'From Cuis 2.0 of 24 February 2010 [latest update: #440] on 2 March 2010 at 10:36:18 am'!

!Object methodsFor: 'copying' stamp: 'jmv 3/2/2010 10:01'!
veryDeepCopyUsing: copier
	"Do a complete tree copy using a dictionary.  An object in the tree twice is only copied once.  All references to the object in the copy of the tree will point to the new copy.
	Same as veryDeepCopy except copier (with dictionary) is supplied.
	** do not delete this method, even if it has no callers **"

	| new refs newDep newModel |
	new _ self veryDeepCopyWith: copier.
	copier references associationsDo: [:assoc | 
		assoc value veryDeepFixupWith: copier].
	"Fix dependents"
	refs _ copier references.
	DependentsFields associationsDo: [:pair |
		pair value do: [:dep | 
			(newDep _ refs at: dep ifAbsent: nil) ifNotNil: [
				newModel _ refs at: pair key ifAbsent: [pair key].
				newModel addDependent: newDep]]].
	^ new! !

!Object methodsFor: 'copying' stamp: 'jmv 3/2/2010 10:16'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
	| class index sub subAss new sup has mine |
	deepCopier references at: self ifPresent: [:newer | ^ newer]. 	"already did him"
	class _ self class.
	class isMeta ifTrue: [^ self].		"a class"
	new _ self clone.
	deepCopier references at: self put: new.	"remember"
	(class isVariable and: [class isPointers]) ifTrue: 
		[index _ self basicSize.
		[index > 0] whileTrue: 
			[sub _ self basicAt: index.
			(subAss _ deepCopier references associationAt: sub ifAbsent: nil)
				ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)]
				ifNotNil: [new basicAt: index put: subAss value].
			index _ index - 1]].
	"Ask each superclass if it wants to share (weak copy) any inst vars"
	new veryDeepInner: deepCopier.		"does super a lot"

	"other superclasses want all inst vars deep copied"
	sup _ class.  index _ class instSize.
	[has _ sup compiledMethodAt: #veryDeepInner: ifAbsent: nil.
	has _ has notNil.
	mine _ sup instVarNames.
	has ifTrue: [index _ index - mine size]	"skip inst vars"
		ifFalse: [1 to: mine size do: [:xx |
				sub _ self instVarAt: index.
				(subAss _ deepCopier references associationAt: sub ifAbsent: nil)
						"use association, not value, so nil is an exceptional value"
					ifNil: [new instVarAt: index put: 
								(sub veryDeepCopyWith: deepCopier)]
					ifNotNil: [new instVarAt: index put: subAss value].
				index _ index - 1]].
	(sup _ sup superclass) == nil] whileFalse.
	new rehash.	"force Sets and Dictionaries to rehash"
	^ new
! !

!Object methodsFor: 'dependents access' stamp: 'jmv 3/2/2010 10:00'!
myDependents
	"Private. Answer a list of all the receiver's dependents."

	^ DependentsFields at: self ifAbsent: nil! !

!Object methodsFor: 'dependents access' stamp: 'jmv 3/2/2010 10:00'!
myDependents: aCollectionOrNil
	"Private. Set (or remove) the receiver's dependents list."

	aCollectionOrNil
		ifNil: [DependentsFields removeKey: self ifAbsent: nil]
		ifNotNil: [DependentsFields at: self put: aCollectionOrNil]! !

!Object methodsFor: 'events-accessing' stamp: 'jmv 3/2/2010 10:00'!
actionForEvent: anEventSelector
    "Answer the action to be evaluated when <anEventSelector> has been triggered."

	^self actionMap ifNotNil: [ :map |
		map
			at: anEventSelector asSymbol
			ifAbsent: nil]! !

!Object methodsFor: 'events-removing' stamp: 'jmv 3/2/2010 10:00'!
removeActionsForEvent: anEventSelector

	| map |
	map _ self actionMap.
	map ifNotNil: [
		map removeKey: anEventSelector asSymbol ifAbsent: nil.
		map isEmpty
			ifTrue: [ self releaseActionMap ]]! !


!AbstractEvent methodsFor: 'private-accessing' stamp: 'jmv 3/2/2010 09:23'!
environmentAt: anItemKind

	(self itemKind = anItemKind) ifTrue: [^self item].
	^environment at: anItemKind ifAbsent: nil! !


!Archive methodsFor: 'archive operations' stamp: 'jmv 3/2/2010 08:56'!
memberNamed: aString
	"Return the first member whose zip name or local file name matches aString, or nil"
	^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: nil! !


!Association methodsFor: 'objects from disk' stamp: 'jmv 3/2/2010 09:24'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  If I am a known global, write a proxy that will hook up with the same resource in the destination system."

	^ (Smalltalk associationAt: key ifAbsent: nil) == self 
		ifTrue: [dp _ DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt: 
							args: (Array with: key).
			refStrm replace: self with: dp.
			dp]
		ifFalse: [self]! !


!Behavior methodsFor: 'obsolete subclasses' stamp: 'jmv 3/2/2010 09:01'!
obsoleteSubclasses
	"Return all the weakly remembered obsolete subclasses of the receiver"
	| obs |
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	obs _ ObsoleteSubclasses at: self ifAbsent:[^#()].
	obs _ obs copyWithout: nil.
	obs isEmpty
		ifTrue: [ ObsoleteSubclasses removeKey: self ifAbsent: nil ]
		ifFalse: [ ObsoleteSubclasses at: self put: obs].
	^obs! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'jmv 3/2/2010 09:01'!
removeAllObsoleteSubclasses
	"Remove all the obsolete subclasses of the receiver"
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	ObsoleteSubclasses removeKey: self ifAbsent: nil! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'jmv 3/2/2010 09:01'!
removeObsoleteSubclass: aClass
	"Remove aClass from the weakly remembered obsolete subclasses"
	| obs |
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	obs _ ObsoleteSubclasses at: self ifAbsent:[^ self].
	(obs includes: aClass) ifFalse:[^self].
	obs _ obs copyWithout: aClass.
	obs _ obs copyWithout: nil.
	obs isEmpty
		ifTrue: [ObsoleteSubclasses removeKey: self ifAbsent: nil]
		ifFalse: [ObsoleteSubclasses at: self put: obs]! !


!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 3/2/2010 09:33'!
valueSupplyingAnswers: aListOfPairs
	"evaluate the block using a list of questions / answers that might be called upon to
	automatically respond to Object>>confirm: or FillInTheBlank requests"

	^ [self value] 
		on: ProvideAnswerNotification
		do: 
			[:notify | | answer caption |
			
			caption := notify messageText withSeparatorsCompacted. "to remove new lines"
			answer := aListOfPairs
				detect: [ :each | 
						caption = each first or:
						[caption includesSubstring: each first caseSensitive: false] or:
						[each first match: caption]]
				ifNone: nil.
			answer
				ifNotNil: [notify resume: answer second]
				ifNil: 
					[ | outerAnswer |
					outerAnswer := ProvideAnswerNotification signal: notify messageText.
					outerAnswer 
						ifNil: [notify resume] 
						ifNotNil: [notify resume: outerAnswer]]]! !

!BlockClosure methodsFor: 'private' stamp: 'jmv 3/2/2010 09:32'!
grabProcessorOnlyFor: milliseconds
	"Grab the CPU above most application processes and evaluate, but only for some milliseconds.
	Return to usual prority after that and finish evaluation if incomplete."

	^self grabProcessorFor: milliseconds onTimeout: nil! !


!BlockContext methodsFor: 'evaluating' stamp: 'jmv 3/2/2010 09:33'!
valueSupplyingAnswers: aListOfPairs
	"evaluate the block using a list of questions / answers that might be called upon to
	automatically respond to Object>>confirm: or FillInTheBlank requests"

	^ [self value] 
		on: ProvideAnswerNotification
		do: 
			[:notify | | answer caption |
			
			caption := notify messageText withSeparatorsCompacted. "to remove new lines"
			answer := aListOfPairs
				detect: 
					[:each | caption = each first or:
						[caption includesSubstring: each first caseSensitive: false] or:
						[each first match: caption]]
				ifNone: nil.
			answer
				ifNotNil: [notify resume: answer second]
				ifNil: 
					[ | outerAnswer |
					outerAnswer := ProvideAnswerNotification signal: notify messageText.
					outerAnswer 
						ifNil: [notify resume] 
						ifNotNil: [notify resume: outerAnswer]]]! !

!BlockContext methodsFor: 'private' stamp: 'jmv 3/2/2010 09:33'!
grabProcessorOnlyFor: milliseconds
	"Grab the CPU above most application processes and evaluate, but only for some milliseconds.
	Return to usual prority after that and finish evaluation if incomplete."

	^self grabProcessorFor: milliseconds onTimeout: nil! !


!BlockNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/2/2010 09:34'!
addRemoteTemp: aTempVariableNode rootNode: rootNode "<MethodNode>"

	"Add aTempVariableNode to my actualScope's sequence of
	 remote temps.  If I am an optimized block then the actual
	 scope is my actualScopeIfOptimized, otherwise it is myself."
	remoteTempNode ifNil: [
		remoteTempNode := RemoteTempVectorNode new
								name: self remoteTempNodeName
								index: arguments size + temporaries size
								type: LdTempType
								scope: 0.
		 actualScopeIfOptimized
			ifNil: [
				self addTempNode: remoteTempNode.
				remoteTempNode definingScope: self]
			ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]].
	remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder.
	
	"use remove:ifAbsent: because the deferred analysis for optimized
	 loops can result in the temp has already been hoised into the root."
	self removeTempNode: aTempVariableNode ifAbsent: [
		self actualScope removeTempNode: aTempVariableNode ifAbsent: nil "should not happen"].
	^remoteTempNode! !

!BlockNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 09:34'!
printOn: aStream indent: level

	"statements size <= 1 ifFalse: [aStream crtab: level]."
	aStream nextPut: $[.
	self printArgumentsOn: aStream indent: level.
	(self printTemporaries: temporaries on: aStream doPrior: nil) ifTrue: [
		"If >0 temps and >1 statement, put all statements on separate lines"
		 statements size > 1
			ifTrue: [aStream crtab: level]
			ifFalse: [aStream space]].
	self printStatementsOn: aStream indent: level.
	aStream nextPut: $]! !


!Categorizer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:36'!
changeFromCategorySpecs: categorySpecs 
	"Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment."

	| oldElements newElements newCategories newStops currentStop temp cc catSpec |
	oldElements _ elementArray asSet.
	newCategories _ Array new: categorySpecs size.
	newStops _ Array new: categorySpecs size.
	currentStop _ 0.
	newElements _ WriteStream on: (Array new: 16).
	1 to: categorySpecs size do: 
		[:i | 
		catSpec _ categorySpecs at: i.
		newCategories at: i put: catSpec first asSymbol.
		catSpec allButFirst asSortedCollection do:
			[:elem |
			(oldElements remove: elem ifAbsent: nil) notNil ifTrue: [
				newElements nextPut: elem.
				currentStop _ currentStop+1]].
		newStops at: i put: currentStop].

	"Ignore extra elements but don't lose any existing elements!!"
	oldElements _ oldElements collect:
		[:elem | Array with: (self categoryOfElement: elem) with: elem].
	newElements _ newElements contents.
	categoryArray _ newCategories.
	(cc _ categoryArray asSet) size = categoryArray size ifFalse: [ "has duplicate element"
		temp _ categoryArray asOrderedCollection.
		temp removeAll: categoryArray asSet asOrderedCollection.
		temp do: [ :each | | dup ii |
			dup _ each.
			ii _ categoryArray indexOf: dup.
			[ dup _ (dup,' #2') asSymbol.  cc includes: dup ] whileTrue.
			cc add: dup.
			categoryArray at: ii put: dup]].
	categoryStops _ newStops.
	elementArray _ newElements.
	oldElements do: [:pair | self classify: pair last under: pair first].! !


!BasicClassOrganizer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:31'!
dateCommentLastSubmitted
	"Answer a Date object indicating when my class comment was last submitted.  If there is no date stamp, or one of the old-time <historical>  guys, return nil"
	"RecentMessageSet organization dateCommentLastSubmitted"

	| aStamp tokens |
	(aStamp _ self commentStamp) isEmptyOrNil ifTrue: [^ nil].
	tokens _ aStamp findBetweenSubStrs: ' 
'.  "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance"
	^ tokens size > 1
		ifTrue: [
			[tokens second asDate] ifError: nil]! !


!ChangeRecord methodsFor: 'access' stamp: 'jmv 3/2/2010 09:38'!
originalChangeSetForSelector: methodSelector
	"Returns the original changeset which contained this method version.  If it is contained in the .sources file, return #sources.  If it is in neither (e.g. its changeset was deleted), return nil.  (The selector is passed in purely as an optimization.)"

	| likelyChangeSets originalChangeSet |
	(file localName findTokens: '.') last = 'sources'
		ifTrue: [^ #sources].
	likelyChangeSets _ ChangeSorter allChangeSets select: 
		[:cs | (cs atSelector: methodSelector class: self methodClass) ~~ #none].
	originalChangeSet _ likelyChangeSets
		detect: [:cs | cs containsMethodAtPosition: position]
		ifNone: nil.
	^ originalChangeSet  "(still need to check for sources file)"! !


!ChangeSet methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:42'!
editPostscript
	"edit the receiver's postscript, in a separate window.  "

	| deps found |
	self assurePostscriptExists.
	deps := postscript dependents 
				select: [ :m | m is: #SystemWindow].
	deps size > 0 
		ifTrue: [
			found := deps detect: [:obj | (obj is: #SystemWindow) and: [obj world == self currentWorld]] ifNone: nil.
			found ifNotNil: [^found activate].

			self 
				inform: 'Caution -- there' , (deps size isOrAreStringWith: 'other window') 
						, '
already open on this postscript elsewhere'].
	postscript openLabel: 'Postscript for ChangeSet named ' , name! !

!ChangeSet methodsFor: 'class changes' stamp: 'jmv 3/2/2010 09:43'!
noteClassForgotten: className
	"Remove from structures if class is not a superclass of some other one we are remembering"

	structures ifNil: [^ self].
	Smalltalk at: className ifPresent: [:cls |
		cls subclasses do: [:sub | (structures includesKey: sub) ifTrue: [
			^ self]]].  "No delete"
	structures removeKey: className ifAbsent: nil! !

!ChangeSet methodsFor: 'class changes' stamp: 'jmv 3/2/2010 09:43'!
noteRemovalOf: class
	"The class is about to be removed from the system.
	Adjust the receiver to reflect that fact."

	class wantsChangeSetLogging ifFalse: [^ self].
	(self changeRecorderFor: class)
		noteChangeType: #remove fromClass: class.
	changeRecords removeKey: class class name ifAbsent: nil! !

!ChangeSet methodsFor: 'moving changes' stamp: 'jmv 3/2/2010 09:42'!
methodsWithAnyInitialsOtherThan: myInits
	"Return a collection of method refs whose author appears to be different from the given one, even historically"
	| slips |
	slips _ Set new.
	self changedClasses do: [:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc | | method |
			(#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [
				method _ aClass compiledMethodAt: mAssoc key ifAbsent: nil.
				method ifNotNil: [
					(aClass changeRecordsAt: mAssoc key) do: [ :chg | | aTimeStamp |
						aTimeStamp _ chg stamp.
						(aTimeStamp notNil and: [(aTimeStamp beginsWith: myInits) not])
							ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]].
	^ slips! !

!ChangeSet methodsFor: 'moving changes' stamp: 'jmv 3/2/2010 09:42'!
methodsWithInitialsOtherThan: myInits
	"Return a collection of method refs whose author appears to be different from the given one"
	| slips |
	slips _ OrderedCollection new.
	self changedClasses do: [ :aClass |
		(self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc | | method |
				(#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [
					method _ aClass compiledMethodAt: mAssoc key ifAbsent: nil.
					method ifNotNil: [ | aTimeStamp |
						((aTimeStamp _ Utilities timeStampForMethod: method) notNil and: [
							(aTimeStamp beginsWith: myInits) not])
								ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips

	"Smalltalk browseMessageList: (ChangeSet current methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"! !

!ChangeSet methodsFor: 'moving changes' stamp: 'jmv 3/2/2010 09:43'!
removeClassAndMetaClassChanges: class
	"Remove all memory of changes associated with this class and its metaclass.  7/18/96 sw"

	changeRecords removeKey: class name ifAbsent: nil.
	changeRecords removeKey: class class name ifAbsent: nil! !

!ChangeSet methodsFor: 'moving changes' stamp: 'jmv 3/2/2010 09:43'!
removeClassChanges: class
	"Remove all memory of changes associated with this class"
	| cname |
	cname _ (class isKindOf: String)
		ifTrue: [ class ]
		ifFalse: [ class name ].

	changeRecords removeKey: cname ifAbsent: nil.
	self noteClassForgotten: cname! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 3/2/2010 09:39'!
askRenames: renamed addTo: msgSet using: smart
	| list |
	"Go through the renamed classes.  Ask the user if it could be in a project.  Add a method in SmartRefStream, and a conversion method in the new class."

	list _ OrderedCollection new.
	renamed do: [ :cls | | rec |
		rec _ changeRecords at: cls name.
		rec priorName ifNotNil: [
			| ans |
			ans _ PopUpMenu withCaption: 'You renamed class ', rec priorName, 
				' to be ', rec thisName,
				'.\Could an instance of ', rec priorName, 
				' be in a project on someone''s disk?'
			chooseFrom: #('Yes, write code to convert those instances'
				'No, no instances are in projects').
			ans = 1 ifTrue: [
				| oldStruct newStruct  |
				oldStruct _ structures at: rec priorName ifAbsent: nil.
				newStruct _ (Array with: cls classVersion), (cls allInstVarNames).
				oldStruct ifNotNil: [
					smart writeConversionMethodIn: cls fromInstVars: oldStruct 
							to: newStruct renamedFrom: rec priorName.
					smart writeClassRename: cls name was: rec priorName.
					list add: cls name, ' convertToCurrentVersion:refStream:']]
			ifFalse: [structures removeKey: rec priorName ifAbsent: nil]]].
	list isEmpty ifTrue: [^ msgSet].
	msgSet messageList ifNil: [msgSet initializeMessageList: list]
		ifNotNil: [list do: [:item | msgSet addItem: item]].
	^ msgSet! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 3/2/2010 10:16'!
checkForConversionMethods
	"See if any conversion methods are needed"
	| tell choice list smart restore renamed listAdd listDrop msgSet |

	Preferences conversionMethodsAtFileOut ifFalse: [^ self].	"Check preference"
	structures ifNil: [^ self].

	list _ OrderedCollection new.
	renamed _ OrderedCollection new.
	self changedClasses do: [ :class | | oldStruct newStruct need sel rec |
		need _ (self atClass: class includes: #new) not.
		need ifTrue: ["Renamed classes."
			(self atClass: class includes: #rename) ifTrue: [
				rec _ changeRecords at: class name.
				rec priorName ifNotNil: [
					(structures includesKey: rec priorName) ifTrue: [
						renamed add: class.  need _ false]]]].
		need ifTrue: [need _ (self atClass: class includes: #change)].
		need ifTrue: [oldStruct _ structures at: class name 
									ifAbsent: [need _ false.  #()]].
		need ifTrue: [
			newStruct _ (Array with: class classVersion), (class allInstVarNames).
			need _ (oldStruct ~= newStruct)].
		need ifTrue: [sel _ #convertToCurrentVersion:refStream:.
			(#(add change) includes: (self atSelector: sel class: class)) ifFalse: [
				list add: class]].
		].

	list isEmpty & renamed isEmpty ifTrue: [^ self].
	"Ask user if want to do this"
	tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString,
		'\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\'
			withCRs,
		'After you edit the conversion method, you''ll need to fileOut again.\' withCRs,
		'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'.
	choice _ (PopUpMenu labels: 
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.') startUpWithCaption: tell. 
	choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
	choice = 2 ifTrue: ["Don't consider this class again in the changeSet"
			list do: [:cls | structures removeKey: cls name ifAbsent: nil].
			renamed do: [:cls | | nn |
				nn _ (changeRecords at: cls name) priorName.
				structures removeKey: nn ifAbsent: nil]].
	choice ~= 1 ifTrue: [^ self].	"exit if choice 2,3,4"

	listAdd _ self askAddedInstVars: list.	"Go through each inst var that was added"
	listDrop _ self askRemovedInstVars: list.	"Go through each inst var that was removed"
	list _ (listAdd, listDrop) asSet asArray.

	smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345').
	smart structures: structures.
	smart superclasses: superclasses.
	(restore _ self class current) == self ifFalse: [
		self class  newChanges: self].	"if not current one"
	msgSet _ smart conversionMethodsFor: list.
		"each new method is added to self (a changeSet).  Then filed out with the rest."
	self askRenames: renamed addTo: msgSet using: smart.	"renamed classes, add 2 methods"
	restore == self ifFalse: [self class newChanges: restore].
	msgSet messageList isEmpty ifTrue: [^ self].
	self inform: 'Remember to fileOut again after modifying these methods.'.
	MessageSet open: msgSet name: 'Conversion methods for ', self name.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 3/2/2010 09:42'!
checkForSlips
	"Return a collection of method refs with possible debugging code in them."
	| slips |
	slips _ OrderedCollection new.
	self changedClasses do: [ :aClass |
		(self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc |  | method |
			(#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [
				method _ aClass compiledMethodAt: mAssoc key ifAbsent: nil.
				method ifNotNil: [
					method hasReportableSlip
						ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips! !


!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 3/2/2010 10:16'!
name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe
	"Define a new class.
	If unsafe is true do not run any validation checks.
	This facility is provided to implement important system changes."
	| oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory |
	instVars _ Smalltalk actualScannerClass new scanFieldNames: instVarString.
	classVars _ (Smalltalk actualScannerClass new scanFieldNames: classVarString) collect: [:x | x asSymbol].

	"Validate the proposed name"
	unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]].
	oldClass _ Smalltalk at: className ifAbsent: nil.
	oldClass isBehavior 
		ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:"
	copyOfOldClass _ oldClass copy.

	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil].
		(self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]].

	"See if we need a new subclass"
	needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass.
	needNew ifNil: [^nil]. "some error"

	(needNew and:[unsafe not]) ifTrue:[
		"Make sure we don't redefine any dangerous classes"
		(self tooDangerousClasses includes: oldClass name) ifTrue:[
			self error: oldClass name, ' cannot be changed'.
		].
		"Check if the receiver should not be redefined"
		(oldClass notNil and:[oldClass shouldNotBeRedefined]) ifTrue:[
			self notify: oldClass name asText allBold, 
						' should not be redefined!! \Proceed to store over it.' withCRs]].

	needNew ifTrue:[
		"Create the new class"
		newClass _ self 
			newSubclassOf: newSuper 
			type: type 
			instanceVariables: instVars
			from: oldClass.
		newClass ifNil: [ ^nil]. "Some error"
		newClass setName: className.
	] ifFalse:[
		"Reuse the old class"
		newClass _ oldClass.
	].

	"Install the class variables and pool dictionaries... "
	force _ (newClass declare: classVarString) | (newClass sharing: poolString).

	"... classify ..."
	newCategory _ category asSymbol.
	organization _ Smalltalk organization.
	oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol].
	organization classify: newClass name under: newCategory.

	"... recompile ..."
	newClass _ self recompile: force from: oldClass to: newClass mutate: false.

	"... export if not yet done ..."
	(Smalltalk at: newClass name ifAbsent: nil) == newClass ifFalse:[
		[Smalltalk at: newClass name put: newClass]
			on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true].
		Smalltalk flushClassNameCache.
	].

	self doneCompiling: newClass.
	
	"... notify interested clients ..."
	oldClass isNil ifTrue: [
		SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory.
		^ newClass].
	SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.
	newCategory ~= oldCategory 
		ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category].
	^newClass! !

!ClassBuilder methodsFor: 'private' stamp: 'jmv 3/2/2010 09:46'!
showProgressFor: aClass
	"Announce that we're processing aClass"
	progress
		ifNil: [^ self].
	aClass isObsolete ifTrue:[^self].
	currentClassIndex _ currentClassIndex + 1.
	(aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue: [
		[	"As we might be recompiling the  lasses involved in showing progress, ignore errors. After all, they are harmless."
			progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')
		] on: Error do: nil]! !

!ClassBuilder methodsFor: 'public' stamp: 'jmv 3/2/2010 09:46'!
superclass: aClass
	variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	| oldClassOrNil actualType |
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
	(aClass isVariable and: [aClass isWords])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields'].
	oldClassOrNil := aClass environment at: t ifAbsent: nil.
	actualType := (oldClassOrNil notNil
				   and: [oldClassOrNil typeOfClass == #compiledMethod])
					ifTrue: [#compiledMethod]
					ifFalse: [#bytes].
	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: actualType
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !


!ClassChangeRecord methodsFor: 'all changes' stamp: 'jmv 3/2/2010 09:47'!
noteChangeType: changeSymbol fromClass: class

	(changeSymbol = #new or: [changeSymbol = #add]) ifTrue: [
		changeTypes add: #add.
		changeTypes remove: #change ifAbsent: nil.
		^ self].
	changeSymbol = #change ifTrue: [
		(changeTypes includes: #add) ifTrue: [^ self].
		^ changeTypes add: changeSymbol].
	changeSymbol == #addedThenRemoved ifTrue:
		[^ self].  "An entire class was added but then removed"
	changeSymbol = #comment ifTrue:
		[^ changeTypes add: changeSymbol].
	changeSymbol = #reorganize ifTrue:
		[^ changeTypes add: changeSymbol].
	changeSymbol = #rename ifTrue:
		[^ changeTypes add: changeSymbol].
	(changeSymbol beginsWith: 'oldName: ') ifTrue: [
		"Must only be used when assimilating other changeSets"
		(changeTypes includes: #add) ifTrue: [^ self].
		priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size.
		^ changeTypes add: #rename].
	changeSymbol = #remove ifTrue: [
		(changeTypes includes: #add)
			ifTrue: [changeTypes add: #addedThenRemoved]
			ifFalse: [changeTypes add: #remove].
		^ changeTypes removeAllFoundIn: #(add change comment reorganize)].

	self error: 'Unrecognized changeType'! !

!ClassChangeRecord methodsFor: 'removal' stamp: 'jmv 3/2/2010 09:46'!
forgetChangesIn: otherRecord
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	| cls otherMethodChanges |
	(cls := self realClass) ifNil: [^ self].  "We can do better now, though..."
	otherMethodChanges := otherRecord methodChangeTypes.
	otherMethodChanges associationsDo:
		[:assoc | | selector actionToSubtract |
		selector := assoc key. actionToSubtract := assoc value.
		(cls includesSelector: selector)
			ifTrue: [(#(add change) includes: actionToSubtract)
					ifTrue: [methodChanges removeKey: selector ifAbsent: nil]]
			ifFalse: [(#(remove addedThenRemoved) includes: actionToSubtract)
					ifTrue: [methodChanges removeKey: selector ifAbsent: nil]]].
	changeTypes isEmpty ifFalse: [
		changeTypes removeAllFoundIn: otherRecord allChangeTypes.
		(changeTypes includes: #rename) ifFalse: [
			changeTypes removeAllSuchThat: [:x | x beginsWith: 'oldName: ']]]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'jmv 3/2/2010 09:47'!
removeSelector: selector
	"Remove all memory of changes associated with the argument, selector, in this class."

	selector == #Comment
		ifTrue:
			[changeTypes remove: #comment ifAbsent: nil]
		ifFalse:
			[methodChanges removeKey: selector ifAbsent: nil]! !


!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'jmv 3/2/2010 09:47'!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor
	| priorMethodOrNil |
	priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: nil.
	self addSelectorSilently: selector withMethod: compiledMethod.
	SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category].
	priorMethodOrNil isNil
		ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor]
		ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'jmv 3/2/2010 09:47'!
addSelector: selector withMethod: compiledMethod notifying: requestor
	| priorMethodOrNil |
	priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: nil.
	self addSelectorSilently: selector withMethod: compiledMethod.
	priorMethodOrNil isNil
		ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor]
		ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'jmv 3/2/2010 09:47'!
allMethodCategoriesIntegratedThrough: mostGenericClass
	"Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass"

	| aColl |
	aColl _ OrderedCollection new.
	self withAllSuperclasses do:
		[:aClass |
			(aClass includesBehavior: mostGenericClass)
				ifTrue:	[aColl addAll: aClass organization categories]].
	aColl remove: 'no messages' asSymbol ifAbsent: nil.

	^ (aColl asSet asSortedCollection: [:a :b | a asLowercase < b asLowercase]) asArray

"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! !

!ClassDescription methodsFor: 'private' stamp: 'jmv 3/2/2010 09:48'!
logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor
	| priorMethodOrNil |
	priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: nil.
	aCompiledMethodWithNode method putSource: aText asString
		fromParseNode: aCompiledMethodWithNode node
		class: self category: category withStamp: changeStamp 
		inFile: 2 priorMethod: priorMethodOrNil.! !


!Class methodsFor: 'testing' stamp: 'jmv 3/2/2010 09:44'!
isObsolete
	"Return true if the receiver is obsolete."
	^(Smalltalk at: name ifAbsent: nil) ~~ self! !


!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 3/2/2010 09:23'!
familyName: aString pointSize: aNumber
	"
	AbstractFont familyName: 'DejaVu' pointSize: 12
	"
	| familyDictionary |
	familyDictionary _ AvailableFonts at: aString ifAbsent: [^nil].
	^familyDictionary at: aNumber ifAbsent: nil! !


!AbstractSound class methodsFor: 'sound library' stamp: 'jmv 3/2/2010 09:00'!
updateFMSounds
	"AbstractSound updateFMSounds"

	Sounds keys do: [:k |
		((Sounds at: k) isKindOf: FMSound) ifTrue: [
			Sounds removeKey: k ifAbsent: nil]].

	(FMSound class organization listAtCategoryNamed: #instruments) do:
		[:sel | Sounds at: sel asString put: (FMSound perform: sel)].
! !


!ActiveModel class methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:00'!
actionMapFor: anObject

    ^self actionMaps
        at: anObject
        ifAbsent: nil! !

!ActiveModel class methodsFor: 'releasing' stamp: 'jmv 3/2/2010 09:00'!
releaseActionMapFor: anObject

	self actionMaps
		removeKey: anObject
		ifAbsent: nil! !

!ActiveModel class methodsFor: 'initialize-release' stamp: 'jmv 3/2/2010 09:24'!
flushEvents
	"Object flushEvents"
	self actionMaps keysAndValuesDo: [ :rcvr :evtDict | 
		rcvr ifNotNil:[
			"make sure we don't modify evtDict while enumerating"
			evtDict keys do: [ :evtName | | msgSet |
				msgSet _ evtDict at: evtName ifAbsent: nil.
				msgSet ifNil: [ rcvr removeActionsForEvent: evtName]]]].
	ActiveModel actionMaps finalizeValues. ! !


!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 09:00'!
unregister: aProviderClass
	(default = aProviderClass) ifTrue: [default _ nil].
	self registeredClasses remove: aProviderClass ifAbsent: nil! !


!Collection methodsFor: 'removing' stamp: 'jmv 3/2/2010 09:49'!
removeAllFoundIn: aCollection 
	"Remove each element of aCollection which is present in the receiver 
	from the receiver. Answer aCollection. No error is raised if an element
	isn't found. ArrayedCollections cannot respond to this message."

	aCollection do: [:each | self remove: each ifAbsent: nil].
	^ aCollection! !


!Compiler methodsFor: 'public access' stamp: 'jmv 3/2/2010 09:51'!
parse: textOrStream in: aClass notifying: req
	"Compile the argument, textOrStream, with respect to the class, aClass, and
	 answer the MethodNode that is the root of the resulting parse tree.  Notify the
	 argument, req, if an error occurs. The failBlock is defaulted to an empty block."

	self from: textOrStream class: aClass context: nil notifying: req.
	^self parser
		parse: sourceStream
		class: class
		noPattern: false
		context: context
		notifying: requestor
		ifFail: nil! !


!ConnectionQueue methodsFor: 'private' stamp: 'jmv 3/2/2010 09:51'!
oldStyleListenLoop
	"Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port."
	"Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection."
	"Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms."

	[true] whileTrue: [
		((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [
			"try to create a new socket for listening"
			socket _ Socket createIfFail: nil].

		socket
			ifNil: [(Delay forMilliseconds: 100) wait]
			ifNotNil: [
				socket isUnconnected ifTrue: [socket listenOn: portNumber].
				[socket waitForConnectionFor: 10]
					on: ConnectionTimedOut
					do: [:ex |
						socket isConnected
							ifTrue: [  "connection established"
								accessSema critical: [connections addLast: socket].
								socket _ nil]
							ifFalse: [
								socket isWaitingForConnection
									ifFalse: [socket destroy. socket _ nil]]]].  "broken socket; start over"
		self pruneStaleConnections].
! !


!Cursor class methodsFor: 'current cursor' stamp: 'jmv 3/2/2010 09:52'!
currentCursor: aCursor 
	"Make the instance of cursor, aCursor, be the current cursor. Display it. 
	Create an error if the argument is not a Cursor."

	(aCursor isKindOf: self)
		ifTrue: [
			CurrentCursor _ aCursor.
			Preferences biggerCursors
				ifTrue: [
					[ ^aCursor asBigCursor beCursor] 
						on: Error do: nil  "fall through "].
			aCursor beCursor]
		ifFalse: [ self error: 'The new cursor must be an instance of class Cursor' ]! !


!Decompiler methodsFor: 'instruction decoding' stamp: 'jmv 3/2/2010 09:52'!
pushReceiverVariable: offset

	| var |
	(var := instVars at: offset + 1 ifAbsent: nil)
		ifNil: [
			"Not set up yet"
			var := constructor codeInst: offset.
			instVars size < (offset + 1) ifTrue: [
				instVars := (Array new: offset + 1)
					replaceFrom: 1 to: instVars size with: instVars; yourself ].
			instVars at: offset + 1 put: var].
	stack addLast: var! !


!DecompilerTests methodsFor: 'utilities' stamp: 'jmv 3/2/2010 09:52'!
checkDecompileMethod: oldMethod
	
	| cls selector oldMethodNode methodNode newMethod oldCodeString newCodeString |
	cls := oldMethod methodClass.
	selector := oldMethod selector.
	oldMethodNode := cls decompilerClass new
						decompile: selector
						in: cls
						method: oldMethod.
	[oldMethodNode properties includesKey: #warning] whileTrue:
		[oldMethodNode properties removeKey: #warning].
	oldCodeString := oldMethodNode decompileString.
	methodNode := [cls compilerClass new
						compile: oldCodeString
						in: cls
						notifying: nil
						ifFail: nil]
						on: SyntaxErrorNotification
						do: [:ex|
							ex errorMessage = 'Cannot store into' ifTrue:
								[ex return: #badStore].
							ex pass].
	"Ignore cannot store into block arg errors; they're not our issue."
	methodNode ~~ #badStore ifTrue:
		[newMethod := methodNode generate: #(0 0 0 0).
		 newCodeString := (cls decompilerClass new
							decompile: selector
							in: cls
							method: newMethod) decompileString.
		 "(StringHolder new textContents:
			(TextDiffBuilder buildDisplayPatchFrom: oldCodeString to: newCodeString))
				openLabel: 'Decompilation Differences for ', cls name,'>>',selector"
		 "(StringHolder new textContents:
			(TextDiffBuilder buildDisplayPatchFrom: oldMethod abstractSymbolic to: newMethod abstractSymbolic))
				openLabel: 'Bytecode Differences for ', cls name,'>>',selector"
		 self assert: oldCodeString = newCodeString
			description: cls name asString, ' ', selector asString
			resumable: true]! !


!DeepCopier methodsFor: 'like fullCopy' stamp: 'jmv 3/2/2010 09:53'!
fixDependents
	"They are not used much, but need to be right"

	DependentsFields associationsDo:
		[:pair |
		pair value do:
			[:dep |
			(references at: dep ifAbsent: nil) ifNotNil:
				[:newDep| | newModel |
				newModel := references at: pair key ifAbsent: [pair key].
				newModel addDependent: newDep]]]! !


!Delay class methodsFor: 'timer process' stamp: 'jmv 3/2/2010 09:53'!
unscheduleDelay: aDelay
	"Private. Unschedule this Delay."
	aDelay beingWaitedOn ifFalse:[^self].
	ActiveDelay == aDelay ifTrue: [
		SuspendedDelays isEmpty ifTrue:[
			ActiveDelay := nil.
		] ifFalse: [
			ActiveDelay := SuspendedDelays removeFirst.
		]
	] ifFalse:[
		SuspendedDelays remove: aDelay ifAbsent: nil.
	].
	aDelay beingWaitedOn: false.! !


!DiskProxy methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 09:53'!
simpleGlobalOrNil
	"Return the object I refer to if it is a simple global in Smalltalk."

	preSelector ifNotNil: [^ nil].
	constructorSelector == #yourself ifFalse: [^ nil].
	^ Smalltalk at: globalObjectName ifAbsent: nil
! !


!ElementCategory methodsFor: 'elements' stamp: 'jmv 3/2/2010 09:53'!
elementAt: aKey
	"Answer the element at the given key"

	^ elementDictionary at: aKey ifAbsent: nil! !

!ElementCategory methodsFor: 'elements' stamp: 'jmv 3/2/2010 09:54'!
removeElementAt: aKey
	"Remove the element at the given key"

	elementDictionary removeKey: aKey ifAbsent: [^ self].
	keysInOrder remove: aKey ifAbsent: nil! !


!Encoder methodsFor: 'results' stamp: 'jmv 3/2/2010 09:54'!
associationForClass
	| assoc |
	assoc := self environment associationAt: class name ifAbsent: nil.
	^assoc value == class
		ifTrue: [assoc]
		ifFalse: [Association new value: class]! !

!Encoder methodsFor: 'temps' stamp: 'jmv 3/2/2010 09:54'!
fixTemp: name
	| node |
	node := scopeTable at: name ifAbsent: nil.
	node class ~~ TempVariableNode ifTrue:
		[self error: 'can only fix a floating temp var'].
	node index: nTemps.
	nTemps := nTemps + 1.
	^node! !

!Encoder methodsFor: 'temps' stamp: 'jmv 3/2/2010 09:54'!
floatTemp: node
	(node ~~ (scopeTable at: node name ifAbsent: nil)
	or: [node class ~~ TempVariableNode
	or: [node code ~= (node code: nTemps - 1 type: LdTempType)]]) ifTrue: [
		self error: 'can only float the last allocated temp var'].
	nTemps := nTemps - 1! !


!FileDirectory methodsFor: 'enumeration' stamp: 'jmv 3/2/2010 09:55'!
directoryEntryFor: filenameOrPath
	"Answer the directory entry for the given file or path. Sorta like a poor man's stat()."
	| fName dir |
	DirectoryClass splitName: filenameOrPath to:[:filePath :name |
		fName _ name.
		filePath isEmpty
			ifTrue: [dir _ self]
			ifFalse: [dir _ FileDirectory on: filePath]].
	self isCaseSensitive 
		ifTrue:[^dir entries detect:[:entry| entry name = fName] ifNone: nil]
		ifFalse:[^dir entries detect:[:entry| entry name sameAs: fName] ifNone: nil]! !

!FileDirectory methodsFor: 'file operations' stamp: 'jmv 3/2/2010 09:54'!
deleteFileNamed: localFileName
	"Delete the file with the given name in this directory."

	self deleteFileNamed: localFileName ifAbsent: nil! !

!FileDirectory methodsFor: 'file operations' stamp: 'jmv 3/2/2010 09:55'!
mimeTypesFor: fileName
	"Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type"

	| idx ext dot |
	ext _ ''.
	dot _ self class extensionDelimiter.
	idx _ (self fullNameFor: fileName) findLast: [:ch| ch = dot].
	idx = 0 ifFalse:[ext _ fileName copyFrom: idx+1 to: fileName size].
	^StandardMIMEMappings at: ext asLowercase ifAbsent: nil! !


!FormsAndHelpsRepository class methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:56'!
formAtKey: aString
	"Answer the form saved under the given key"

	Symbol hasInterned: aString ifTrue: [ :aKey |
		^ FormDictionary at: aKey ifAbsent: nil].
	^ nil! !


!MIDIFileReader methodsFor: 'track reading' stamp: 'jmv 3/2/2010 09:56'!
endNote: midiKey chan: channel at: endTicks

	| evt |
	evt _ activeEvents
		detect: [:e | (e midiKey = midiKey) and: [e channel = channel]]
		ifNone: [^ self].
	evt duration: (endTicks - evt time).
	activeEvents remove: evt ifAbsent: nil! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jmv 3/2/2010 09:56'!
startNote: midiKey vel: vel chan: chan at: startTicks
	"Record the beginning of a note."
	"Details: Some MIDI scores have missing note-off events, causing a note-on to be received for a (key, channel) that is already sounding. If the previous note is suspiciously long, truncate it."

	| newActiveEvents dur noteOnEvent |
	newActiveEvents _ nil.
	activeEvents do: [:e |
		((e midiKey = midiKey) and: [e channel = chan]) ifTrue: [
			"turn off key already sounding"
			dur _ startTicks - e time.
			dur > maxNoteTicks ifTrue: [dur _ ticksPerQuarter].  "truncate"
			e duration: dur.
			newActiveEvents ifNil: [newActiveEvents _ activeEvents copy].
			newActiveEvents remove: e ifAbsent: nil]].
	newActiveEvents ifNotNil: [activeEvents _ newActiveEvents].

	noteOnEvent _ NoteEvent new key: midiKey velocity: vel channel: chan.
	noteOnEvent time: startTicks.
	track add: noteOnEvent.
	activeEvents add: noteOnEvent! !

!MIDIFileReader methodsFor: 'private' stamp: 'jmv 3/2/2010 09:56'!
guessMissingInstrumentNames
	"Attempt to guess missing instrument names from the first program change in that track."

	| progChange instrIndex instrName |
	1 to: tracks size do: [:i |
		(trackInfo at: i) isEmpty ifTrue: [
			progChange _ (tracks at: i) detect: [:e | e isProgramChange] ifNone: nil.
			progChange ifNotNil: [
				instrIndex _ progChange program + 1.
				instrName _ self class standardMIDIInstrumentNames at: instrIndex.
				trackInfo at: i put: instrName]]].
! !


!MenuIcons class methodsFor: 'menu decoration' stamp: 'jmv 3/2/2010 08:57'!
iconForMenuItem: anItem
	"Answer the icon (or nil) corresponding to the (translated) string."

	^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: nil! !


!MessageTally methodsFor: 'printing' stamp: 'jmv 3/2/2010 09:58'!
printSenderCountsOn: aStream
	| mergedSenders |
	mergedSenders _ IdentityDictionary new.
	senders do: [ :node | | mergedNode |
		mergedNode _ mergedSenders at: node method ifAbsent: nil .
		mergedNode
			ifNil: [ mergedSenders at: node method put: node ]
			ifNotNil: [ mergedNode bump: node tally ]].
	mergedSenders asSortedCollection do: [ :node | 
		10 to: node tally printString size by: -1 do: [ :i | aStream space].
		node printOn: aStream total: tally totalTime: nil tallyExact: true]! !


!MethodNode methodsFor: 'converting' stamp: 'jmv 3/2/2010 09:58'!
asColorizedSmalltalk80Text
	"Answer a colorized Smalltalk-80-syntax string description of the parse tree whose root is the receiver."

	| printText |
	printText := self printString asText.
	^(Smalltalk at: #SHTextStylerST80 ifAbsent: nil)
		ifNotNil: [:stylerClass| stylerClass new styledTextFor: printText]
		ifNil: [printText]! !


!Model methodsFor: 'dependents' stamp: 'jmv 3/2/2010 09:59'!
containingWindow
	"Answer the window that holds the receiver.  The dependents technique is odious and may not be airtight, if multiple windows have the same model."

	^self dependents detect: 
			[:d | 
			(d isKindOf: SystemWindow) 
				and: [d model == self]]
		ifNone: nil! !

!Model methodsFor: 'copying' stamp: 'jmv 3/2/2010 09:59'!
veryDeepFixupWith: deepCopier 
	"See if the dependents are being copied also.  If so, point at the new copies.  (The dependent has self as its model.)
	Dependents handled in class Object, when the model is not a Model, are fixed up in Object veryDeepCopy."

	| originalDependents refs newDependent |
	super veryDeepFixupWith: deepCopier.
	originalDependents _ dependents.
	originalDependents ifNil: [
		^self ].
	dependents _ nil.
	refs _ deepCopier references.
	originalDependents
		do: [:originalDependent | 
			newDependent _ refs
						at: originalDependent
						ifAbsent: nil.
			newDependent
				ifNotNil: [self addDependent: newDependent]]! !


!CodeHolder methodsFor: 'misc' stamp: 'jmv 3/2/2010 09:48'!
refreshAnnotation
	"If the receiver has an annotation pane that does not bear unaccepted edits, refresh it"

	(self dependents
		detect: [ :m | 
			(m is: #HasTextSelector) and: [
				m getTextSelector == #annotation]]
		ifNone: nil)
		
			ifNotNil: [ :aPane | 
				aPane hasUnacceptedEdits ifFalse: [
					aPane update: #annotation]]! !

!CodeHolder methodsFor: 'message list menu' stamp: 'jmv 3/2/2010 09:49'!
selectMessageAndEvaluate: aBlock
	"Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector.  If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any"

	| selector method messages |
	(selector _ self selectedMessageName) ifNil: [^ self].
	method _ (self selectedClassOrMetaClass ifNil: [^ self])
		compiledMethodAt: selector
		ifAbsent: nil.
	(method isNil or: [(messages _ method messages) size = 0])
		 ifTrue: [^ aBlock value: selector].
	(messages size = 1 and: [messages includes: selector])
		ifTrue:
			[^ aBlock value: selector].  "If only one item, there is no choice"

	Smalltalk
		showMenuOf: messages
		withFirstItem: selector
		ifChosenDo: [:sel | aBlock value: sel]! !

!CodeHolder methodsFor: 'message list menu' stamp: 'jmv 3/2/2010 09:49'!
timeStamp
	"Answer the time stamp for the chosen class and method, if any, else an empty string"

	|  selector  aMethod |
	(selector _ self selectedMessageName) ifNotNil: [
		self selectedClassOrMetaClass 
			ifNil: [
				^ String new]
			ifNotNil: [
				aMethod _ self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: nil.
				aMethod ifNotNil: [^ Utilities timeStampForMethod: aMethod]]].
	^ String new! !


!Browser methodsFor: 'class functions' stamp: 'jmv 3/2/2010 09:36'!
explainSpecial: string 
	"Answer a string explaining the code pane selection if it is displaying 
	one of the special edit functions."

	| classes whole lits reply |
	(editSelection == #editClass or: [editSelection == #newClass])
		ifTrue: 
			["Selector parts in class definition"
			string last == $: ifFalse: [^nil].
			lits _ Array with:
				#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:.
			(whole _ lits detect: [:each | (each keywords
					detect: [:frag | frag = string] ifNone: nil) notNil]
						ifNone: nil) notNil
				ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.']
				ifFalse: [^nil].
			classes _ Smalltalk allClassesImplementing: whole.
			classes _ 'these classes ' , classes printString.
			^reply , '  It is defined in ' , classes , '."
Smalltalk browseAllImplementorsOf: #' , whole].

	editSelection == #hierarchy
		ifTrue: 
			["Instance variables in subclasses"
			classes _ self selectedClassOrMetaClass allSubclasses.
			classes _ classes detect: [:each | (each instVarNames
						detect: [:name | name = string] ifNone: nil) notNil]
					ifNone: [^nil].
			classes _ classes printString.
			^'"is an instance variable in class ' , classes , '."
' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
	editSelection == #editSystemCategories ifTrue: [^nil].
	editSelection == #editMessageCategories ifTrue: [^nil].
	^nil! !

!Browser methodsFor: 'message category list' stamp: 'jmv 3/2/2010 09:35'!
categorizeAllUncategorizedMethods
	"Categorize methods by looking in parent classes for a method category."

	| organizer organizers |
	organizer _ self classOrMetaClassOrganizer.
	organizers _ self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization].
	(organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found |
		found _ (organizers collect: [ :org | org categoryOfElement: sel])
			detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]]
			ifNone: nil.
		found ifNotNil: [organizer classify: sel under: found]].

	self changed: #messageCategoryList! !

!Browser methodsFor: 'system category functions' stamp: 'jmv 3/2/2010 09:36'!
findClass
	"Search for a class by name."
	| pattern foundClass classNames index toMatch exactMatch potentialClassNames |

	self okToChange ifFalse: [^ self classNotFound].
	pattern _ FillInTheBlank request: 'Class name or fragment?'.
	pattern isEmpty ifTrue: [^ self classNotFound].
	toMatch _ (pattern copyWithout: $.) asLowercase.
	potentialClassNames _ self potentialClassNames asOrderedCollection.
	classNames _ pattern last = $. 
		ifTrue: [potentialClassNames select:
					[:nm |  nm asLowercase = toMatch]]
		ifFalse: [potentialClassNames select: 
					[:n | n includesSubstring: toMatch caseSensitive: false]].
	classNames isEmpty ifTrue: [^ self classNotFound].
	exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: nil.

	index _ classNames size = 1
		ifTrue:	[1]
		ifFalse:	[exactMatch
			ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUp]
			ifNotNil: [classNames addFirst: exactMatch.
				(PopUpMenu labelArray: classNames lines: #(1)) startUp]].
	index = 0 ifTrue: [^ self classNotFound].
	foundClass _ Smalltalk at: (classNames at: index) asSymbol.
 	self selectCategoryForClass: foundClass.
	self selectClass: foundClass
! !


!ChangeList methodsFor: 'scanning' stamp: 'jmv 3/2/2010 09:36'!
scanCategory
	"Scan anything that involves more than one chunk; method name is historical only"

	| itemPosition item tokens stamp isComment anIndex def isMeta name record |
	itemPosition _ file position.
	item _ file nextChunk.

	isComment _ (item includesSubString: 'commentStamp:').
	(isComment or: [item includesSubString: 'methodsFor:'] or: [item includesSubString: 'classDefinition:']) ifFalse: [
		"Maybe a preamble, but not one we recognize; bail out with the preamble trick"
		^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
				 text: ('preamble: ' , item contractTo: 160)].

	tokens _ Smalltalk actualScannerClass new scanTokens: item.
	tokens size >= 3 ifTrue: [
		stamp _ ''.
		anIndex _ tokens indexOf: #stamp: ifAbsent: nil.
		anIndex ifNotNil: [stamp _ tokens at: (anIndex + 1)].

		tokens first == #classDefinition:
			ifTrue: [
				itemPosition _ file position.
				isMeta _ tokens second includesSubString: ' class'.
				name _ isMeta ifTrue: [tokens second substrings first] ifFalse: [tokens second].
				def _ file nextChunk.
				record _ ChangeRecord new file: file position: itemPosition type: #classDefinition
					class: name asSymbol category: tokens last meta: isMeta stamp: nil.
				self addItem: record text: 'classDefinition: ', def.
				^file skipStyleChunk].
		
		tokens second == #methodsFor:
			ifTrue: [^ self scanCategory: tokens third class: tokens first
							meta: false stamp: stamp].

		tokens third == #methodsFor:
			ifTrue: [^ self scanCategory: tokens fourth class: tokens first
							meta: true stamp: stamp]].

	tokens second == #commentStamp:
		ifTrue:
			[stamp _ tokens third.
			self addItem:
					(ChangeRecord new file: file position: file position type: #classComment
									class: tokens first category: nil meta: false stamp: stamp)
					text: 'class comment for ' , tokens first, 
						  (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
			file nextChunk.
			^ file skipStyleChunk]! !

!ChangeList methodsFor: 'menu actions' stamp: 'jmv 3/2/2010 09:38'!
selectEquivalentMethods
	"Selects all method definitions for which there is already an equivalent method in the current image, 
	(meaning that the difference is cosmetic and not in behavior)"
	Cursor wait showWhile: [
		1 to: changeList size do: [ :i | 
			| change class |
			change _ changeList at: i.
			listSelections at: i put:
				((change type = #method and: [
					(class _ change methodClass) notNil]) and: [
						(class includesSelector: change methodSelector) and: [
							| cmWithNode |
							cmWithNode _ [class basicCompile: change string notifying: nil trailer: class defaultMethodTrailer ifFail: nil] 
								on: SyntaxErrorNotification do: [ :ex | ex return ].
							(cmWithNode notNil and: [
								| current inChange |
								current _ (class compiledMethodAt: change methodSelector) copyWithTrailerBytes: #(0).
								inChange _cmWithNode method copyWithTrailerBytes: #(0).
								current = inChange or: [
									| currentCmWithNode |
									currentCmWithNode _ [class basicCompile: (class decompilerClass new decompile: change methodSelector in: class) decompileString
											notifying: nil trailer: class defaultMethodTrailer ifFail: nil] on: SyntaxErrorNotification do: [ :ex | ex return ].
									(currentCmWithNode notNil and: [
										current _ currentCmWithNode method copyWithTrailerBytes: #(0).
										current = inChange])
								]
							])
						]]
				)]].
	self changed: #allSelections! !


!ChangeSorter methodsFor: 'class list' stamp: 'jmv 3/2/2010 09:44'!
selectedClassOrMetaClass
	"Careful, the class may have been removed!!"

	| cName |
	currentClassName ifNil: [^ nil].
	(currentClassName endsWith: ' class')
		ifTrue: [
			cName _ (currentClassName copyFrom: 1 to: currentClassName size-6) asSymbol.
			^ (Smalltalk at: cName ifAbsent: [^nil]) class]
		ifFalse: [
			cName _ currentClassName asSymbol.
			^ Smalltalk at: cName ifAbsent: nil]! !


!ChangeSorter class methodsFor: 'enumerating' stamp: 'jmv 3/2/2010 09:44'!
changeSetNamed: aName
	"Return the change set of the given name, or nil if none found.  1/22/96 sw"

	^ AllChangeSets
		detect: [:aChangeSet | aChangeSet name = aName]
		ifNone: nil! !

!ChangeSorter class methodsFor: 'removing' stamp: 'jmv 3/2/2010 09:44'!
removeChangeSet: aChangeSet
	"Remove the given changeSet.  Caller must assure that it's cool to do this"

	AllChangeSets remove: aChangeSet ifAbsent: nil.
	aChangeSet wither
! !


!Debugger methodsFor: 'context stack menu' stamp: 'jmv 3/2/2010 09:52'!
contextStackKey: aChar from: view
	"Respond to a keystroke in the context list"

 	| selector |
	selector _ ContextStackKeystrokes at: aChar ifAbsent: nil.
	selector
		ifNil: [self messageListKey: aChar from: view]
		ifNotNil: [self perform: selector]! !

!Debugger methodsFor: 'tally support' stamp: 'jmv 3/2/2010 09:52'!
getTextMorphWithSelection
	"This is extremely ugly... We I need to get a reference of the code pane, which is not easily accessible"
	^self dependents
		detect: [:m| (m isKindOf: PluggableTextMorph)
			and: [m selectionInterval first > 1]]
		ifNone: nil! !


!FileContentsBrowser methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:54'!
selectedPackage
	| cat |
	cat := self selectedSystemCategoryName.
	cat isNil ifTrue: [^nil].
	^self packages at: cat asString ifAbsent: nil! !

!FileContentsBrowser methodsFor: 'diffs' stamp: 'jmv 3/2/2010 09:54'!
modifiedClassDefinition
	| pClass rClass old new |
	pClass := self selectedClassOrMetaClass.
	pClass hasDefinition ifFalse: [ ^pClass definition].
	rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent: nil.
	rClass isNil ifTrue:[^pClass definition].
	self metaClassIndicated ifTrue:[ rClass := rClass class].
	old := rClass definition.
	new := pClass definition.
	^Cursor wait showWhile:[
		DifferenceFinder displayPatchFrom: old to: new tryWords: true ]! !

!FileContentsBrowser methodsFor: 'infoView' stamp: 'jmv 3/2/2010 09:54'!
infoViewContents
	| theClass |
	editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage].
	self selectedClass isNil ifTrue: [^ ''].
	theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: nil.
	editSelection == #editClass ifTrue: [^ theClass notNil
			ifTrue: ['Class exists already in the system']
			ifFalse: ['New class']].
	editSelection == #editMessage ifFalse: [^ ''].
	(theClass notNil and: [self metaClassIndicated])
		ifTrue: [theClass _ theClass class].
	^ (theClass notNil and: [theClass includesSelector: self selectedMessageName])
		ifTrue: ['Method already exists' , self extraInfo]
		ifFalse: ['New method']! !


!FileList methodsFor: 'own services' stamp: 'jmv 3/2/2010 09:55'!
servicesFromSelectorSpecs: symbolArray
	"Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service.  Pass the symbol #- along unchanged to serve as a separator between services"

	"FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)"

	| res services col | 
	col := OrderedCollection new.
	services := self class allRegisteredServices, (self myServicesForFile: #dummy suffix: '*').
	symbolArray do: 
		[:sel | 
			sel == #-
				ifTrue:
					[col add: sel]
				ifFalse:
					[res := services
							detect: [:each | each selector = sel] ifNone: nil.
					res notNil
							ifTrue: [col add: res]]].
	^ col! !

!FileList methodsFor: 'private' stamp: 'jmv 3/2/2010 09:55'!
addPath: aString
	"Add the given string to the list of recently visited directories."

	| full |
	aString ifNil: [^self].
	full := String streamContents: 
		[ :strm | 2 to: volList size do: 
			[ :i | strm nextPutAll: (volList at: i) withBlanksTrimmed.
			strm nextPut: FileDirectory pathNameDelimiter]].
	full := full, aString.
"Remove and super-directories of aString from the collection."
	RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)].

"If a sub-directory is in the list, do nothing."
	(RecentDirs detect: [ :aDir | ((full, '*') match: aDir)] ifNone: nil)
		ifNotNil: [^self].

	[RecentDirs size >= 10]
		whileTrue: [RecentDirs removeFirst].
	RecentDirs addLast: full! !


!FileList class methodsFor: 'file reader registration' stamp: 'jmv 3/2/2010 09:55'!
unregisterFileReader: aProviderClass
	"unregister the given class as providing services for reading files"

	self registeredFileReaderClasses remove: aProviderClass ifAbsent: nil! !


!Inspector methodsFor: 'selecting' stamp: 'jmv 3/2/2010 09:56'!
selectedSlotName

	^ self fieldList at: self selectionIndex ifAbsent: nil! !


!DictionaryInspector methodsFor: 'selecting' stamp: 'jmv 3/2/2010 09:53'!
selection

	selectionIndex <= (self numberOfFixedFields) ifTrue: [^ super selection].
	^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) ifAbsent: nil! !


!MessageSet methodsFor: 'message list' stamp: 'jmv 3/2/2010 09:58'!
sortByDate
	"Sort the message-list by date of time-stamp"

	| assocs aCompiledMethod aDate inOrder |
	assocs _ messageList collect:
		[:aRef |
			aDate _ aRef methodSymbol == #Comment
				ifTrue:
					[aRef actualClass organization dateCommentLastSubmitted]
				ifFalse:
					[aCompiledMethod _ aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: nil.
					aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]].
			aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])].  "The dawn of Squeak history"
	inOrder _ assocs asSortedCollection:
		[:a :b | a value < b value].

	messageList _ inOrder asArray collect: [:assoc | assoc key].
	self changed: #messageList! !

!MessageSet methodsFor: 'contents' stamp: 'jmv 3/2/2010 09:57'!
selectedMessage
	"Answer the source method for the currently selected message."

	| source |
	self setClassAndSelectorIn: [:class :selector | 
		class ifNil: [^ 'Class vanished'].
		selector first isUppercase ifTrue:
			[selector == #Comment ifTrue:
				[currentCompiledMethod _ class organization commentRemoteStr.
				^ class comment].
			selector == #Definition ifTrue:
				[^ class definition].
			selector == #Hierarchy ifTrue: [^ class printHierarchy]].
		source _ class sourceMethodAt: selector ifAbsent:
			[currentCompiledMethod _ nil.
			^ 'Missing'].

		self showingDecompile ifTrue:
			[^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

		currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: nil.
		self showingDocumentation ifTrue:
			[^ self commentContents].

	source _ self sourceStringPrettifiedAndDiffed.
	^ source asText makeSelectorBoldIn: class]! !

!MessageSet methodsFor: 'private' stamp: 'jmv 3/2/2010 09:58'!
selection
	"Answer the item in the list that is currently selected, or nil if no selection is present"

	^ messageList at: messageListIndex ifAbsent: nil! !

!MessageSet methodsFor: 'filtering' stamp: 'jmv 3/2/2010 09:57'!
filterToCurrentAuthor
	"Filter down only to messages with my initials as most recent author"

	| myInitials aMethod aTimeStamp |
	(myInitials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:			
				[aMethod _ aClass compiledMethodAt: aSelector ifAbsent: nil.
				aMethod notNil and:
					[(aTimeStamp _ Utilities timeStampForMethod: aMethod) notNil and:
						[aTimeStamp beginsWith: myInitials]]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'jmv 3/2/2010 09:57'!
filterToMessagesInChangesFile
	"Filter down only to messages whose source code risides in the Changes file.  This allows one to ignore long-standing methods that live in the .sources file."

	| cm |
	self filterFrom:
		[:aClass :aSelector |
			aClass notNil and: [aSelector notNil and:
				[(self class isPseudoSelector: aSelector) not and:
					[(cm _ aClass compiledMethodAt: aSelector ifAbsent: nil) notNil and:
					[cm fileIndex ~= 1]]]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'jmv 3/2/2010 09:57'!
filterToMessagesInSourcesFile
	"Filter down only to messages whose source code resides in the .sources file."

	| cm |
	self filterFrom: [:aClass :aSelector |
		(aClass notNil and: [aSelector notNil]) and:
			[(self class isPseudoSelector: aSelector) not and:
				[(cm _ aClass compiledMethodAt: aSelector ifAbsent: nil) notNil and:
					[cm fileIndex = 1]]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'jmv 3/2/2010 09:57'!
filterToNotCurrentAuthor
	"Filter down only to messages not stamped with my initials"

	| myInitials aMethod aTimeStamp |
	(myInitials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:			
				[aMethod _ aClass compiledMethodAt: aSelector ifAbsent: nil.
				aMethod notNil and:
					[(aTimeStamp _ Utilities timeStampForMethod: aMethod) isNil or:
						[(aTimeStamp beginsWith: myInitials) not]]]]! !


!MessageNames methodsFor: 'selection' stamp: 'jmv 3/2/2010 09:57'!
selection
	"Answer the item in the list that is currently selected, or nil if no selection is present"

	^ self messageList at: messageListIndex ifAbsent: nil! !

!MessageNames methodsFor: 'message list menu' stamp: 'jmv 3/2/2010 09:57'!
copyName
	"Copy the current selector to the clipboard"

	| selector |
	(selector _ self selectorList at: selectorListIndex ifAbsent: nil) ifNotNil: [
		Clipboard clipboardText: selector asString asText ]! !


!MethodHolder methodsFor: 'contents' stamp: 'jmv 3/2/2010 09:58'!
stringContents
	"Answer the contents, with due respect for my contentsSymbol"

	contents _ methodClass sourceCodeAt: methodSelector ifAbsent: [''].
	currentCompiledMethod _ methodClass compiledMethodAt: methodSelector ifAbsent: nil.

	self showingDecompile ifTrue: [
		^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

	self showingDocumentation ifTrue: [
		^ self commentContents].

	^ contents _ self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: methodClass! !


!Monitor methodsFor: 'private' stamp: 'jmv 3/2/2010 09:59'!
signalLock: aSemaphore inQueue: anOrderedCollection
	queuesMutex critical: [
		aSemaphore signal.
		anOrderedCollection remove: aSemaphore ifAbsent: nil
	]! !


!Morph methodsFor: 'copying' stamp: 'jmv 3/2/2010 09:59'!
veryDeepFixupWith: deepCopier
	"If some fields were weakly copied, fix new copy here."

	"super veryDeepFixupWith: deepCopier.	Object has no fixups, so don't call it"

	"If my owner is being duplicated too, then store his duplicate.
	 If I am owned outside the duplicated tree, then I am no longer owned!!"
	owner _ deepCopier references at: owner ifAbsent: nil

! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 3/2/2010 09:59'!
findA: aClass
	"Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."

	^self submorphs
		detect: [:p | p isKindOf: aClass]
		ifNone: nil! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 3/2/2010 09:59'!
findSubmorphBinary: aBlock
	"Use binary search for finding a specific submorph of the receiver. Caller must be certain that the ordering holds for the submorphs."
	^submorphs findBinary: aBlock ifNone: nil! !


!HandMorph methodsFor: 'halo handling' stamp: 'jmv 3/2/2010 09:56'!
obtainHalo: aHalo
	"Used for transfering halos between hands"
	| formerOwner |
	self halo == aHalo ifTrue:[^self].
	"Find former owner"
	formerOwner _ self world hands detect: [ :h | h halo == aHalo] ifNone: nil.
	formerOwner ifNotNil:[formerOwner releaseHalo: aHalo].
	self halo: aHalo! !


!MenuMorph methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:56'!
commandKeyHandler
	"Answer the receiver's commandKeyHandler"

	^ self valueOfProperty: #commandKeyHandler ifAbsent: nil! !

!MenuMorph methodsFor: 'modal control' stamp: 'jmv 3/2/2010 09:57'!
modalSelection
	^self valueOfProperty: #modalSelection ifAbsent: nil! !


!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'jmv 3/2/2010 09:59'!
layoutFrame
	^self valueOfProperty: #layoutFrame ifAbsent: nil! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'jmv 3/2/2010 09:59'!
hasProperty: aSymbol 
	"Answer whether the receiver has the property named aSymbol"
	| property |
	self hasOtherProperties
		ifFalse: [^ false].
	property _ self otherProperties
				at: aSymbol
				ifAbsent: nil.
	property isNil
		ifTrue: [^ false].
	property == false
		ifTrue: [^ false].
	^ true! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'jmv 3/2/2010 09:59'!
removeProperty: aSymbol 
	"removes the property named aSymbol if it exists"
	self hasOtherProperties
		ifFalse: [^ self].
	self otherProperties
		removeKey: aSymbol
		ifAbsent: nil.
	self otherProperties isEmpty
		ifTrue: [self removeOtherProperties]! !

!MorphExtension methodsFor: 'other properties' stamp: 'jmv 3/2/2010 09:59'!
valueOfProperty: propName 
	^ self valueOfProperty: propName ifAbsent: nil! !


!NewParagraph methodsFor: 'editing' stamp: 'jmv 3/2/2010 10:16'!
clickAt: clickPoint for: model
	"Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."
	| startBlock action target range boxes box |
	action _ false.
	startBlock _ self characterBlockAtPoint: clickPoint.
	(text attributesAt: startBlock stringIndex) do: [ :att | 
		att mayActOnClick ifTrue:
				[(target _ model) ifNil: [ target _ editor morph].
				range _ text rangeOf: att startingAt: startBlock stringIndex.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last+1).
				box _ boxes detect: [:each | each containsPoint: clickPoint] ifNone: nil.
				box ifNotNil: [
					box _ (editor transformFrom: nil) invertBoundsRect: box.
					editor morph allOwnersDo: [ :m | box _ box intersect: (m boundsInWorld) ].
					Utilities
						awaitMouseUpIn: box
						repeating: nil
						ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action _ true]].
					Cursor currentCursor == Cursor webLink ifTrue:[Cursor normal show].
				]]].
	^ action! !


!Parser methodsFor: 'primitives' stamp: 'jmv 3/2/2010 10:01'!
externalFunctionDeclaration
	"Parse the function declaration for a call to an external library."
	| descriptorClass callType retType externalName args argType module fn |
	descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: nil.
	descriptorClass
		ifNil: [^ false].
	callType := descriptorClass callingConventionFor: here.
	callType == nil ifTrue:[^false].
	"Parse return type"
	self advance.
	retType := self externalType: descriptorClass.
	retType == nil ifTrue:[^self expected:'return type'].
	"Parse function name or index"
	externalName := here.
	(self match: #string) 
		ifTrue:[externalName := externalName asSymbol]
		ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']].
	(self matchToken: #'(') ifFalse:[^self expected:'argument list'].
	args := WriteStream on: Array new.
	[here == #')'] whileFalse:[
		argType := self externalType: descriptorClass.
		argType == nil ifTrue:[^self expected:'argument'].
		argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType].
	].
	(self matchToken:#')') ifFalse:[^self expected:')'].
	(self matchToken: 'module:') ifTrue:[
		module := here.
		(self match: #string) ifFalse:[^self expected: 'String'].
		module := module asSymbol].
	Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn|
		fn := xfn name: externalName 
				module: module 
				callType: callType
				returnType: retType
				argumentTypes: args contents.
		self allocateLiteral: fn.
	].
	self addPragma: (Pragma keyword: #primitive: arguments: #(120)).
	^true! !


!PluggableListMorph methodsFor: 'updating' stamp: 'jmv 3/2/2010 10:02'!
verifyContents
	"Verify the contents of the receiver, reconstituting if necessary.  Called whenever window is reactivated, to react to possible structural changes.  Also called periodically in morphic if the smartUpdating preference is true"
	| newList existingSelection anIndex oldList |
	oldList _ list ifNil: [ #() ].
	newList _ self getList.
	((oldList == newList) "fastest" or: [oldList = newList]) ifTrue: [^ self].
	self flash.  "list has changed beneath us; give the user a little visual feedback that the contents of the pane are being updated."
	existingSelection _ self selectionIndex > 0 ifTrue: [ oldList at: self selectionIndex ].
	self updateList.
	(existingSelection notNil and: [(anIndex _ list indexOf: existingSelection asStringOrText ifAbsent: nil) notNil])
		ifTrue: [
			model noteSelectionIndex: anIndex for: getListSelector.
			self selectionIndex: anIndex]
		ifFalse: [
			self changeModelSelection: 0]! !


!PluggableMessageCategoryListMorph methodsFor: 'updating' stamp: 'jmv 3/2/2010 10:02'!
verifyContents
	
	| newList existingSelection anIndex newRawList |
	(model editSelection == #editComment) ifTrue: [^ self].
	model classListIndex = 0 ifTrue: [^ self].
	newRawList _ model perform: getRawListSelector.
	newRawList == priorRawList ifTrue: [^ self].  "The usual case; very fast"
	priorRawList _ newRawList.
	newList _ (Array with: ClassOrganizer allCategory), priorRawList.
	list = newList ifTrue: [^ self].
	self flash.  "could get annoying, but hell"
	existingSelection _ self selection.
	self updateList.
	(anIndex _ newList indexOf: existingSelection ifAbsent: nil)
		ifNotNil: [
			model noteSelectionIndex: anIndex for: getListSelector.
			self selectionIndex: anIndex]
		ifNil: [
			self changeModelSelection: 0]! !


!PluggableTextMorph methodsFor: 'menu commands' stamp: 'jmv 3/2/2010 10:16'!
accept
	"Inform the model of text to be accepted, and return true if OK."

	"sps 8/13/2001 22:41: save selection and scroll info"

	| textToAccept ok saveSelection saveScrollerOffset |
	saveSelection := self selectionInterval copy.
	saveScrollerOffset := scroller offset copy.
	(self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) 
		ifTrue: [^self flash].
	self hasEditingConflicts 
		ifTrue: 
			[(self 
				confirm: 'Caution!! This method may have been
changed elsewhere since you started
editing it here.  Accept anyway?' 
						translated) 
					ifFalse: [^self flash]].
	textToAccept := textMorph asText.
	ok := setTextSelector isNil or: 
					[setTextSelector numArgs = 2 
						ifTrue: 
							[model 
								perform: setTextSelector
								with: textToAccept
								with: self]
						ifFalse: [model perform: setTextSelector with: textToAccept]].
	ok == true 
		ifTrue: 
			[self setText: self getText.
			self hasUnacceptedEdits: false.
			(model dependents detect: 
					[:dep | 
					(dep isKindOf: PluggableTextMorph) 
						and: [dep getTextSelector == #annotation]]
				ifNone: nil) ifNotNil: [ :aPane | model changed: #annotation]].

	"sps 8/13/2001 22:41: restore selection and scroll info"
	
	["During the step for the browser, updateCodePaneIfNeeded is called, and 
		invariably resets the contents of the codeholding PluggableTextMorph
		at that time, resetting the cursor position and scroller in the process.
		The following line forces that update without waiting for the step, 		then restores the cursor and scrollbar"

	ok 
		ifTrue: 
			["(don't bother if there was an error during compile)"

			(model isKindOf: CodeHolder) ifTrue: [model updateCodePaneIfNeeded].
			"jmv - moved this outside the deferred message.
			See 'Re: [squeak-dev] scrambled input fields'
			from Gary Chambers on Nov 14, 2008."
			self selectFrom: saveSelection first to: saveSelection last.
			WorldState addDeferredUIMessage: 
					[self currentHand newKeyboardFocus: textMorph.
					scroller offset: saveScrollerOffset.
					self setScrollDeltas.
					"self selectFrom: saveSelection first to: saveSelection last"]]] 
			on: Error
			do: nil! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'jmv 3/2/2010 10:03'!
cancel
	self setText: self getText.
	self setSelection: self getSelection.
	getTextSelector == #annotation ifFalse: [
		(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [
				dep getTextSelector == #annotation]] ifNone: nil)
					ifNotNil: [:aPane | 
						model changed: #annotation]]! !


!PointerFinder methodsFor: 'application' stamp: 'jmv 3/2/2010 10:17'!
buildList
	| list obj parent object key |
	list := OrderedCollection new.
	obj := goal.
	
	[
		list addFirst: obj.
		obj := parents at: obj ifAbsent: nil.
		obj == nil ] whileFalse.
	list removeFirst.
	parent := Smalltalk.
	objectList := OrderedCollection new.
	pointerList := OrderedCollection new.
	[list isEmpty]
		whileFalse: [ 
			object := list removeFirst.
			key := nil.
			(parent isKindOf: Dictionary)
				ifTrue: [list size >= 2
						ifTrue: [
							key := parent keyAtValue: list second ifAbsent: nil.
							key == nil
								ifFalse: 
									[object := list removeFirst; removeFirst.
									pointerList add: key printString , ' -> ' , object class name]]].
			key == nil
				ifTrue: 
					[parent class == object ifTrue: [key := 'CLASS'].
					key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i)
									== object ifTrue: [key := parent class allInstVarNames at: i]]]].
					key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i)
									== object ifTrue: [key := i printString]]]].
					key == nil ifTrue: [((parent is: #Morph) and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']].
					key == nil ifTrue: [((parent is: #CompiledMethod) and: [object isVariableBinding]) ifTrue: [key := 'literals?']].
					key == nil ifTrue: [key := '???'].
					pointerList add: key , ': ' , object class name].
			objectList add: object.
			parent := object]! !


!Preferences class methodsFor: 'halos' stamp: 'jmv 3/2/2010 10:03'!
resetHaloSpecifications
	"Preferences resetHaloSpecifications"

	^ Parameters removeKey: #HaloSpecs ifAbsent: nil! !

!Preferences class methodsFor: 'initialization' stamp: 'jmv 3/2/2010 10:03'!
removePreference: aSymbol
	"Remove all memory of the given preference symbol in my various structures."

	| pref |
	pref _ self preferenceAt: aSymbol ifAbsent: [^ self].

	DictionaryOfPreferences removeKey: aSymbol ifAbsent: nil.
	self class removeSelector: aSymbol

"Preferences removePreference: #tileToggleInBrowsers"! !

!Preferences class methodsFor: 'preference-object access' stamp: 'jmv 3/2/2010 10:03'!
preferenceAt: aSymbol
	"Answer the Preference object at the given symbol, or nil if not there"

	^ DictionaryOfPreferences at: aSymbol ifAbsent: nil! !


!Process methodsFor: 'changing process state' stamp: 'jmv 3/2/2010 10:04'!
suspend
	"Primitive. Stop the process that the receiver represents in such a way 
	that it can be restarted at a later time (by sending the receiver the 
	message resume). If the receiver represents the activeProcess, suspend it. 
	Otherwise remove the receiver from the list of waiting processes.
	The return value of this method is the list the receiver was previously on (if any)."
	| oldList |
	<primitive: 88>
	"This is fallback code for VMs which only support the old primitiveSuspend which 
	would not accept processes that are waiting to be run."
	myList ifNil:[^nil]. "this allows us to use suspend multiple times"
	oldList := myList.
	myList := nil.
	oldList remove: self ifAbsent: nil.
	^oldList! !


!ProcessBrowser methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:04'!
processListIndex: index 
	processListIndex _ index.
	selectedProcess _ processList
				at: index
				ifAbsent: nil.
	self updateStackList.
	self changed: #processListIndex! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:04'!
stackListIndex: index 
	stackListIndex := index.
	selectedContext := (stackList notNil
						and: [index > 0]) ifTrue: [
							stackList at: index ifAbsent: nil ].
	selectedClass := nil.
	selectedSelector := nil.
	methodText := nil.
	self changed: #stackListIndex.
	self changed: #selectedMethod! !

!ProcessBrowser methodsFor: 'process list' stamp: 'jmv 3/2/2010 10:04'!
processListMenu: menu 
	| pw |

	selectedProcess
		ifNotNil: [| nameAndRules | 
			nameAndRules _ self nameAndRulesForSelectedProcess.
			menu addList: {{'inspect (i)'. #inspectProcess}. {'explore (I)'. #exploreProcess}. {'inspect Pointers (P)'. #inspectPointers}}.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [ menu add: 'chase pointers (c)' action: #chasePointers.  ].
			nameAndRules second
				ifTrue: [menu add: 'terminate (t)' action: #terminateProcess.
					selectedProcess isSuspended
						ifTrue: [menu add: 'resume (r)' action: #resumeProcess]
						ifFalse: [menu add: 'suspend (s)' action: #suspendProcess]].
			nameAndRules third
				ifTrue: [menu addList: {{'change priority (p)'. #changePriority}. {'debug (d)'. #debugProcess}}].
			menu addList: {{'profile messages (m)'. #messageTally}}.
			(selectedProcess suspendingList isKindOf: Semaphore)
				ifTrue: [menu add: 'signal Semaphore (S)' action: #signalSemaphore].
			menu add: 'full stack (k)' action: #moreStack.
			menu addLine].

	menu addList: {{'find context... (f)'. #findContext}. {'find again (g)'. #nextContext}}.
	menu addLine.

	menu
		add: (self isAutoUpdating
				ifTrue: ['turn off auto-update (a)']
				ifFalse: ['turn on auto-update (a)'])
		action: #toggleAutoUpdate.
	menu add: 'update list (u)' action: #updateProcessList.

	pw _ Smalltalk at: #CPUWatcher ifAbsent: nil.
	pw ifNotNil: [
		menu addLine.
		pw isMonitoring
				ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher ]
				ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher  ]
	].

	^ menu! !

!ProcessBrowser methodsFor: 'process list' stamp: 'jmv 3/2/2010 08:58'!
processNameList
	"since processList is a WeakArray, we have to strengthen the result"
	| pw tally |
	pw _ Smalltalk at: #CPUWatcher ifAbsent: nil.
	tally _ pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ].
	^ (processList asOrderedCollection
		copyWithout: nil)
		collect: [:each | | percent |
			percent _ tally
				ifNotNil: [ ((((tally occurrencesOf: each) * 100.0 / tally size) roundTo: 1)
						asString padded: #left to: 2 with: $ ), '% '  ]
				ifNil: [ '' ].
			percent, (self prettyNameForProcess: each)
		] ! !


!ProcessBrowser class methodsFor: 'process control' stamp: 'jmv 3/2/2010 08:58'!
setProcess: aProcess toPriority: priority
	| oldPriority |
	oldPriority _ self suspendedProcesses at: aProcess ifAbsent: nil.
	oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ].
	aProcess priority: priority.
	^oldPriority! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'jmv 3/2/2010 10:04'!
terminateProcess: aProcess
	aProcess ifNotNil: [
		self suspendedProcesses
			removeKey: aProcess
			ifAbsent: nil.
		aProcess terminate
	]! !


!PseudoClass methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:04'!
realClass
	^Smalltalk at: self name asSymbol ifAbsent: nil! !

!PseudoClass methodsFor: 'private' stamp: 'jmv 3/2/2010 10:04'!
makeSureClassExists: aString
	| theClass |
	theClass := Smalltalk at: (aString asSymbol) ifAbsent: nil.
	theClass ifNotNil:[^true].
	^self confirm: aString,' does not exist in the system. Use nil instead?'.! !

!PseudoClass methodsFor: 'private' stamp: 'jmv 3/2/2010 10:04'!
makeSureSuperClassExists: aString
	| theClass |
	theClass := Smalltalk at: (aString asSymbol) ifAbsent: nil.
	theClass ifNotNil:[^true].
	^self confirm: 'The super class ',aString,' does not exist in the system. Use nil instead?'.! !


!ReadWriteStream methodsFor: 'converting' stamp: 'jmv 3/2/2010 10:05'!
asUnZippedStream
	| isGZip outputStream first strm archive which |
	"Decompress this file if needed, and return a stream.  No file is written.  File extension may be .gz or anything else.  Also works on archives (.zip, .gZip)."

	strm _ self binary.
	strm isZipArchive ifTrue: [
		archive _ ZipArchive new readFrom: strm.
		which _ archive members 
			detect: [:any | any fileName asLowercase endsWith: '.ttf'] 
			ifNone: nil.
		which ifNil: [
			archive close.
			^ self error: 'Can''t find .ttf file in archive'].
		strm _ which contentStream.
		archive close].

	first _ strm next.
	isGZip _ (strm next * 256 + first) = (GZipConstants gzipMagic).
	strm skip: -2.
	isGZip 
		ifTrue: [outputStream _ (RWBinaryOrTextStream with:
									(GZipReadStream on: strm) upToEnd) reset.
				strm close]
		ifFalse: [outputStream _ strm].
	^ outputStream! !


!ReferenceStream methodsFor: 'reading' stamp: 'jmv 3/2/2010 10:05'!
next
	"Answer the next object in the stream.  If this object was already read, don't re-read it.  File is positioned just before the object."
	| curPosn skipToPosn haveIt theObject wasSkipping |

	haveIt _ true.
	curPosn _ byteStream position - basePos.
	theObject _ objects at: curPosn ifAbsent: [haveIt _ false].
		"probe in objects is done twice when coming from objectAt:.  This is OK."
	skipToPosn _ fwdRefEnds at: curPosn ifAbsent: nil.
	haveIt ifFalse: [ ^ super next].

	skipToPosn ifNotNil: [
		"Skip over the object and return the already-read-in value."
		byteStream position: skipToPosn + basePos		"make absolute"
	] ifNil: [
		"File is not positioned correctly.  Read object and throw it away."
		wasSkipping _ skipping includes: curPosn.
		skipping add: curPosn.
		"fake _" super next.
		wasSkipping ifFalse: [skipping remove: curPosn ifAbsent: nil].
	].
	^ theObject
		! !

!ReferenceStream methodsFor: 'statistics' stamp: 'jmv 3/2/2010 10:05'!
statisticsOfRefs
	"Analyze the information in references, the objects being written out"

	| parents n kids nm ownerBags tallies owners objParent |
	parents _ IdentityDictionary new: references size * 2.
	n _ 0.
	'Finding Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:
		[:parent | bar value: (n _ n+1).
		kids _ parent class isFixed
			ifTrue: [(1 to: parent class instSize) collect: [:i | parent
instVarAt: i]]
			ifFalse: [parent class isBits ifTrue: [Array new]
					 ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt:
i]]].
		(kids select: [:x | references includesKey: x])
			do: [:child | parents at: child put: parent]]].
	ownerBags _ Dictionary new.
	tallies _ Bag new.
	n _ 0.
	'Tallying Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:  "For each class of obj, tally a bag of owner
classes"
		[:obj | bar value: (n _ n+1).
		nm _ obj class name.
		tallies add: nm.
		owners _ ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new].
		(objParent _ parents at: obj ifAbsent: nil) ifNotNil: [
			owners add: objParent class name]]].
	^ String streamContents: [ :strm | 
		tallies sortedCounts do: [ :assn |
			n _ assn key.  nm _ assn value.
			owners _ ownerBags at: nm.
			strm cr; nextPutAll: nm; space; print: n.
			owners size > 0 ifTrue: [
				strm cr; tab; print: owners sortedCounts]]]! !


!RemoteString methodsFor: 'private' stamp: 'jmv 3/2/2010 10:05'!
makeNewTextAttVersion
	"Create a new TextAttributes version because some inst var has changed.  If no change, don't make a new one."
	"Don't delete this method even though it has no callers!!!!!!!!!!"

| obj cls struct tag |
"Note that TextFontReference and TextAnchor are forbidden."
obj _ #(RunArray TextDoIt TextURL TextColor TextEmphasis TextKern TextLinkToImplementors 3 'a string') collect: [:each | 
		cls _ Smalltalk at: each ifAbsent: nil.
		cls ifNil: [each] ifNotNil: [cls new]].
struct _ (SmartRefStream on: (RWBinaryOrTextStream on: String new)) instVarInfo: obj.
tag _ self checkSum: struct printString.
TextAttributeStructureVersions ifNil: [TextAttributeStructureVersions _ Dictionary new].
(struct = CurrentTextAttStructure) & (tag = CurrentTextAttVersion) 
	ifTrue: [^ false].
CurrentTextAttStructure _ struct.
CurrentTextAttVersion _ tag.
TextAttributeStructureVersions at: tag put: struct.
^ true! !


!RemoteString class methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 10:05'!
structureAt: styleVersion

	^ TextAttributeStructureVersions at: styleVersion ifAbsent: nil! !


!SHParserST80 methodsFor: 'scan' stamp: 'jmv 3/2/2010 10:05'!
currentChar
	^source at: sourcePosition ifAbsent: nil! !

!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 3/2/2010 10:06'!
leaveBlock
	arguments removeKey: blockDepth ifAbsent: nil.
	temporaries removeKey: blockDepth ifAbsent: nil.
	blockDepth := blockDepth - 1.
	bracketDepth := bracketDepth - 1! !

!SHParserST80 methodsFor: 'token testing' stamp: 'jmv 3/2/2010 10:06'!
isTokenExternalFunctionCallingConvention
	| descriptorClass |
	descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: nil.
	descriptorClass ifNil: [^false].
	^(descriptorClass callingConventionFor: currentToken) notNil! !


!SHTextStylerST80 class methodsFor: 'style table' stamp: 'jmv 3/2/2010 10:06'!
attributesFor: aSymbol

	textAttributes ifNil: [ textAttributes _ self initialTextAttributes ].
	^ textAttributes at: aSymbol ifAbsent: nil! !

!SHTextStylerST80 class methodsFor: 'style table' stamp: 'jmv 3/2/2010 10:06'!
initialTextAttributes
	| d element color emphasis attrArray |
	 
	d := IdentityDictionary new.
	self styleTable do: [ :each |
		element := each first.
		color := each at: 2 ifAbsent: nil.
		color:=color ifNotNil: [ Color colorFrom: color].
		emphasis := each at: 3 ifAbsent: nil.
		attrArray := self attributeArrayForColor: color emphasis: emphasis.
		attrArray notEmpty 
			ifTrue: [
				d at: element put: attrArray]].
	^d	
	! !


!SUnitNameResolver class methodsFor: 'Camp Smalltalk' stamp: 'jmv 3/2/2010 10:06'!
classNamed: aSymbol

        ^Smalltalk
                at: aSymbol
                ifAbsent: nil! !


!SampledSound class methodsFor: 'sound library' stamp: 'jmv 3/2/2010 10:06'!
removeSoundNamed: aString
	"Remove the sound with the given name from the sound library."

	SoundLibrary removeKey: aString ifAbsent: nil! !


!ScorePlayer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:06'!
mutedForTrack: trackIndex put: aBoolean

	trackIndex > muted size ifTrue: [^ self].
	muted at: trackIndex put: aBoolean.
	aBoolean ifFalse: [^ self].

	"silence any currently sounding notes for this track"
	activeSounds do: [:pair |
		pair last = trackIndex ifTrue: [activeSounds remove: pair ifAbsent: nil]].
	midiPort ifNotNil: [
		activeMIDINotes do: [:pair |
			pair last = trackIndex ifTrue: [
				pair first endNoteOnMidiPort: midiPort.
				activeMIDINotes remove: pair ifAbsent: nil]]].
! !


!SequenceableCollection methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:07'!
after: target
	"Answer the element after target.  Raise an error if target is not
	in the receiver, but answer nil if there are no elements after it."

	^ self after: target ifNone: nil! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:07'!
before: target
	"Answer the receiver's element immediately before target. Raise an
	error if target is not an element of the receiver, 
	but answer nil if there are no elements before it (i.e. it is the first element)."

	^ self before: target ifNone: nil! !


!CompiledMethod methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:51'!
searchForClass
	"search me in all classes, if found, return my class. Slow!!"
	Smalltalk allBehaviorsDo: [:class | 
		(class methodDict keyAtIdentityValue: self ifAbsent: nil) ifNotNil: [^class]].
	^nil! !

!CompiledMethod methodsFor: 'accessing' stamp: 'jmv 3/2/2010 09:51'!
searchForSelector
	"search me in all classes, if found, return my selector. Slow!!"

	Smalltalk allBehaviorsDo: [:class | 
		(class methodDict keyAtIdentityValue: self ifAbsent: nil) ifNotNil: [ :selector | ^selector]].
	^nil! !

!CompiledMethod methodsFor: 'testing' stamp: 'jmv 3/2/2010 09:50'!
hasReportableSlip
	"Answer whether the receiver contains anything that should be brought 
	to the attention of the author when filing out. Customize the lists here 
	to suit your preferences. If slips do not get reported in spite of your 
	best efforts here, make certain that the Preference 'checkForSlips' is set 
	to true."

	#(#doOnlyOnce: #halt #halt: #hottest #printDirectlyToDisplay #toRemove #personal #urgent  #haltOnce #haltOnce: #haltIf: )
		do: [ :aLit | 
			(self hasLiteral: aLit)
				ifTrue: [^ true]].
	#(#Transcript #AA #BB #CC #DD #EE )
		do: [ :aSymbol | 	| assoc |
			(assoc := Smalltalk
				associationAt: aSymbol
				ifAbsent: nil)
					ifNotNil: [(self hasLiteral: assoc)
						ifTrue: [^ true]]].
	^ false! !

!CompiledMethod methodsFor: 'testing' stamp: 'jmv 3/2/2010 09:50'!
isInstalled
	self methodClass ifNotNil:
		[:class|
		self selector ifNotNil:
			[:selector|
			^self == (class methodDict at: selector ifAbsent: nil)]].
	^false! !

!CompiledMethod methodsFor: 'printing' stamp: 'jmv 3/2/2010 09:50'!
dateMethodLastSubmitted
	"Answer a Date object indicating when a method was last submitted.  If there is no date stamp, return nil"
	"(CompiledMethod compiledMethodAt: #dateMethodLastSubmitted) dateMethodLastSubmitted"

	| aStamp tokens |
	aStamp _ self timeStamp.
	tokens _ aStamp findBetweenSubStrs: ' 
'.  "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance"
	^ tokens size > 1
		ifTrue: [
			[tokens second asDate] ifError: nil]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 3/2/2010 09:51'!
sourceClass
	"Get my receiver class (method class) from the preamble of my source.  Return nil if not found."

	^ [(Compiler evaluate: (self sourceFileStream backChunk "blank"; backChunk "preamble")) theClass] on: Error do: nil! !

!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'jmv 3/2/2010 09:50'!
pragmaAt: aKey
	"Answer the pragma with selector aKey, or nil if none."
	| propertiesOrSelector |
	^(propertiesOrSelector := self penultimateLiteral) isMethodProperties
		ifTrue: [propertiesOrSelector at: aKey ifAbsent: nil]! !

!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'jmv 3/2/2010 09:50'!
propertyValueAt: propName
	| propertiesOrSelector |
	^(propertiesOrSelector := self penultimateLiteral) isMethodProperties
		ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: nil]! !


!Set methodsFor: 'removing' stamp: 'jmv 3/2/2010 10:08'!
copyWithout: oldElement 
	"Answer a copy of the receiver that does not contain any elements equal
	to oldElement."
	^ self copy
		remove: oldElement ifAbsent: nil;
		yourself! !


!Dictionary methodsFor: '*Compiler' stamp: 'jmv 3/2/2010 09:53'!
bindingOf: varName
	^self associationAt: varName ifAbsent: nil! !


!SmartRefStream methodsFor: 'read write' stamp: 'jmv 3/2/2010 10:08'!
mapClass: incoming
	"See if the old class named nm exists.  If so, return it.  If not, map it to a new class, and save the mapping in renamed.  "

	| cls oldVer sel nm |

	self flag: #bobconv.	


	nm _ renamed at: incoming ifAbsent: [incoming].	"allow pre-mapping around collisions"
	(nm endsWith: ' class') 
		ifFalse: [cls _ Smalltalk at: nm ifAbsent: nil.
			cls ifNotNil: [^ cls]]  	"Known class.  It will know how to translate the instance."
		ifTrue: [cls _ Smalltalk at: nm substrings first asSymbol ifAbsent: nil.
			cls ifNotNil: [^ cls class]]. 	"Known class.  It will know how to translate the instance."
	oldVer _ self versionSymbol: (structures at: nm).
	sel _ nm asString.
	sel at: 1 put: (sel at: 1) asLowercase.
	sel _ sel, oldVer.	"i.e. #rectangleoc4"
	Symbol hasInterned: sel ifTrue: [:symb | 
		(self class canUnderstand: sel asSymbol) ifTrue: [
			cls _ self perform: sel asSymbol]].	"This class will take responsibility"
	cls ifNil: [cls _ self writeClassRenameMethod: sel was: nm
					fromInstVars: (structures at: nm).
			   cls class == String ifTrue: [cls _ nil]].
	cls ifNotNil: [renamed at: nm put: cls name].
	^ cls
! !


!Socket methodsFor: 'receiving' stamp: 'jmv 3/2/2010 10:09'!
receiveDataTimeout: timeout into: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Wait for data once for the specified nr of seconds.  The answer may be 
	zero (indicating that there was no data available within the given timeout)."

	self waitForDataFor: timeout ifClosed: nil ifTimedOut: nil.
	^self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size-aNumber+1! !


!Socket class methodsFor: 'registry' stamp: 'jmv 3/2/2010 10:09'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry remove: anObject ifAbsent: nil! !


!SoundPlayer class methodsFor: 'playing' stamp: 'jmv 3/2/2010 10:09'!
pauseSound: aSound
	"Stop playing the given sound. Playing can be resumed from this point later."

	PlayerSemaphore critical: [
		ActiveSounds remove: aSound ifAbsent: nil].
! !


!StandardFileStream methodsFor: 'browser requests' stamp: 'jmv 3/2/2010 10:10'!
requestURL: url target: target
	^self requestURL: url target: target ifError: nil! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'jmv 3/2/2010 10:10'!
requestURLStream: url
	"FileStream requestURLStream:'http://www.squeak.org'"
	^self requestURLStream: url ifError: nil! !


!StandardFileStream class methodsFor: 'registry' stamp: 'jmv 3/2/2010 10:10'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse: [^anObject].
	self registry remove: anObject ifAbsent: nil! !


!String methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:10'!
findTokens: delimiters includes: subString
	"Divide self into pieces using delimiters.  Return the piece that includes subString anywhere in it.  Is case sensitive (say asLowercase to everything beforehand to make insensitive)."

^ (self findTokens: delimiters) 
	detect: [:str | (str includesSubString: subString)] 
	ifNone: nil! !

!String methodsFor: 'converting' stamp: 'jmv 3/2/2010 10:10'!
substrings
	"Answer an array of the substrings that compose the receiver."
	| result end beginning |

	result _ WriteStream on: (Array new: 10).



	end _ 0.
	"find one substring each time through this loop"
	[ 
		"find the beginning of the next substring"
		beginning _ self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: nil.
		beginning notNil ] 
	whileTrue: [
		"find the end"
		end _ self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ].
		end _ end - 1.

		result nextPut: (self copyFrom: beginning to: end).

	].

	^result contents! !


!SyntaxError methodsFor: 'initialization' stamp: 'jmv 3/2/2010 10:10'!
setClass: aClass code: aString debugger: aDebugger doitFlag: flag

	| types printables badChar |
	class _ aClass.
	debugger _ aDebugger.
	selector _ aClass parserClass new parseSelector: aString.
	types _ Smalltalk actualScannerClass classPool at: #TypeTable.	"dictionary"
	printables _ '!!@#$%&*-_=+<>{}?/\,¥£¢¤¦»¼ÐÑÒÔÓÕÉò¾òøùÀÇÈ`~`' asSet.
	badChar := aString detect: [:aChar | (types at: aChar asciiValue ifAbsent: [#xLetter]) == #xBinary and: [
			(printables includes: aChar) not]] ifNone: nil.
	contents _ badChar 
		ifNil: [aString]
		ifNotNil: ['<<<This string contains a character (ascii value ', 
			badChar asciiValue printString,
			') that is not normally used in code>>> ', aString].
	category ifNil: [category _ aClass organization categoryOfElement: selector].
	category ifNil: [category _ ClassOrganizer default].
	doitFlag _ flag! !


!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'jmv 3/2/2010 10:10'!
selector: selector recategorizedFrom: oldCategory to: newCategory inClass: aClass

	self trigger: (RecategorizedEvent 
				method: (aClass compiledMethodAt: selector ifAbsent: nil)
				protocol: newCategory
				class: aClass
				oldProtocol: oldCategory)! !


!SystemDictionary methodsFor: 'class names' stamp: 'jmv 3/2/2010 10:11'!
forgetClass: aClass logged: aBool 
	"Delete the class, aClass, from the system.
	Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem."

	aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: aClass category].		
	SystemOrganization removeElement: aClass name.
	self removeFromStartUpList: aClass.
	self removeFromShutDownList: aClass.
	self removeKey: aClass name ifAbsent: nil.
	self flushClassNameCache! !

!SystemDictionary methodsFor: 'class names' stamp: 'jmv 3/2/2010 10:11'!
hasClassNamed: aString
	"Answer whether there is a class of the given name, but don't intern aString if it's not alrady interned.  4/29/96 sw"

	Symbol hasInterned: aString ifTrue: [ :aSymbol | 
		^ (self at: aSymbol ifAbsent: nil) isKindOf: Class].
	^ false! !

!SystemDictionary methodsFor: 'class names' stamp: 'jmv 3/2/2010 10:12'!
removeClassNamed: aName
	"Invoked from fileouts:  if there is currently a class in the system named aName, then remove it.  If anything untoward happens, report it in the Transcript.  "

	| oldClass |
	(oldClass _ self at: aName asSymbol ifAbsent: nil)
		ifNil: [
			Transcript cr; show: 'Removal of class named ', aName, ' ignored because ', aName, ' does not exist.'.
			^ self].

	oldClass removeFromSystem! !

!SystemDictionary methodsFor: 'class names' stamp: 'jmv 3/2/2010 10:12'!
renameClassNamed: oldName as: newName
	"Invoked from fileouts:  if there is currently a class in the system named oldName, then rename it to newName.  If anything untoward happens, report it in the Transcript.  "

	| oldClass |
	(oldClass _ self at: oldName asSymbol ifAbsent: nil)
		ifNil: [
			Transcript cr; show: 'Class-rename for ', oldName, ' ignored because ', oldName, ' does not exist.'.
			^ self].

	oldClass rename: newName! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 3/2/2010 10:11'!
macroBenchmark1    "Smalltalk macroBenchmark1"
	"Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code.  This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same.  Because it never installs the new method, it should not cause any flusing of the method cache."
	 | methodNode oldMethod newMethod badOnes oldCodeString n classes |
	classes _ Smalltalk allClasses select: [:c | c name < 'B3'].
	badOnes _ OrderedCollection new.
'Decompiling and recompiling...'
displayProgressAt: Sensor cursorPoint
from: 0 to: (classes detectSum: [:c | c selectors size])
during: [:bar | n _ 0.
	classes do:
		[:cls | 
		"Transcript cr; show: cls name."
		cls selectors do:
			[:selector | bar value: (n _ n+1).
			oldMethod _ cls compiledMethodAt: selector.
			oldCodeString _ (cls decompilerClass new
								decompile: selector in: cls method: oldMethod)
							decompileString.
			methodNode _ cls compilerClass new
						compile: oldCodeString
						in: cls notifying: nil ifFail: nil.
			newMethod _ methodNode generate: #(0 0 0 0).
			oldCodeString = (cls decompilerClass new
								decompile: selector in: cls method: newMethod)
							decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]].
].
	^ badOnes size! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 3/2/2010 10:12'!
testDecompiler    "Smalltalk testDecompiler"
	"Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code.  This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same."
	 | methodNode oldMethod newMethod badOnes oldCodeString n |
	badOnes _ OrderedCollection new.
	Smalltalk forgetDoIts.
'Decompiling all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allBehaviorsDo:
		[:cls | 
		"Transcript cr; show: cls name."
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			oldMethod _ cls compiledMethodAt: selector.
			oldCodeString _ (cls decompilerClass new
								decompile: selector in: cls method: oldMethod)
							decompileString.
			methodNode _ cls compilerClass new
						compile: oldCodeString
						in: cls
						notifying: nil
						ifFail: nil.
			newMethod _ methodNode generate: #(0 0 0 0).
			oldCodeString = (cls decompilerClass new decompile: selector in: cls method: newMethod) decompileString 
				ifFalse: [
					Transcript cr; show: '***' , cls name , ' ' , selector.
					badOnes add: cls name , ' ' , selector]]].
].
	Smalltalk browseMessageList: badOnes asSortedCollection name: 'Decompiler Discrepancies'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 3/2/2010 10:12'!
testFormatter    "Smalltalk testFormatter"
	"Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code.
	The formatting used will be classic monochrome."

	 | newCodeString methodNode oldMethod newMethod badOnes n |
	badOnes _ OrderedCollection new.
	Smalltalk forgetDoIts.
'Formatting all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allBehaviorsDo:
		[:cls | 
		"Transcript cr; show: cls name."
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			newCodeString _ (cls compilerClass new)
				format: (cls sourceCodeAt: selector)
				in: cls notifying: nil.
			methodNode _ cls compilerClass new
						compile: newCodeString
						in: cls
						notifying: nil
						ifFail: nil.
			newMethod _ methodNode generate: #(0 0 0 0).
			oldMethod _ cls compiledMethodAt: selector.
			oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector.
											badOnes add: cls name , ' ' , selector]]].
].
	Smalltalk browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 3/2/2010 10:11'!
logError: errMsg inContext: aContext to: aFilename
	"Log the error message and a stack trace to the given file."

	| ff |
	FileDirectory default deleteFileNamed: aFilename ifAbsent: nil.
	(ff _ FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"].

  	ff nextPutAll: errMsg; cr.
	aContext errorReportOn: ff.
	ff close.! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 3/2/2010 10:11'!
allUnusedClassesWithout: classesAndMessagesPair
	"Enumerates all classes in the system and returns a list of those that are apparently unused. A class is considered in use if it (a) has subclasses or (b) is referred to by some method or (c) has its name in use as a literal (but not in the same class) or: (d) some instance is a global."
	"Smalltalk unusedClasses"

	| unused cl |
	Smalltalk garbageCollect.
	unused _ Smalltalk classNames asIdentitySet
				copyWithoutAll: (self allGlobalRefsWithout: classesAndMessagesPair).
				
	Smalltalk do: [ :global |
		unused remove: global class name ifAbsent: nil].
	
	^ unused reject:
		[:cName | cl _ Smalltalk at: cName.
		cl subclasses notEmpty
			"or: [ cl someInstance notNil ]"
			or: [cl inheritsFrom: FileDirectory]]! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 3/2/2010 10:13'!
unimplemented
	"Answer an Array of each message that is sent by an expression in a method but is not implemented by any object in the system."

	| all unimplemented entry |
	all _ IdentitySet new: Symbol instanceCount * 2.
	Cursor wait showWhile: 
		[self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | all add: aSelector]]].

	unimplemented _ IdentityDictionary new.
	Cursor execute showWhile: [
		self allBehaviorsDo: [:cl |
			 cl selectorsDo: [:sel |
				(cl compiledMethodAt: sel) messages do: [:m |
					(all includes: m) ifFalse: [
						entry _ unimplemented at: m ifAbsent: [Array new].
						entry _ entry copyWith: (cl name, '>', sel).
						unimplemented at: m put: entry]]]]].

	"remove some clutter from the result:"
	#(DoIt DoItIn: doPrimitive: primitiveFail success:)
		do: [ :sel | unimplemented removeKey: sel ifAbsent: nil].

	^ unimplemented! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 3/2/2010 10:12'!
removeAllUnSentMessages
	"Smalltalk removeAllUnSentMessages"
	"[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. 
	Smalltalk removeAllUnSentMessages > 0] whileTrue."
	"Remove all implementations of unsent messages."
	| sels n |
	sels _ self allUnSentMessages.
	self presumedSentMessages
		do: [:sel | sels
				remove: sel
				ifAbsent: nil].
	sels size = 0
		ifTrue: [^ 0].
	n _ 0.
	Smalltalk
		allBehaviorsDo: [:x | n _ n + 1].
	'Removing ' , sels size printString , ' messages . . .'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: n
		during: [:bar | 
			n _ 0.
			self
				allBehaviorsDo: [:class | 
					bar value: (n _ n + 1).
					sels
						do: [:sel | class removeSelector: sel]]].
	^ sels size! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 3/2/2010 10:11'!
add: aClass toList: startUpOrShutDownList after: predecessor
	"Add the name of aClass to the startUp or shutDown list.
	Add it after the name of predecessor, or at the end if predecessor is nil."

	| name earlierName |
	name _ aClass name.
	(self at: name ifAbsent: nil) == aClass ifFalse: [
		self error: name , ' cannot be found in Smalltalk dictionary.'].
	predecessor
		ifNil: ["No-op if alredy in the list."
				(startUpOrShutDownList includes: name) ifFalse:
					[startUpOrShutDownList == StartUpList
						ifTrue: ["Add to end of startUp list"
								startUpOrShutDownList addLast: name]
						ifFalse: ["Add to front of shutDown list"
								startUpOrShutDownList addFirst: name]]]
		ifNotNil: ["Add after predecessor, moving it if already there."
				earlierName _ predecessor name.
				(self at: earlierName) == predecessor ifFalse: [
					self error: earlierName , ' cannot be found in Smalltalk dictionary.'].
				(startUpOrShutDownList includes: earlierName) ifFalse: [
					self error: earlierName , ' cannot be found in the list.'].
				startUpOrShutDownList remove: name ifAbsent: nil.
				startUpOrShutDownList add: name after: earlierName]! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 3/2/2010 10:12'!
removeFromShutDownList: aClass

	ShutDownList remove: aClass name ifAbsent: nil! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 3/2/2010 10:12'!
removeFromStartUpList: aClass

	StartUpList remove: aClass name ifAbsent: nil! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 3/2/2010 10:12'!
saveAsNewVersion
	"Save the image/changes using the next available version number."

	"Smalltalk saveAsNewVersion"
	| newName changesName aName anIndex |

	aName _ FileDirectory baseNameFor: (FileDirectory default localNameFor: Smalltalk imageName).
	anIndex _ aName lastIndexOf: FileDirectory dot asCharacter ifAbsent: nil.
	(anIndex notNil and: [(aName copyFrom: anIndex + 1 to: aName size) isAllDigits])
		ifTrue:
			[aName _ aName copyFrom: 1 to: anIndex - 1].

	newName _ FileDirectory default nextNameFor: aName extension: FileDirectory imageSuffix.
	changesName _ self fullNameForChangesNamed: newName.

	"Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number"
	(FileDirectory default includesKey: changesName)
		ifTrue:
			[^ self inform:
'There is already .changes file of the desired name,
', newName, '
curiously already present, even though there is
no corresponding .image file.   Please remedy
manually and then repeat your request.'].

	(SourceFiles at: 2) ifNotNil:
		[self saveChangesInFileNamed: (self fullNameForChangesNamed: newName)].
	self saveImageInFileNamed: (self fullNameForImageNamed: newName)


! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 3/2/2010 10:12'!
send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument
	"Send the message #startUp: or #shutDown: to each class named in the list.
	The argument indicates if the system is about to quit (for #shutDown:) or if
	the image is resuming (for #startUp:).
	If any name cannot be found, then remove it from the list."

	| removals class |
	removals _ OrderedCollection new.
	startUpOrShutDownList do:
		[:name |
		class _ self at: name ifAbsent: nil.
		class
			ifNil: [removals add: name]
			ifNotNil: [
				class isInMemory ifTrue: [
					class perform: startUpOrShutDown with: argument]]].

	"Remove any obsolete entries, but after the iteration"
	startUpOrShutDownList removeAll: removals! !

!SystemDictionary methodsFor: 'special objects' stamp: 'jmv 3/2/2010 10:12'!
recreateSpecialObjectsArray
	"Smalltalk recreateSpecialObjectsArray"
	"The Special Objects Array is an array of object pointers used
	by the
	Squeak virtual machine. Its contents are critical and
	unchecked, so don't even think of playing here unless you
	know what you are doing."
	| newArray |
	newArray := Array new: 50.
	"Nil false and true get used throughout the interpreter"
	newArray at: 1 put: nil.
	newArray at: 2 put: false.
	newArray at: 3 put: true.
	"This association holds the active process (a ProcessScheduler)"
	newArray at: 4 put: (self associationAt: #Processor).
	"Numerous classes below used for type checking and instantiation"
	newArray at: 5 put: Bitmap.
	newArray at: 6 put: SmallInteger.
	newArray at: 7 put: String.
	newArray at: 8 put: Array.
	newArray at: 9 put: Smalltalk.
	newArray at: 10 put: Float.
	newArray at: 11 put: MethodContext.
	newArray at: 12 put: BlockContext.
	newArray at: 13 put: Point.
	newArray at: 14 put: LargePositiveInteger.
	newArray at: 15 put: Display.
	newArray at: 16 put: Message.
	newArray at: 17 put: CompiledMethod.
	newArray at: 18 put: (self specialObjectsArray at: 18).
	"(low space Semaphore)"
	newArray at: 19 put: Semaphore.
	newArray at: 20 put: Character.
	newArray at: 21 put: #doesNotUnderstand:.
	newArray at: 22 put: #cannotReturn:.
	newArray at: 23 put: nil.
	"An array of the 32 selectors that are compiled as special bytecodes,
	 paired alternately with the number of arguments each takes."
	newArray at: 24 put: #(	#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
							#* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
							#at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
							#blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
	"An array of the 255 Characters in ascii order."
	newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).
	newArray at: 26 put: #mustBeBoolean.
	newArray at: 27 put: ByteArray.
	newArray at: 28 put: Process.
	"An array of up to 31 classes whose instances will have compact headers"
	newArray at: 29 put: self compactClassesArray.
	newArray at: 30 put: (self specialObjectsArray at: 30).
	"(delay Semaphore)"
	newArray at: 31 put: (self specialObjectsArray at: 31).
	"(user interrupt Semaphore)"
	"Prototype instances that can be copied for fast initialization"
	newArray at: 32 put: (Float new: 2).
	newArray at: 33 put: (LargePositiveInteger new: 4).
	newArray at: 34 put: Point new.
	newArray at: 35 put: #cannotInterpret:.
	"Note: This must be fixed once we start using context prototypes (yeah, right)"
	"(MethodContext new: CompiledMethod fullFrameSize)."
	newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)"
	newArray at: 37 put: BlockClosure.
	"(BlockContext new: CompiledMethod fullFrameSize)."
	newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)"
	newArray at: 39 put: (self specialObjectsArray at: 39).	"preserve external semaphores"
	"array of objects referred to by external code"
	newArray at: 40 put: PseudoContext.
	newArray at: 41 put: TranslatedMethod.
	"finalization Semaphore"
	newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]).
	newArray at: 43 put: LargeNegativeInteger.
	"External objects for callout.
	 Note: Written so that one can actually completely remove the FFI."
	newArray at: 44 put: (self at: #ExternalAddress ifAbsent: nil).
	newArray at: 45 put: (self at: #ExternalStructure ifAbsent: nil).
	newArray at: 46 put: (self at: #ExternalData ifAbsent: nil).
	newArray at: 47 put: (self at: #ExternalFunction ifAbsent: nil).
	newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: nil).
	newArray at: 49 put: #aboutToReturn:through:.
	newArray at: 50 put: #run:with:in:.
	"Now replace the interpreter's reference in one atomic operation"
	self specialObjectsArray become: newArray! !


!SystemVersion methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:13'!
unregisterUpdate: update
	self updates remove: update ifAbsent: nil! !


!SystemWindow methodsFor: 'panes' stamp: 'jmv 3/2/2010 10:13'!
paneMorphSatisfying: aBlock
	^ paneMorphs detect: [:aPane | aBlock value: aPane] ifNone: nil! !

!SystemWindow methodsFor: 'panes' stamp: 'jmv 3/2/2010 10:13'!
setUpdatablePanesFrom: getSelectors
	| aList aPane possibles |
	"Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors.  Order is important here!!  Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"

	aList _ OrderedCollection new.
	possibles _ OrderedCollection new.
	self allMorphsDo: [ :pane | 
		(pane isKindOf: PluggableListMorph) ifTrue: [
			possibles add: pane.
		].
	].

	getSelectors do: [:sel | 
		aPane _ possibles detect: [ :pane | pane getListSelector == sel] ifNone: nil.
		aPane
			ifNotNil:
				[aList add: aPane]
			ifNil:
				[Transcript cr; show: 'Warning: pane ', sel, ' not found.']].
	updatablePanes _ aList asArray! !


!TestRunner methodsFor: 'menus' stamp: 'jmv 3/2/2010 10:13'!
listMenu: aMenu shifted: shiftState
	aMenu title: 'Test Cases'.
	aMenu add: 'select all' target: self selector: #selectAll.
	aMenu add: 'deselect all' target: self selector: #deselectAll.
	aMenu add: 'toggle selections' target: self selector: #toggleSelections.
	aMenu add: 'filter' target: self selector: #setFilter.
	running ifNotNil: [
		aMenu add: 'stop' target: self selector: #terminateRun
		].
	selectedSuite > 0 ifTrue: [ | cls |
		cls _ (tests at: selectedSuite ifAbsent: ['']) copyUpTo: Character space.
		cls _ cls asSymbol.
		cls _ (Smalltalk at: cls ifAbsent: nil).
		cls ifNotNil: [ | mtc |
			aMenu addLine.
			aMenu add: 'browse' target: self selector: #browse: argument: cls.
		].
	].
	shiftState ifTrue: [
		aMenu addLine.
		testsList addCustomMenuItems: aMenu hand: ActiveHand.
	].
	^aMenu
! !


!TextEditor methodsFor: 'menu messages' stamp: 'jmv 3/2/2010 10:13'!
saveContentsInFile
	"Save the receiver's contents string to a file, prompting the user for a file-name.  Suggest a reasonable file-name."

	| fileName stringToSave parentWindow labelToUse suggestedName lastIndex |
	stringToSave := paragraph text string.
	stringToSave size = 0 ifTrue: [^self inform: 'nothing to save.'].
	parentWindow := model dependents 
				detect: [:dep | dep isKindOf: SystemWindow]
				ifNone: nil.
	labelToUse := parentWindow ifNil: ['Untitled']
				ifNotNil: [parentWindow label].
	suggestedName := nil.
	#(#('Decompressed contents of: ' '.gz')) do: 
			[:leaderTrailer | 
			"can add more here..."

			(labelToUse beginsWith: leaderTrailer first) 
				ifTrue: 
					[suggestedName := labelToUse copyFrom: leaderTrailer first size + 1
								to: labelToUse size.
					(labelToUse endsWith: leaderTrailer last) 
						ifTrue: 
							[suggestedName := suggestedName copyFrom: 1
										to: suggestedName size - leaderTrailer last size]
						ifFalse: 
							[lastIndex := suggestedName lastIndexOf: $. ifAbsent: [0].
							(lastIndex = 0 or: [lastIndex = 1]) 
								ifFalse: [suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1]]]].
	suggestedName ifNil: [suggestedName := labelToUse , '.text'].
	fileName := FillInTheBlank request: 'File name?'
				initialAnswer: suggestedName.
	fileName isEmptyOrNil 
		ifFalse: 
			[(FileStream newFileNamed: fileName)
				nextPutAll: stringToSave;
				close]! !


!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 3/2/2010 10:08'!
browseItHere
	"Retarget the receiver's window to look at the selected class, if appropriate.  3/1/96 sw"
	| aSymbol foundClass b |
	(((b _ model) isKindOf: Browser) and: [b couldBrowseAnyClass])
		ifFalse: [^ morph flash].
	model okToChange ifFalse: [^ morph flash].
	self selectionInterval isEmpty ifTrue: [self selectWord].
	(aSymbol _ self selectedSymbol) isNil ifTrue: [^ morph flash].

	foundClass _ (Smalltalk at: aSymbol ifAbsent: nil).
		foundClass isNil ifTrue: [^ morph flash].
		(foundClass isKindOf: Class)
			ifTrue:
				[model systemCategoryListIndex: 
					(model systemCategoryList indexOf: foundClass category).
	model classListIndex: (model classList indexOf: foundClass name)]! !

!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 3/2/2010 10:08'!
explain
	"Try to shed some light on what kind of entity the current selection is. 
	The selection must be a single token or construct. Insert the answer after 
	the selection. Send private messages whose names begin with 'explain' 
	that return a string if they recognize the selection, else nil."

	| string tiVars cgVars selectors delimitors numbers sorry reply symbol |
Cursor execute showWhile: [
			sorry _ '"Sorry, I can''t explain that.  Please select a single
token, construct, or special character.'.
			sorry _ sorry , (morph canDiscardEdits
							ifFalse: ['  Also, please cancel or accept."']
							ifTrue: ['"']).
			(string _ self selection asString) isEmpty
				ifTrue: [reply _ '']
				ifFalse: [
					string _ self explainScan: string.
					"Remove space, tab, cr"
					"Temps and Instance vars need only test strings that are all letters"
					(string detect: [:char | (char isLetter or: [char isDigit]) not]
						ifNone: nil) ifNil: [
							tiVars _ (self explainTemp: string)
								ifNil: [self explainInst: string]].
					(tiVars == nil and: [model respondsTo: #explainSpecial:])
						ifTrue: [tiVars _ model explainSpecial: string].
					tiVars _ tiVars
						ifNil: [ '']
						ifNotNil: [ tiVars , '\' withCRs].
					"Context, Class, Pool, and Global vars, and Selectors need 
					only test symbols"
					(Symbol hasInterned: string ifTrue: [:s | symbol _ s])
						ifTrue: [
							cgVars _ (self explainCtxt: symbol) 
								ifNil: [ (self explainClass: symbol)
									ifNil: [ self explainGlobal: symbol]].
							"See if it is a Selector (sent here or not)"
							selectors _ (self explainMySel: symbol)
								ifNil: [(self explainPartSel: string)
									ifNil: [ self explainAnySel: symbol]]]
						ifFalse: [selectors _ self explainPartSel: string].
					cgVars _ cgVars
						ifNil: [ '']
						ifNotNil: [cgVars , '\' withCRs].
					selectors _ selectors
						ifNil: [ '']
						ifNotNil: [ selectors , '\' withCRs].
					delimitors _ string size = 1
						ifTrue: ["single special characters"
							self explainChar: string]
						ifFalse: ["matched delimitors"
							self explainDelimitor: string].
					numbers _ self explainNumber: string.
					numbers ifNil: [numbers _ ''].
					delimitors ifNil: [delimitors _ ''].
					reply _ tiVars , cgVars , selectors , delimitors , numbers].
			reply size = 0 ifTrue: [reply _ sorry].
			self afterSelectionInsertAndSelect: reply]! !

!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 3/2/2010 10:17'!
explainClass: symbol 
	"Is symbol a class variable or a pool variable?"
	| class reply classes |
	(model respondsTo: #selectedClassOrMetaClass)
		ifFalse: [^ nil].
	(class _ model selectedClassOrMetaClass) ifNil: [^ nil].
	"no class is selected"
	(class isKindOf: Metaclass)
		ifTrue: [class _ class soleInstance].
	classes _ (Array with: class)
				, class allSuperclasses.
	"class variables"
	reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name]
					ifNone: nil)
					notNil]
				ifNone: nil.
	reply ifNotNil: [
		^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 
		'SystemNavigation new browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').'].
	"pool variables"
	classes do: [:each | (each sharedPools
			detect: [:pool | (pool includesKey: symbol)
					and: 
						[reply _ pool.
						true]]
			ifNone: nil)
			notNil].
	reply
		ifNil: [(Undeclared includesKey: symbol)
				ifTrue: [
					^ '"is an undeclared variable.' , '"\' withCRs , 
					'SystemNavigation new browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']]
		ifNotNil: 
			[classes _ WriteStream on: Array new.
			Smalltalk
				allBehaviorsDo: [:each | (each sharedPools
						detect: 
							[:pool | 
							pool == reply]
						ifNone: nil)
						notNil ifTrue: [classes nextPut: each]].
			"Perhaps not print whole list of classes if too long. (unlikely)"
			^ '"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply) asString , 
			', which is used by the following classes ' , classes contents printString , '"\' withCRs , 
			'SystemNavigation new browseAllCallsOn: (' , (Smalltalk keyAtIdentityValue: reply) asString , 
			' bindingOf: #' , symbol , ').'].
	^ nil! !

!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 3/2/2010 10:08'!
explainGlobal: symbol 
	"Is symbol a global variable?"
	| reply classes |
	reply _ Smalltalk at: symbol ifAbsent: [^nil].
	(reply class == Dictionary or:[reply isKindOf: SharedPool class])
		ifTrue: 
			[classes _ Set new.
			Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply]
					ifNone: nil)
					notNil ifTrue: [classes add: each]].
			classes _ classes printString.
			^'"is a global variable.  It is a pool which is used by the following classes ' , (classes allButFirst: 5) , '"'].
	(reply isKindOf: Behavior)
		ifTrue: [^'"is a global variable.  ' , symbol , ' is a class in category ', reply category,
			'."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.'].
	symbol == #Smalltalk ifTrue: [^'"is a global.  Smalltalk is the only instance of SystemDictionary and holds all global variables."'].
	^'"is a global variable.  ' , symbol , ' is ' , reply printString , '"'! !

!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 3/2/2010 10:08'!
explainInst: string 
	"Is string an instance variable of this class?"
	| classes cls |

	(model respondsTo: #selectedClassOrMetaClass) ifTrue: [
		cls _ model selectedClassOrMetaClass].
	cls ifNil: [^ nil].	  "no class known"
	classes _ (Array with: cls)
				, cls allSuperclasses.
	classes _ classes detect: [:each | (each instVarNames
			detect: [:name | name = string] ifNone: nil)
			notNil] ifNone: [^nil].
	classes _ classes printString.
	^ '"is an instance variable of the receiver; defined in class ' , classes , 
		'"\' withCRs , classes , ' systemNavigation browseAllAccessesTo: ''' , string , ''' from: ', classes, '.'! !

!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 3/2/2010 10:08'!
explainMySel: symbol 
	"Is symbol the selector of this method?  Is it sent by this method?  If 
	not, then expalin will call (explainPartSel:) to see if it is a fragment of a 
	selector sent here.  If not, explain will call (explainAnySel:) to catch any 
	selector. "

	| lits classes msg |
	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^nil].	"not in a message"
	classes _ Smalltalk allClassesImplementing: symbol.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	msg = symbol
		ifTrue: [
			^ '"' , symbol , ' is the selector of this very method!!  It is defined in ', classes , 
			'.  To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
		ifFalse: [
			lits _ (model selectedClassOrMetaClass compiledMethodAt:
				msg) messages.
			(lits detect: [:each | each == symbol]
				ifNone: nil)
					ifNil: [^nil].
			^ '"' , symbol , ' is a message selector which is defined in ', classes , 
			'.  To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].! !

!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 3/2/2010 10:17'!
explainPartSel: string 
	"Is this a fragment of a multiple-argument selector sent in this method?"
	| lits whole reply classes s msg |

	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^ nil].  "not in a message"
	string last == $: ifFalse: [^ nil].
	"Name of this method"
	lits _ Array with: msg.
	(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
					ifNone: nil) notNil]
				ifNone: nil) notNil
		ifTrue: [reply _ ', which is the selector of this very method!!'.
			s _ '.  To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
		ifFalse: 
			["Selectors called from this method"
			lits _ (model selectedClassOrMetaClass compiledMethodAt:
				msg) messages.
			(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
							ifNone: nil) notNil]
						ifNone: nil) notNil
				ifFalse: [string = 'primitive:'
					ifTrue: [^self explainChar: '<']
					ifFalse: [^nil]].
			reply _ '.'.
			s _ '.  To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].
	classes _ Smalltalk allClassesImplementing: whole.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	^ '"' , string , ' is one part of the message selector ' , whole, reply , '  It is defined in ' , classes , s! !


!UndeclaredVariable methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 10:13'!
openMenuIn: aBlock 
	| alternatives labels actions lines caption choice |
	alternatives := parser possibleVariablesFor: name.
	labels := OrderedCollection new.
	actions := OrderedCollection new.
	lines := OrderedCollection new.
	name first isLowercase 
		ifTrue: 
			[labels add: 'declare temp'.
			actions add: [parser declareTempAndPaste: name].
			labels add: 'declare instance'.
			actions add: [parser declareInstVar: name]]
		ifFalse: 
			[labels add: 'define new class'.
			actions add: [parser defineClass: name].
			labels add: 'declare global'.
			actions add: [parser declareGlobal: name].
			parser canDeclareClassVariable 
				ifTrue: 
					[labels add: 'declare class variable'.
					actions add: [parser declareClassVar: name]]].
	lines add: labels size.
	alternatives do: 
		[:each | 
		labels add: each.
		actions add: [parser substituteVariable: each atInterval: interval]].
	lines add: labels size.
	labels add: 'cancel'.
	caption := 'Unknown variable: ' , name , ' please correct, or cancel:'.
	choice := aBlock value: labels value: lines value: caption.
	self resume: (actions at: choice ifAbsent: nil)! !


!Utilities class methodsFor: 'miscellaneous' stamp: 'jmv 3/2/2010 10:13'!
awaitMouseUpIn: box repeating: doBlock ifSucceed: succBlock
	"The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock.  While waiting for the mouse to come up, repeatedly execute doBlock. 5/11/96 sw
	6/10/96 sw: call new method that adds extra feature"

	^ self awaitMouseUpIn: box whileMouseDownDo: doBlock whileMouseDownInsideDo: nil ifSucceed: succBlock! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'jmv 3/2/2010 10:14'!
instanceComparisonsBetween: fileName1 and: fileName2
	"For differential results, run printSpaceAnalysis twice with different fileNames,
	then run this method...
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'.
			--- do something that uses space here ---
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'.
		Smalltalk instanceComparisonsBetween: 'STspace.text1' and 'STspace.text2'"

	| instCountDict report f aString items className newInstCount oldInstCount newSpace oldPair oldSpace |
	instCountDict _ Dictionary new.
	report _ ReadWriteStream on: ''.
	f _ FileStream readOnlyFileNamed: fileName1.
	[f atEnd] whileFalse:
		[aString _ f upTo: Character cr.
		items _ aString findTokens: ' '.
		(items size = 4 or: [items size = 5]) ifTrue:
			[instCountDict at: items first put: (Array with: items third asNumber with: items fourth asNumber)]].
	f close.

	f _ FileStream readOnlyFileNamed: fileName2.
	[f atEnd] whileFalse:
		[aString _ f upTo: Character cr.
		items _ aString findTokens: ' '.
		(items size = 4 or: [items size = 5]) ifTrue:
			[className _ items first.
			newInstCount _ items third asNumber.
			newSpace _ items fourth asNumber.
			oldPair _ instCountDict at: className ifAbsent: nil.
			oldInstCount _ oldPair ifNil: [0] ifNotNil: [oldPair first].
			oldSpace _ oldPair ifNil: [0] ifNotNil: [oldPair second].
			oldInstCount ~= newInstCount ifTrue:
				[report nextPutAll: (newInstCount - oldInstCount) printString; tab; nextPutAll: (newSpace - oldSpace) printString; tab; nextPutAll: className asString; cr]]].
	f close.

	(StringHolder new contents: report contents)
		openLabel: 'Instance count differentials between ', fileName1, ' and ', fileName2! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'jmv 3/2/2010 10:14'!
setClassAndSelectorFrom: messageIDString in: csBlock
	"Decode strings of the form <className> [class] <selectorName>.   If <className> does not exist as a class, use nil for the class in the block"

	| aStream aClass maybeClass sel |

	(messageIDString isKindOf: MethodReference) ifTrue: [
		^messageIDString setClassAndSelectorIn: csBlock
	].

	aStream _ ReadStream on: messageIDString.
	aClass _ Smalltalk at: (aStream upTo: $ ) asSymbol ifAbsent: nil.
	maybeClass _ aStream upTo: $ .
	sel _ aStream upTo: $ .
	((maybeClass = 'class') & (sel size ~= 0))
		ifTrue:
			[aClass
				ifNil:
					[csBlock value: nil value: sel asSymbol]
				ifNotNil:
					[csBlock value: aClass class value: sel asSymbol]]
		ifFalse:
			[csBlock value: aClass value: maybeClass asSymbol]


"
Utilities setClassAndSelectorFrom: 'Utilities class oppositeModeTo:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString].

Utilities setClassAndSelectorFrom: 'MessageSet setClassAndSelectorIn:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString].
"
! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'jmv 3/2/2010 10:14'!
purgeRecentSubmissionsOfMissingMethods
	"Utilities purgeRecentSubmissionsOfMissingMethods"

	| keep |
	self flag: #mref.	"fix for faster references to methods"
	RecentSubmissions _ RecentSubmissions select:
		[:aSubmission | 
			Utilities setClassAndSelectorFrom: aSubmission in:
				[:aClass :aSelector |
					keep _ (aClass == nil) not
						and: [aClass isInMemory
						and: [aSelector == #Comment or: [(aClass compiledMethodAt: aSelector ifAbsent: nil) notNil]]]].
			keep]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'jmv 3/2/2010 10:14'!
classFromPattern: pattern withCaption: aCaption
	"If there is a class whose name exactly given by pattern, return it.
	If there is only one class in the system whose name matches pattern, return it.
	Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen.
	This method ignores tab, space, & cr characters in the pattern"

	| toMatch potentialClassNames classNames exactMatch index |
	(toMatch _  pattern copyWithoutAll:
			{Character space.  Character cr.  Character tab})
		isEmpty ifTrue: [^ nil].
	Symbol hasInterned: toMatch ifTrue:
		[:patternSymbol | Smalltalk at: patternSymbol ifPresent:
			[:maybeClass | (maybeClass isKindOf: Class) ifTrue: [^ maybeClass]]].

	toMatch _ (toMatch copyWithout: $.) asLowercase.
	potentialClassNames _ Smalltalk classNames asOrderedCollection.
	classNames _ pattern last = $. 
		ifTrue: [potentialClassNames select:
					[:nm |  nm asLowercase = toMatch]]
		ifFalse: [potentialClassNames select: 
					[:n | n includesSubstring: toMatch caseSensitive: false]].
	classNames isEmpty ifTrue: [^ nil].
	exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: nil.

	index _ classNames size = 1
		ifTrue:	[1]
		ifFalse:	[exactMatch
			ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpWithCaption: aCaption]
			ifNotNil: [classNames addFirst: exactMatch.
				(PopUpMenu labelArray: classNames lines: #(1)) startUpWithCaption: aCaption]].
	index = 0 ifTrue: [^ nil].
	^ Smalltalk at: (classNames at: index) asSymbol

"
	Utilities classFromPattern: 'CharRecog'
	Utilities classFromPattern: 'rRecog'
	Utilities classFromPattern: 'znak'
	Utilities classFromPattern: 'orph'
"
! !

!Utilities class methodsFor: 'tailoring system' stamp: 'jmv 3/2/2010 10:14'!
stripMethods: tripletList messageCode: messageString
	"Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form  (<class name>  <#instance or #class> <selector name>), and with a string to be produced as part of the error msg if any of the methods affected is reached"

	| aClass sel keywords codeString |
	tripletList do:
		[:triplet |  
			(aClass _ (Smalltalk at: triplet first ifAbsent: nil)) notNil ifTrue:
				[triplet second == #class ifTrue:
					[aClass _ aClass class].
				sel _ triplet third.
				keywords _ sel keywords.
				(keywords size = 1 and: [keywords first asSymbol isKeyword not])
					ifTrue:
						[codeString _ keywords first asString]
					ifFalse:
						[codeString _ ''.
						keywords withIndexDo:
							[:kwd :index |
								codeString _ codeString, ' ', (keywords at: index), ' ',
									'arg', index printString]].
				codeString _ codeString, '
	self codeStrippedOut: ', (messageString surroundedBySingleQuotes).

				aClass compile: codeString classified: 'stripped']]! !


!WeakRegistry methodsFor: 'removing' stamp: 'jmv 3/2/2010 10:14'!
remove: oldObject ifAbsent: exceptionBlock
	"Remove oldObject as one of the receiver's elements."
	| removedObject |
	oldObject isNil ifTrue:[^oldObject].
	self protected:[
		removedObject := valueDictionary removeKey: oldObject ifAbsent: nil.
	].
	^removedObject isNil
		ifTrue:[exceptionBlock value]
		ifFalse:[removedObject].
! !


!Workspace methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 10:14'!
saveContentsInFile
	"A bit of a hack to pass along this message to the controller or morph.  (Possibly this Workspace menu item could be deleted, since it's now in the text menu.)"

	| textMorph |
	textMorph := self dependents 
				detect: [:dep | dep isKindOf: PluggableTextMorph]
				ifNone: nil.
	textMorph notNil ifTrue: [^textMorph saveContentsInFile]! !


!WorldState methodsFor: 'alarms' stamp: 'jmv 3/2/2010 10:15'!
removeAlarm: aSelector for: aTarget 
	"Remove the alarm with the given selector"

	| alarm |
	alarm := self alarms 
				detect: [:any | any receiver == aTarget and: [any selector == aSelector]]
				ifNone: nil.
	alarm isNil ifFalse: [self alarms remove: alarm]! !

!WorldState methodsFor: 'hands' stamp: 'jmv 3/2/2010 10:15'!
selectHandsToDrawForDamage: damageList
	"Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle."

	| result hBnds |
	result _ OrderedCollection new.
	hands do: [:h |
		h needsToBeDrawn ifTrue: [
			h hasChanged
				ifTrue: [result add: h]
				ifFalse: [
					hBnds _ h fullBounds.
					(damageList detect: [:r | r intersects: hBnds] ifNone: nil)
						ifNotNil: [result add: h]]]].
	^ result
! !


!WorldTest methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 10:15'!
testDoOneCycleWorksWithDeferredQueue
        "Ensure that nested doOneCycles don't break deferred UI messages"
        | finished |
        [
                WorldState addDeferredUIMessage: [ World doOneCycleNow ].
                WorldState addDeferredUIMessage: nil "whatever".
                World doOneCycleNow.
                finished _ true.
        ] valueWithin: 1 second onTimeout: [finished _ false ].
        self assert: finished! !


!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 3/2/2010 10:16'!
compressAndDecompress: aFile using: tempName stats: stats
	| fileSize tempFile result |
	aFile
		ifNil: [^ nil].
	fileSize _ aFile size.
	(fileSize < 1"00000" "or:[fileSize > 1000000]") ifTrue:[aFile close. ^nil].
	Transcript cr; show:'Testing ', aFile name,' ... '.
	tempFile _ StandardFileStream new open: tempName forWrite: true.
	'Compressing ', aFile name,'...' displayProgressAt: Sensor cursorPoint
		from: 1 to: aFile size during:[:bar|
			result _ self regressionCompress: aFile into: tempFile notifiying: bar stats: stats].
	result ifTrue:[
		'Validating ', aFile name,'...' displayProgressAt: Sensor cursorPoint
			from: 0 to: aFile size during:[:bar|
				result _ self regressionDecompress: aFile from: tempFile notifying: bar stats: stats]].
	aFile close.
	tempFile close.
	FileDirectory default deleteFileNamed: tempName ifAbsent: nil.
	result ~~ false ifTrue:[
		Transcript show:' ok (', (result * 100 truncateTo: 0.01) printString,')'].
	^result! !

