'From Cuis 2.0 of 24 February 2010 [latest update: #440] on 2 March 2010 at 5:22:38 pm'!

!Behavior methodsFor: 'printing' stamp: 'jmv 3/2/2010 15:33'!
literalScannedAs: scannedLiteral notifying: requestor
	"Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote).
	If scannedLiteral is not an association, answer it.
	Else, if it is of the form:
		nil->#NameOfMetaclass
	answer nil->theMetaclass, if any has that name, else report an error.
	Else, if it is of the form:
		#NameOfGlobalVariable->anythiEng
	answer the global, class, or pool association with that nameE, if any, else
	add it to Undeclared a answer the new Association."

	| key value |
	(scannedLiteral isVariableBinding)
		ifFalse: [^ scannedLiteral].
	key _ scannedLiteral key.
	value _ scannedLiteral value.
	key ifNil: [
		(self bindingOf: value) ifNotNil: [ :assoc |
				 (assoc value isKindOf: Behavior)
					ifTrue: [^ nil->assoc value class]].
		requestor notify: 'No such metaclass'.
		^false].
	(key isMemberOf: Symbol)
		ifTrue: "##<global var name>"
			[(self bindingOf: key) ifNotNil:[ :assoc | ^assoc].
			Undeclared at: key put: nil.
			 ^Undeclared bindingOf: key].
	requestor notify: '## must be followed by a non-local variable name'.
	^false

"	Form literalScannedAs: 14 notifying: nil 14
	Form literalScannedAs: #OneBitForm notiEfying: nil  OneBitForm
	Form literalScannedAs: ##OneBitForm notifying: nil  OneBitForm->a Form
	Form literalScannedAs: ##Form notifying: nil   Form->Form
	Form literalScannedAs: ###Form notifying: nil   nilE->Form class
"! !


!BitBlt methodsFor: 'private' stamp: 'jmv 3/2/2010 16:48'!
installStrikeFont: aStrikeFont foregroundColor: foregroundColor

	| lastSourceDepth targetColor sourceDepth destDepth |
	sourceForm ifNotNil: [ lastSourceDepth _ sourceForm depth ].
	sourceForm _ aStrikeFont glyphs.
	sourceDepth _ sourceForm depth.
	destDepth _ destForm depth.
	"Ignore any halftone pattern since we use a color map approach here"
	halftoneForm _ nil.
	sourceY _ 0.
	height _ aStrikeFont height.

	sourceDepth = 1 ifTrue: [
		self combinationRule: Form paint.
		(colorMap isNil or: [ lastSourceDepth ~= sourceDepth ]) ifTrue: [
			"Set up color map for a different source depth (color font)"
			"Uses caching for reasonable efficiency
			Warning: We are not considering that destDepth could change too, requiring a new colormap
			This seems not to cause any problems..."
			colorMap _ self cachedFontColormapFrom1BitTo: destDepth.
			colorMap at: 1 put: (destForm pixelValueFor: Color transparent)].
		colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ]
	
	ifFalse: [
		(Preferences subPixelRenderFonts and: [ foregroundColor = Color black or: [ Preferences subPixelRenderColorFonts ]]) ifTrue: [
			destDepth > 8 ifTrue: [
				"rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)"
				self combinationRule: 37.		"rgbMul"
				colorMap _ (destDepth = 32 or: [ (foregroundColor = Color black) not ]) ifTrue: [
					"rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)"
					"This colorMap is to be used on the second pass with rule 20 (rgbAdd)
					See #displayString:from:to:at:strikeFont:kern:"
					"Note: In 32bpp we always need the second pass, as the source could have transparent pixels, and we need to add to the alpha channel"
					self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]]
			ifFalse: [
				self combinationRule: 25.		"Paint"
				targetColor _ foregroundColor = Color black ifFalse: [ foregroundColor ].
				colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]]
		ifFalse: [
			"Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!"
			self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]).
			colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]].! !


!BlockClosure methodsFor: 'controlling' stamp: 'jmv 3/2/2010 15:35'!
whileNil: aBlock 
	"Unlike #whileTrue/False: this is not compiled inline."
	^ [self value == nil] whileTrue: [ aBlock value ]! !

!BlockClosure methodsFor: 'controlling' stamp: 'jmv 3/2/2010 15:35'!
whileNotNil: aBlock 
	"Unlike #whileTrue/False: this is not compiled inline."
	^ [self value == nil] whileFalse: [aBlock value]! !

!BlockClosure methodsFor: 'private' stamp: 'jmv 3/2/2010 16:48'!
grabProcessorFor: milliseconds onTimeout: timeoutBlock
	"Evaluate the receiver (block), without the possibility of preemption by regular priority processes.
	If not finished after milliseconds, restore original priority and evaluate timeoutBlock.
	Use with care!!"
	"Based on #valueUnpreemptively"
	
	| activeProcess oldPriority result done |
	activeProcess _ Processor activeProcess.
	oldPriority _ activeProcess priority.
	done _ false.
	
	activeProcess priority: Processor highIOPriority + Processor lowIOPriority // 2.
	milliseconds ifNotNil: [
		[
			(Delay forMilliseconds: milliseconds) wait.
			done ifFalse: [
				activeProcess
					suspend;
					priority: oldPriority;
					resume.
				timeoutBlock value ]
		] forkAt: Processor highIOPriority ].

	result _ self ensure: [
		done _ true.
		activeProcess priority: oldPriority].
	
	"Yield after restoring priority to give the preempted processes a chance to run"
	Processor yield.
	^result! !


!BlockContext methodsFor: 'private' stamp: 'jmv 3/2/2010 16:48'!
grabProcessorFor: milliseconds onTimeout: timeoutBlock
	"Evaluate the receiver (block), without the possibility of preemption by regular priority processes.
	If not finished after milliseconds, restore original priority and evaluate timeoutBlock.
	Use with care!!"
	"Based on #valueUnpreemptively"
	
	| activeProcess oldPriority result done |
	activeProcess _ Processor activeProcess.
	oldPriority _ activeProcess priority.
	done _ false.
	
	activeProcess priority: Processor highIOPriority + Processor lowIOPriority // 2.
	milliseconds ifNotNil: [
		[
			(Delay forMilliseconds: milliseconds) wait.
			done ifFalse: [
				activeProcess
					suspend;
					priority: oldPriority;
					resume.
				timeoutBlock value ]
		] forkAt: Processor highIOPriority ].

	result _ self ensure: [
		done _ true.
		activeProcess priority: oldPriority].
	
	"Yield after restoring priority to give the preempted processes a chance to run"
	Processor yield.
	^result! !


!BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'jmv 3/2/2010 15:36'!
tempCountForBlockAt: pc in: method
	"Compute the number of local temporaries in a block.
	 If the block begins with a sequence of push: nil bytecodes then some of
	 These could be initializing local temps.  We can only reliably disambuguate
	 them from other uses of nil by parsing the stack and seeing what the offset
	 of the stack pointer is at the end of the block.

	 There are short-cuts.  The ones we take here are
		- if there is no sequence of push nils there can be no local temps
		- we follow forward jumps to shorten the amount of scanning"
	stackPointer := 0.
	scanner := InstructionStream new method: method pc: pc.
	scanner interpretNextInstructionFor: self.
	blockEnd ifNil: [
		self error: 'pc is not that of a block'].
	scanner nextByte = Encoder pushNilCode ifTrue: [
		joinOffsets := Dictionary new.
		[scanner pc < blockEnd] whileTrue: [
			scanner interpretNextInstructionFor: self]].
	^stackPointer! !

!BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'jmv 3/2/2010 15:37'!
testTempCountForBlockAt: startPc in: method
	"Compute the number of local temporaries in a block.
	 If the block begins with a sequence of push: nil bytecodes then some of
	 These could be initializing local temps.  We can only reliably disambuguate
	 them from other uses of nil by parsing the stack and seeing what the offset
	 of the stack pointer is at the end of the block.There are short-cuts.  The only
	 one we take here is
		- if there is no sequence of push nils there can be no local temps"

	| symbolicLines line prior thePc |
	symbolicLines := Dictionary new.
	method symbolicLinesDo:
		[:pc :lineForPC| symbolicLines at: pc put: lineForPC].
	stackPointer := 0.
	scanner := InstructionStream new method: method pc: startPc.
	scanner interpretNextInstructionFor: self.
	blockEnd ifNil: [
		self error: 'pc is not that of a block'].
	scanner nextByte = Encoder pushNilCode ifTrue: [
		joinOffsets := Dictionary new.
		[scanner pc < blockEnd] whileTrue: [
			line := symbolicLines at: scanner pc.
			prior := stackPointer.
			thePc := scanner pc.
			scanner interpretNextInstructionFor: self.
			Transcript cr; print: prior; nextPutAll: '->'; print: stackPointer;  tab; print: thePc; tab; nextPutAll: line; flush]].
	^stackPointer! !


!BlockNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/2/2010 16:49'!
ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode
	"If a remoteTempNode has been added ensure a statement exists to initialize it."
	remoteTempNode ifNotNil: [
		(statements notEmpty
		  and: [statements first isAssignmentNode
		  and: [statements first variable isTemp
		  and: [statements first variable isIndirectTempVector]]])
			ifTrue: "If this is a decompiled tree, or if a temporary has been added later in
					the analysis then there already is a temp vector initialization node."
				[(statements first variable ~~ remoteTempNode) ifTrue:
					[statements first variable become: remoteTempNode].
				 statements first value numElements: remoteTempNode remoteTemps size]
			ifFalse:
				[statements addFirst: (remoteTempNode nodeToInitialize: rootNode encoder)]].! !


!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/2/2010 15:44'!
addLocalsToPool: locals "<Set of: TempVariableNode>"
	localsPool ifNil: [
		localsPool := IdentitySet new].
	localsPool addAll: locals! !

!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/2/2010 15:44'!
noteBlockEntry: aBlock
	"Evaluate aBlock with the numbering for the block entry."
	locationCounter ifNil: [
		locationCounter := -1].
	aBlock value: locationCounter + 1.
	locationCounter := locationCounter + 2! !


!Categorizer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 15:45'!
categories
	"Answer an Array of categories (names)."
	categoryArray ifNil: [^ nil].
	(categoryArray size = 1 
		and: [categoryArray first = Default & (elementArray size = 0)])
		ifTrue: [^Array with: NullCategory].
	^categoryArray! !

!Categorizer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:51'!
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) ifNotNil: [
				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].! !

!Categorizer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:51'!
classify: element under: heading suppressIfDefault: aBoolean
	"Store the argument, element, in the category named heading.   If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein"

	| catName catIndex elemIndex realHeading |
	((heading = NullCategory) or: [heading == nil])
		ifTrue: [realHeading _ Default]
		ifFalse: [realHeading _ heading asSymbol].
	(catName _ self categoryOfElement: element) = realHeading
		ifTrue: [^ self].  "done if already under that category"

	catName ifNotNil: [
		(aBoolean and: [realHeading = Default])
				ifTrue: [^ self].	  "return if non-Default category already assigned in memory"
		self removeElement: element].	"remove if in another category"

	(categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading].

	catIndex _ categoryArray indexOf: realHeading.
	elemIndex _ 
		catIndex > 1
			ifTrue: [categoryStops at: catIndex - 1]
			ifFalse: [0].
	[(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) 
		and: [element >= (elementArray at: elemIndex)]] whileTrue.

	"elemIndex is now the index for inserting the element. Do the insertion before it."
	elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1
						with: (Array with: element).

	"add one to stops for this and later categories"
	catIndex to: categoryArray size do: 
		[:i | categoryStops at: i put: (categoryStops at: i) + 1].

	(self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! !

!Categorizer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 15:45'!
elementCategoryDict
	| dict firstIndex lastIndex |
	elementArray ifNil: [^ nil].
	dict _ Dictionary new: elementArray size.
	1to: categoryStops size do: [:cat |
		firstIndex _ self firstIndexOfCategoryNumber: cat.
		lastIndex _ self lastIndexOfCategoryNumber: cat.
		firstIndex to: lastIndex do: [:el |
			dict at: (elementArray at: el) put: (categoryArray at: cat)].
	].
	^ dict.! !


!ChangeRecord methodsFor: 'initialization' stamp: 'jmv 3/2/2010 16:51'!
fileIn
	"File the receiver in.  If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it."
	Cursor read showWhile: [
		| methodClass s aSelector |
		(methodClass _ self methodClass) ifNotNil: [
			methodClass compile: self text classified: category withStamp: stamp notifying: nil.
			(aSelector _ self methodSelector) ifNotNil:
				[Utilities noteMethodSubmission: aSelector forClass: methodClass]].
		(type == #doIt) ifTrue:
			[((s _ self string) beginsWith: '----') ifFalse: [Smalltalk actualCompilerClass evaluate: s]].
		(type == #classDefinition) ifTrue: [
			Smalltalk actualCompilerClass evaluate: self string].
		(type == #classComment) ifTrue:
			[ | cls | (cls _ Smalltalk at: class asSymbol) comment: self text stamp: stamp.
			Utilities noteMethodSubmission: #Comment forClass: cls ]]! !


!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 3/2/2010 15:47'!
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 ifNotNil: [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 ifNil: [
		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: 'validation' stamp: 'jmv 3/2/2010 16:53'!
validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize
	"Validate the # of instVars and the format of the subclasses"
	| deltaSize |
	oldClass ifNil: [^ true]. "No subclasses"
	"Compute the # of instvars needed for all subclasses"
	deltaSize _ newInstSize.
	oldClass
		ifNotNil: [deltaSize _ deltaSize - oldClass instVarNames size].
	newSuper
		ifNotNil: [deltaSize _ deltaSize + newSuper instSize].
	(oldClass notNil and: [oldClass superclass notNil]) 
		ifTrue: [deltaSize _ deltaSize - oldClass superclass instSize].
	oldClass
		ifNil: [deltaSize > 254
				ifTrue: [self error: 'More than 254 instance variables'.
					^ false].
			^ true].

	oldClass withAllSubclassesDo: [ :sub | 
		( sub instSize + deltaSize > 254 )
			ifTrue: [
				self error: sub name,' has more than 254 instance variables'.
				^ false].

		"If we get this far, check whether the immediate subclasses of oldClass can keep its layout."
		(newType ~~ #normal) 
			ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]].

	^ true! !


!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 3/2/2010 15:51'!
instVarNameForIndex: index
	"Answer the named instance variable with index index or nil if none."

	| superInstSize |
	index > self instSize ifTrue: [^nil].
	superInstSize := superclass ifNil: [0] ifNotNil: [superclass instSize].
	index > superInstSize ifTrue: [
		^instanceVariables at: index - superInstSize].
	^superclass ifNotNil: [ superclass instVarNameForIndex: index ]! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'jmv 3/2/2010 15:49'!
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
		ifNil: [
			SystemChangeNotifier uniqueInstance 
				methodAdded: compiledMethod 
				selector: selector 
				inProtocol: category 
				class: self 
				requestor: requestor]
		ifNotNil: [
			SystemChangeNotifier uniqueInstance 
				methodChangedFrom: priorMethodOrNil 
				to: compiledMethod 
				selector: selector 
				inClass: self 
				requestor: requestor]! !

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

!ClassDescription methodsFor: 'compiling' stamp: 'jmv 3/2/2010 16:54'!
instVarNamesAndOffsetsDo: aBinaryBlock
	"This is part of the interface between the compiler and a class's instance or field names.
	 The class should enumerate aBinaryBlock with the instance variable name strings and
	 their integer offsets.  The order is important. Names evaluated later will override the
	 same names occurring earlier."

	| superInstSize |
	(superInstSize := superclass ifNotNil: [superclass instSize] ifNil: [0]) > 0 ifTrue: [
		superclass instVarNamesAndOffsetsDo: aBinaryBlock].
	1 to: self instSize - superInstSize do: [ :i | 
		aBinaryBlock value: (instanceVariables at: i) value: i + superInstSize]! !

!ClassDescription methodsFor: 'private' stamp: 'jmv 3/2/2010 16:56'!
setInstVarNames: instVarArray
	"Private - for class initialization only"
	| required |
	required _ self instSize.
	superclass ifNotNil: [
		required _ required - superclass instSize].
	instVarArray size = required
		ifFalse:[
			^self error: required printString, ' instvar names are required'].
	instanceVariables _ instVarArray isEmpty
		ifFalse: [ instVarArray asArray]! !


!Class methodsFor: 'initialize-release' stamp: 'jmv 3/2/2010 16:52'!
declare: varString 
	"Declare class variables common to all instances. Answer whether 
	recompilation is advisable."

	| newVars conflicts |
	newVars _ 
		(Smalltalk actualScannerClass new scanFieldNames: varString)
			collect: [:x | x asSymbol].
	newVars do: [:var | 
		var first isLowercase
			ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
	conflicts _ false.
	classPool
		ifNotNil: [
			(classPool keys reject: [:x | newVars includes: x]) 
				do: [:var | self removeClassVarName: var]].
	(newVars reject: [:var | self classPool includesKey: var])
		do: [:var | "adding"
			"check if new vars defined elsewhere"
			(self bindingOf: var)
				ifNotNil: [ 
					self error: var , ' is defined elsewhere'.
					conflicts _ true]].
	newVars size > 0
		ifTrue: [
			classPool _ self classPool.
			"in case it was nil"
			newVars do: [:var | classPool declare: var from: Undeclared]].
	^conflicts! !


!Beeper class methodsFor: 'customize' stamp: 'jmv 3/2/2010 15:31'!
default
	"When the default is not defined it is
	initialized using #newDefault."

	default ifNil: [ default := self newDefault ].
	^ default! !


!BreakpointManager class methodsFor: 'install-uninstall' stamp: 'jmv 3/2/2010 15:41'!
installInClass: aClass selector: aSymbol 
	"Install a new method containing a breakpoint.
	The receiver will remember this for unstalling it later"

	(self compilePrototype: aSymbol in: aClass) ifNotNil: [ :breakMethod  |
		self installed at: breakMethod put: aClass >> aSymbol. "old method"
		aClass methodDictionary at: aSymbol put: breakMethod ]! !

!BreakpointManager class methodsFor: 'private' stamp: 'jmv 3/2/2010 15:39'!
compilePrototype: aSymbol in: aClass 
	"Compile and return a new method containing a break statement"

	| source node |
	source := self breakpointMethodSourceFor: aSymbol in: aClass.
	node := aClass compilerClass new
		compile: source
		in: aClass 
		notifying: nil 
		ifFail: [self error: '[breakpoint] unable to install breakpoint'].
	^node ifNotNil: [ node generate: #(0 0 0 0) ]! !

!BreakpointManager class methodsFor: 'private' stamp: 'jmv 3/2/2010 15:42'!
installed
	Installed ifNil: [Installed := IdentityDictionary new].
	^Installed! !


!ChangeSet class methodsFor: 'fileIn/Out' stamp: 'jmv 3/2/2010 15:46'!
superclassOrder: classes
	"Arrange the classes in the collection, classes, in superclass order so the 
	classes can be properly filed in. Do it in sets instead of ordered collections.
	SqR 4/12/2000 22:04"

	| all list inclusionSet cache |

	list _ classes copy. "list is indexable"
	inclusionSet _ list asSet. cache _ Dictionary new.
	all _ OrderedCollection new: list size.
	list size timesRepeat:
		[
			| aClassIndex aClass |
			aClassIndex _ list findFirst: [:one | one notNil and: [
				self doWeFileOut: one given: inclusionSet cache: cache]].
			aClass _ list at: aClassIndex.
			all addLast: aClass.
			inclusionSet remove: aClass.
			list at: aClassIndex put: nil
		].
	^all! !


!ClassOrganizer methodsFor: 'private' stamp: 'jmv 3/2/2010 15:52'!
notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil
	(oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil])
		ifTrue: [^ self].
		
	oldDictionaryOrNil ifNil: [
		newDictionaryOrNil keysAndValuesDo: [ :el :cat |
			self notifyOfChangedSelector: el from: nil to: cat].
		^ self.
	].

	newDictionaryOrNil ifNil: [
		oldDictionaryOrNil keysAndValuesDo: [ :el :cat |
			self notifyOfChangedSelector: el from: cat to: nil].
		^ self.
	].
		
	oldDictionaryOrNil keysAndValuesDo: [ :el :cat | | newCat |
		newCat := newDictionaryOrNil at: el.
		self notifyOfChangedSelector: el from: cat to: newCat.
	]! !


!CodeHolder methodsFor: 'categories' stamp: 'jmv 3/2/2010 16:56'!
letUserReclassify: anElement in: aClass
	"Put up a list of categories and solicit one from the user.  
	Answer true if user indeed made a change, else false"
	

	| currentCat newCat |
	currentCat _ aClass organization categoryOfElement: anElement.
	newCat _ self 
				categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")' 
				for: aClass.
	(newCat notNil and: [newCat ~= currentCat])
		ifTrue: [
			aClass organization classify: anElement under: newCat suppressIfDefault: false.
			^ true]
		ifFalse: [
			^ false]! !

!CodeHolder methodsFor: 'commands' stamp: 'jmv 3/2/2010 15:53'!
copyUpOrCopyDown
	"Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing.  Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established."

	| aClass aSelector allClasses implementors aMenu |
	((aClass := self selectedClassOrMetaClass) isNil 
		or: [(aSelector := self selectedMessageName) isNil]) 
			ifTrue: [^Beeper beep].
	allClasses := Utilities hierarchyOfClassesSurrounding: aClass.
	implementors := Smalltalk hierarchyOfImplementorsOf: aSelector
				forClass: aClass.
	aMenu := MenuMorph new defaultTarget: self.
	aMenu title: aClass name , '.' , aSelector 
				, '
Choose where to insert a copy of this method
(blue = current, black = available, red = other implementors'.
	allClasses do: 
			[:cl | | aColor |
			aColor := cl == aClass 
						ifTrue: [#blue]
						ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]].
			aColor == #red 
				ifFalse: 
					[aMenu 
						add: cl name
						selector: #spawnToClass:
						argument: cl]
				ifTrue: 
					[aMenu 
						add: cl name
						selector: #spawnToCollidingClass:
						argument: cl].
			aMenu lastItem color: (Color colorFrom: aColor)].
	aMenu popUpInWorld! !

!CodeHolder methodsFor: 'commands' stamp: 'jmv 3/2/2010 15:53'!
spawn: aString 
	"Create and schedule a spawned message category browser for the currently selected message category.  The initial text view contains the characters in aString.  In the spawned browser, preselect the current selector (if any) as the going-in assumption, though upon acceptance this will often change"

	| newBrowser  aClass |
	(aClass _ self selectedClassOrMetaClass) ifNil: [
		^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']].

	self categoryOfCurrentMethod
		ifNil: [
			self buildClassBrowserEditString: aString]
		ifNotNil: [ :cat |
			newBrowser _ Browser new setClass: aClass selector: self selectedMessageName.
			self suggestCategoryToSpawnedBrowser: newBrowser.
			Browser openBrowserView: (newBrowser openMessageCatEditString: aString)
				label: 'category "', cat, '" in ', 
					newBrowser selectedClassOrMetaClassName]! !


!Browser methodsFor: 'breakpoints' stamp: 'jmv 3/2/2010 15:43'!
toggleBreakOnEntry
	"Install or uninstall a halt-on-entry breakpoint"

	| selectedMethod |
	self selectedClassOrMetaClass ifNil: [ ^self].
	selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName.
	selectedMethod hasBreakpoint
		ifTrue:
			[BreakpointManager unInstall: selectedMethod]
		ifFalse:
			[BreakpointManager 
				installInClass: self selectedClassOrMetaClass
				selector: self selectedMessageName].
	self changed: #messageList! !

!Browser methodsFor: 'class list' stamp: 'jmv 3/2/2010 15:42'!
classListIndex: anInteger 
	"Set anInteger to be the index of the current class selection."

	| className |

	classListIndex _ anInteger.
	self setClassOrganizer.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	self classCommentIndicated
		ifFalse: [self editSelection: (anInteger = 0
					ifTrue: [metaClassIndicated | (systemCategoryListIndex = 0)
						ifTrue: [#none]
						ifFalse: [#newClass]]
					ifFalse: [#editClass])].
	contents _ nil.
	self selectedClass
		ifNotNil: [
			className _ self selectedClass name.
					(RecentClasses includes: className)
				ifTrue: [RecentClasses remove: className].
			RecentClasses addFirst: className.
			RecentClasses size > 16
				ifTrue: [RecentClasses removeLast]].
	self changed: #classSelectionChanged.
	self changed: #classCommentText.
	self changed: #classListIndex.	"update my selection"
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #relabel.
	self contentsChanged! !

!Browser methodsFor: 'message functions' stamp: 'jmv 3/2/2010 16:49'!
inspectInstances
	"Inspect all instances of the selected class.  1/26/96 sw"

	| myClass |
	myClass _ self selectedClassOrMetaClass.
	myClass ifNotNil: [
		myClass theNonMetaClass inspectAllInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'jmv 3/2/2010 16:49'!
inspectSubInstances
	"Inspect all instances of the selected class and all its subclasses  1/26/96 sw"

	| aClass |
	aClass _ self selectedClassOrMetaClass.
	aClass ifNotNil: [
		aClass _ aClass theNonMetaClass.
		 aClass inspectSubInstances].
! !


!Date class methodsFor: 'squeak protocol' stamp: 'jmv 3/2/2010 15:56'!
readFrom: aStream 
	"Read a Date from the stream in any of the forms:  
		<day> <month> <year>		(15 April 1982; 15-APR-82; 15.4.82; 15APR82)  
		<month> <day> <year>		(April 15, 1982; 4/15/82)
		<year>-<month>-<day>			(1982-04-15) (ISO8601)"
	| day month year parsedNumber prefix |
	aStream peek = $-
		ifTrue: [prefix := -1]
		ifFalse: [prefix := 1].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	aStream peek isDigit
		ifTrue: [
			parsedNumber := (Integer readFrom: aStream) * prefix.
			(parsedNumber < 0 or: [parsedNumber > 31])
				ifTrue: [year := parsedNumber]].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	aStream peek isLetter
		ifTrue: ["MM-DD-YY or DD-MM-YY or YY-MM-DD"
			month := WriteStream on: (String new: 10).
			[aStream peek isLetter]
				whileTrue: [month nextPut: aStream next].
			month := month contents.
			[aStream peek isAlphaNumeric]
				whileFalse: [aStream skip: 1].
			parsedNumber
				ifNil: ["MM DD YY"
					day := Integer readFrom: aStream]
				ifNotNil: [
					year
						ifNil: ["DD MM YY"
							day := parsedNumber]]]
		ifFalse: ["MM-DD-YY or DD-MM-YY or YY-MM-DD"
			year 
				ifNil: ["MM-DD-YY or DD-MM-YY"
					parsedNumber > 12
						ifTrue: ["DD-MM-YY"
							day := parsedNumber.
							month := Month nameOfMonth: (Integer readFrom: aStream)]
						ifFalse: ["MM-DD-YY"
							month := Month nameOfMonth: parsedNumber.
							day := Integer readFrom: aStream]]
				ifNotNil: ["YY-MM-DD"
					month := Month nameOfMonth: (Integer readFrom: aStream)]].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	year
		ifNil: [year := Integer readFrom: aStream]
		ifNotNil: [day := Integer readFrom: aStream].
	(year < 100 and: [year >= 0]) 
		ifTrue: [
			year < 69 
				ifTrue: [	year := 2000 + year]
				ifFalse: [year := 1900 + year]].

	^ self
		year: year
		month: month
		day: day
! !


!Debugger methodsFor: 'context stack menu' stamp: 'jmv 3/2/2010 16:58'!
buildMorphicNotifierLabelled: label message: messageString 
	| notifyPane window contentTop extentToUse |
	self expandStack.
	window := (PreDebugWindow labelled: label) model: self.
	contentTop := 0.2.
	extentToUse := 650 @ 320.	"nice and wide to show plenty of the error msg"
	window addMorph: (self buttonRowForPreDebugWindow: window)
		frame: (0 @ 0 corner: 1 @ contentTop).
	messageString 
		ifNil: [
			notifyPane := PluggableListMorph 
						model: self
						listGetter: #contextStackList
						indexGetter: #contextStackIndex
						indexSetter: #debugAt:
						menuGetter: nil
						keystrokeAction: nil]
		ifNotNil: [
			notifyPane := PluggableTextMorph 
						model: self
						editorClass: self editorClass
						textGetter: nil
						textSetter: nil
						selectionGetter: nil
						menuGetter: #debugProceedMenu:.
			notifyPane
				editString: messageString;
				askBeforeDiscardingEdits: false].
	window addMorph: notifyPane frame: (0 @ contentTop corner: 1 @ 1).
	^window openInWorldExtent: extentToUse! !

!Debugger methodsFor: 'breakpoints' stamp: 'jmv 3/2/2010 15:56'!
toggleBreakOnEntry
	"Install or uninstall a halt-on-entry breakpoint"

	| selectedMethod |
	self selectedClassOrMetaClass ifNil: [ ^self].
	selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName.
	selectedMethod hasBreakpoint
		ifTrue:
			[BreakpointManager unInstall: selectedMethod]
		ifFalse:
			[BreakpointManager 
				installInClass: self selectedClassOrMetaClass
				selector: self selectedMessageName].! !


!Decompiler methodsFor: 'control' stamp: 'jmv 3/2/2010 16:58'!
checkForClosureCopy: receiver arguments: arguments
	"We just saw a closureCopy:copiedValues: message. Check for and construct a following block."

	| savePc jump |
	receiver == constructor codeThisContext ifFalse: [^false].
	savePc := pc.
	(jump := self interpretJump) ifNotNil: [
		pc := savePc.
		^nil].
	"Definitely a block"
	self doClosureCopyCopiedValues: arguments last "<BraceNode>" elements
		numArgs: arguments first key
		blockSize: jump.
	^true! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'jmv 3/2/2010 16:59'!
popIntoTemporaryVariable: offset
	| maybeTVTag tempVector start |
	maybeTVTag := stack last.
	((maybeTVTag isMemberOf: Association)
	 and: [maybeTVTag key == #pushNewArray]) ifTrue: [
		blockStartsToTempVars "implies we were intialized with temp names."
			ifNotNil: [ "Use the provided temps"
				self assert: ((tempVector := tempVars at: offset + 1 ifAbsent: [ParseNode basicNew]) isTemp
							 and: [tempVector isIndirectTempVector
							 and: [tempVector remoteTemps size = maybeTVTag value size]])]
			ifNil: [ "Synthesize some remote temps"
				tempVector := maybeTVTag value.
				offset + 1 <= tempVars size
					ifTrue: [
						start := 2.
						tempVector at: 1 put: (tempVars at: offset + 1)]
					ifFalse: [
						tempVars := (Array new: offset + 1)
										replaceFrom: 1
										to: tempVars size
										with: tempVars.
						start := 1].
				start to: tempVector size do: [ :i |
					tempVector
						at: i
						put: (constructor
								codeTemp: numLocalTemps + offset + i - 1
								named: 't', (tempVarCount + i) printString)].
				tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector)].
		 tempVarCount := tempVarCount + maybeTVTag value size.
		 stack removeLast.
		 ^self].
	self pushTemporaryVariable: offset; doStore: statements! !


!DecompilerTestFailuresCollector methodsFor: 'accessing' stamp: 'jmv 3/2/2010 15:57'!
assert: aBoolean description: aString resumable: resumableBoolean 
	aBoolean ifFalse: [
		failures ifNil: [
			failures := OrderedCollection new].
		 failures addLast: (thisContext sender tempAt: 1) methodReference]! !


!Delay class methodsFor: 'testing' stamp: 'jmv 3/2/2010 15:57'!
nextWakeUpTime
	^ AccessProtect
		critical: [
			ActiveDelay
				ifNil: [0]
				ifNotNil: [ActiveDelay resumptionTime]]! !


!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 3/2/2010 15:57'!
lcsAt: i at: j
	| lcs |
	(i = 0 or: [j = 0]) ifTrue: [^EmptyLCS].
	lcs := matrix i: i j: j.
	lcs ifNil: [
		lcs := self computeLcsAt: i at: j.
		matrix i: i j: j put: lcs].
	^lcs
! !


!DisplayScreen methodsFor: 'other' stamp: 'jmv 3/2/2010 17:00'!
fullScreen   "Display fullScreen"

	ScreenSave ifNotNil: [ Display _ ScreenSave].
	clippingBox _ super boundingBox! !


!Encoder methodsFor: 'initialize-release' stamp: 'jmv 3/2/2010 17:00'!
init: aClass context: aContext notifying: req
	requestor := req.
	class := aClass.
	nTemps := 0.
	supered := false.
	self initScopeAndLiteralTables.
	class variablesAndOffsetsDo: [ :variable "<String>" :offset "<Integer>" |
		scopeTable
			at: variable
			put: (offset >= 0
					ifTrue: [InstanceVariableNode new
								name: variable index: offset]
					ifFalse: [MaybeContextInstanceVariableNode new
								name: variable index: offset negated])].
	aContext ifNotNil: [
		| homeNode |
		homeNode := self bindTemp: self doItInContextName.
		"0th temp = aContext passed as arg"
		aContext tempNames withIndexDo: [ :variable :index |
			scopeTable
				at: variable
				put: (MessageAsTempNode new
						receiver: homeNode
						selector: #namedTempAt:
						arguments: (Array with: (self encodeLiteral: index))
						precedence: 3
						from: self)]].
	sourceRanges := Dictionary new: 32.
	globalSourceRanges := OrderedCollection new: 32! !


!BytecodeEncoder methodsFor: 'temps' stamp: 'jmv 3/2/2010 15:45'!
bindBlockArg: name within: aBlockNode
	"Read the comment in the superclass's method.
	 If we have closures we should check the argument
	 count against the block, not the method.

	(Note that this isn't entirely adequate either since optimized blocks
	 will slip through the cracks (their arguments (i.e. ifNotNil: [:expr|)
	 are charged against their enclosing block, not themselves))."
	| nArgs |
	self supportsClosureOpcodes ifFalse:
		[^super bindBlockArg: name within: aBlockNode].
	(nArgs := aBlockNode nArgsSlot) ifNil: [
		aBlockNode nArgsSlot: (nArgs := 0)].
	nArgs  >= 15 ifTrue: [
		^self notify: 'Too many arguments'].
	aBlockNode nArgsSlot: nArgs + 1.
	^(self bindTemp: name)
		beBlockArg;
		nowHasDef;
		nowHasRef;
		yourself! !

!BytecodeEncoder methodsFor: 'temps' stamp: 'jmv 3/2/2010 15:45'!
bindBlockTemp: name within: aBlockNode
	"Read the comment in the superclass's bindBlockArg:within: method.
	 If we have closures we should check the argument
	 count against the block, not the method.

	(Note that this isn't entirely adequate either since optimized blocks
	 will slip through the cracks (their arguments (i.e. ifNotNil: [:expr|)
	 are charged against their enclosing block, not themselves))."
	| nArgs |
	self supportsClosureOpcodes ifFalse:
		[^super bindBlockTemp: name within: aBlockNode].
	(nArgs := aBlockNode nArgsSlot) ifNil: [
		aBlockNode nArgsSlot: (nArgs := 0)].
	nArgs >= (CompiledMethod fullFrameSize - 1) ifTrue: [
		^self notify: 'Too many temporaries'].
	aBlockNode nArgsSlot: nArgs + 1.
	^self bindTemp: name! !


!EventHandler methodsFor: 'printing' stamp: 'jmv 3/2/2010 17:01'!
printOn: aStream 
	| aVal recipients |
	super printOn: aStream.
	#('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector') 
		do: [ :aName | 
			(aVal := self instVarNamed: aName) ifNotNil: [ 
				aStream nextPutAll: '; ' , aName , '=' , aVal]].
	(recipients := self allRecipients) notEmpty 
		ifTrue: [
			aStream nextPutAll: ' recipients: '.
			recipients printOn: aStream]! !


!FFT2D methodsFor: 'computing' stamp: 'jmv 3/2/2010 17:01'!
transformColumns: forward
	| transform height realColumn imagColumn |
	height _ realMatrix height.
	transform _ FFT new: height.
	realColumn _ FloatArray new: height.
	imagColumn _ FloatArray new: height.
	1 to: realMatrix width do: [ :j |
		1 to: height do: [ :i |
			realColumn at: i put: (realMatrix i: i j: j)].
		imagMatrix ifNotNil: [
			1 to: height do: [ :i |
				imagColumn at: i put: (imagMatrix i: i j: j)]].
		transform realData: realColumn imagData: imagColumn.
		transform transformForward: forward.
		1 to: height do: [ :i |
			realMatrix i: i j: j put: (realColumn at: i)].
		imagMatrix ifNotNil: [
			1 to: height do: [ :i |
				imagMatrix i: i j: j put: (imagColumn at: i)]]]! !

!FFT2D methodsFor: 'computing' stamp: 'jmv 3/2/2010 17:01'!
transformRows: forward
	| transform width realRow imagRow |
	width _ realMatrix width.
	transform _ FFT new: width.
	realRow _ FloatArray new: width.
	imagRow _ FloatArray new: width.
	1 to: realMatrix height do: [ :i |
		1 to: width do: [ :j |
			realRow at: j put: (realMatrix i: i j: j)].
		imagMatrix ifNotNil: [
			1 to: width do: [ :j |
				imagRow at: j put: (imagMatrix i: i j: j)]].
		transform realData: realRow imagData: imagRow.
		transform transformForward: forward.
		1 to: width do: [ :j |
			realMatrix i: i j: j put: (realRow at: j)].
		imagMatrix ifNotNil: [
			1 to: width do: [ :j |
				imagMatrix i: i j: j put: (imagRow at: j)]]]! !


!FileContentsBrowser methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:00'!
selectedPackage
	| cat |
	cat := self selectedSystemCategoryName.
	^ cat ifNotNil: [
		self packages at: cat asString ifAbsent: nil ]! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'jmv 3/2/2010 15:59'!
removeUnmodifiedCategories
	| theClass |
	self okToChange ifFalse: [^self].
	theClass _ self selectedClass.
	theClass ifNil: [^self].
	Cursor wait showWhile: [
		theClass removeUnmodifiedMethods: theClass selectors.
		theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors].
	self messageCategoryListIndex: 0.
	self changed: #messageCategoryList! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'jmv 3/2/2010 15:59'!
removeUnmodifiedClasses
	| packageList |
	self okToChange ifFalse:[^self].
	packageList := self selectedPackage
						ifNil: [ self packages] 
						ifNotNil: [ Array with: self selectedPackage].
	packageList do:[:package|
		package classes copy do:[:theClass|
			Cursor wait showWhile:[
				theClass removeAllUnmodified.
			].
			theClass hasChanges ifFalse:[
				package removeClass: theClass.
			].
		]].
	self classListIndex: 0.
	self changed: #classList! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'jmv 3/2/2010 15:59'!
removeUnmodifiedMethods
	| theClass cat |
	self okToChange ifFalse:[^self].
	theClass := self selectedClassOrMetaClass.
	theClass ifNil: [ ^self].
	cat := self selectedMessageCategoryName.
	cat ifNil: [ ^self].
	Cursor wait showWhile:[
		theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat).
	].
	self messageListIndex: 0.
	self changed: #messageList.! !

!FileContentsBrowser methodsFor: 'class list' stamp: 'jmv 3/2/2010 15:58'!
findClass
	| pattern foundClass classNames index foundPackage |
	self okToChange ifFalse: [^ self classNotFound].
	pattern _ (FillInTheBlank request: 'Class Name?') asLowercase.
	pattern isEmpty ifTrue: [^ self].
	classNames := Set new.
	self packages do:[:p| classNames addAll: p classes keys].
	classNames := classNames asArray select: 
		[:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].
	classNames isEmpty ifTrue: [^ self].
	index _ classNames size = 1
				ifTrue:	[1]
				ifFalse:	[(PopUpMenu labelArray: classNames lines: #()) startUp].
	index = 0 ifTrue: [^ self].
	foundPackage := nil.
	foundClass := nil.
	self packages do:[:p| 
		(p classes includesKey: (classNames at: index)) ifTrue:[
			foundClass := p classes at: (classNames at: index).
			foundPackage := p]].
	foundClass ifNotNil: [
	 	self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol).
		self classListIndex: (self classList indexOf: foundClass name) ]! !

!FileContentsBrowser methodsFor: 'diffs' stamp: 'jmv 3/2/2010 15:58'!
modifiedClassDefinition
	| pClass rClass old new |
	pClass := self selectedClassOrMetaClass.
	pClass hasDefinition ifFalse: [ ^pClass definition].
	rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent: nil.
	rClass ifNil: [ ^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 17:02'!
infoViewContents
	| theClass |
	editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage].
	self selectedClass ifNil: [^ ''].
	theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: nil.
	editSelection == #editClass ifTrue: [
		^ theClass
			ifNotNil: ['Class exists already in the system']
			ifNil: ['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']! !

!FileContentsBrowser methodsFor: 'infoView' stamp: 'jmv 3/2/2010 15:58'!
packageInfo: p
	| nClasses newClasses oldClasses |
	p ifNil: [^''].
	nClasses := newClasses := oldClasses := 0.
	p classes do:[:cls|
		nClasses := nClasses + 1.
		(Smalltalk includesKey: (cls name asSymbol))
			ifTrue:[oldClasses := oldClasses + 1]
			ifFalse:[newClasses := newClasses + 1]].
	^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'! !


!FileDirectory methodsFor: 'file operations' stamp: 'jmv 3/2/2010 17:02'!
rename: oldFileName toBe: newFileName
	| selection oldName newName |
	"Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name."
	"Modified for retry after GC ar 3/21/98 18:09"
	oldName _ self fullNameFor: oldFileName.
	newName _ self fullNameFor: newFileName.
	(StandardFileStream 
		retryWithGC:[self primRename: oldName to: newName]
		until:[:result| result notNil]
		forFileNamed: oldName) ifNotNil: [ ^self].
	(self fileExists: oldFileName) ifFalse: [
		^self error:'Attempt to rename a non-existent file'.
	].
	(self fileExists: newFileName) ifTrue:[
		selection _ (PopUpMenu labels:
'delete old version
cancel')
				startUpWithCaption: 'Trying to rename a file to be
', newFileName , '
and it already exists.'.
		selection = 1 ifTrue: [
			self deleteFileNamed: newFileName.
			^ self rename: oldFileName toBe: newFileName]].
	^self error:'Failed to rename file'.! !


!FileList methodsFor: 'own services' stamp: 'jmv 3/2/2010 17:03'!
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 ifNotNil: [
						col add: res]]].
	^ col! !

!FileList methodsFor: 'private' stamp: 'jmv 3/2/2010 16:00'!
isFileSelected
	"return if a file is currently selected"

	^ fileName notNil! !


!FileStream class methodsFor: 'directory services' stamp: 'jmv 3/2/2010 17:03'!
creationAndModificationTimeOf: filename

	| stream entry answer |
	answer _ nil.
	stream _ self oldFileOrNoneNamed: filename.
	stream ifNotNil: [
		[
			entry _ stream directoryEntry.
			answer _ Array
				with: entry creationTime
				with: entry modificationTime.
		] ensure: [stream close]].
	^answer! !


!FloatBandMatrix methodsFor: 'accessing' stamp: 'jmv 3/2/2010 17:03'!
i: i j: j
	"Answer element at row i, column j"

	| position |
	position _ (self elementsIndexForI: i j: j).
	^ position
		ifNotNil: [ elements at: position ]
		ifNil: [ 0.0 ]! !

!FloatBandMatrix methodsFor: 'accessing' stamp: 'jmv 3/2/2010 17:04'!
i: i j: j put: aNumber
	"Store aNumber as the element at row i, column j"

	| position |
	position _ (self elementsIndexForI: i j: j).
	position
		ifNotNil: [ elements at: position put: aNumber ]
		ifNil: [ self error: 'Can not store outside band' ]! !


!Form class methodsFor: 'instance creation' stamp: 'jmv 3/2/2010 17:04'!
fromDisplay: aRectangle using: oldForm
	"Like fromDisplay: only if oldForm is the right size, copy into it and answer it instead."

	^(oldForm notNil and: [oldForm extent = aRectangle extent])
		ifTrue: [
			oldForm fromDisplay: aRectangle.
			oldForm]
		ifFalse: [
			self fromDisplay: aRectangle]! !

!Form class methodsFor: 'instance creation' stamp: 'jmv 3/2/2010 16:01'!
fromFileNamedOrNil: fileName
	"Read a Form or ColorForm from the given file."

	| file form |
	file _ FileStream oldFileOrNoneNamed: fileName.
	file ifNil: [ ^ nil ].
	[
		file binary.
		form _ self fromBinaryStream: file] 
			ensure: [ file close ].
	^ form! !


!GrafPort methodsFor: 'copying' stamp: 'jmv 3/2/2010 16:02'!
copyBits
	"Override copybits to do translucency if desired"

	(combinationRule >= 30 and: [combinationRule <= 31]) 
		ifTrue: [
			self copyBitsTranslucent: (alpha ifNil: [255])]
		ifFalse: [super copyBits]! !


!InflateStream methodsFor: 'huffman trees' stamp: 'jmv 3/2/2010 16:07'!
mapValues: values by: valueMap
	| oldValue |
	valueMap ifNil:[^values].
	1 to: values size do:[:i|
		oldValue _ values at: i.
		"Note: there may be nil values if not all values are used"
		oldValue
			ifNil: [ ^values]
			ifNotNil: [ values at: i put: (valueMap at: oldValue+1)]]! !


!InstructionStream class methodsFor: 'compiling' stamp: 'jmv 3/2/2010 17:06'!
instVarNamesAndOffsetsDo: aBinaryBlock
	"This is part of the interface between the compiler and a class's instance or field names.
	 We override here to arrange that the compiler will use MaybeContextInstanceVariableNodes
	 for instances variables of ContextPart or any of its superclasses and subclasses.  The
	 convention to make the compiler use the special nodes is to use negative indices"

	| superInstSize |
	(self withAllSubclasses noneSatisfy: [:class|class isContextClass]) ifTrue:
		[^super instVarNamesAndOffsetsDo: aBinaryBlock].
	(superInstSize := superclass ifNotNil: [superclass instSize] ifNil: [0]) > 0 ifTrue:
		[superclass instVarNamesAndOffsetsDo: aBinaryBlock].
	1 to: self instSize - superInstSize do:
		[:i| aBinaryBlock value: (instanceVariables at: i) value: (i + superInstSize) negated]! !


!LeafNode methodsFor: 'private' stamp: 'jmv 3/2/2010 16:07'!
code: idx type: type

	idx ifNil: [
		^type negated].
	(CodeLimits at: type) > idx 
		ifTrue: [^(CodeBases at: type) + idx].
	^type * 256 + idx! !


!LightWidget methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:09'!
world
	^owner ifNotNil: [owner world]! !

!LightWidget methodsFor: 'view of a model or target' stamp: 'jmv 3/2/2010 16:08'!
performActionWith: data

	| argument |
	action ifNil: [
		^self].
	argument _ actionAdaptor
		ifNil: [data]
		ifNotNil: [data perform: actionAdaptor].
	target perform: action with: argument! !

!LightWidget methodsFor: 'view of a model or target' stamp: 'jmv 3/2/2010 16:09'!
targetAspect

	| answer |
	aspect ifNil: [
		^target].
	answer _ target perform: aspect.
	aspectAdaptor ifNil: [
		^answer].
	^answer perform: aspectAdaptor! !


!ButtonLW methodsFor: 'updating' stamp: 'jmv 3/2/2010 16:50'!
modelChanged
	"The model changed is some way.
	This is usually the place to call #targetAspect to fetch the current value of the aspect from the
		model, and to store it in some Model Extension.
	We must update all Model Extension instance variables with values from the model (i.e. target)
		or with appropriate defaults.
	We must update ourselves and all subviews to reflect the model's new state"

	pressed _ self targetAspect == true.
	
	contentsOrGetter ifNotNil: [
		label _ contentsOrGetter isSymbol
			ifTrue: [
				target perform: contentsOrGetter ]
			ifFalse: [
				contentsOrGetter asString ]].
	
	super modelChanged! !

!ButtonLW methodsFor: 'view of a model or target' stamp: 'jmv 3/2/2010 15:44'!
performAction

	| a |
	target ifNil: [
		^self].
	action ifNil: [
		^self].
	actionArgument ifNil: [
		^target perform: action].
	a _ actionAdaptor
		ifNil: [actionArgument]
		ifNotNil: [actionArgument perform: actionAdaptor].
	target perform: action with: a! !


!CompositeLW methodsFor: 'submorphs-add/remove' stamp: 'jmv 3/2/2010 16:57'!
removeAllMorphs
	| oldMorphs myWorld |
	myWorld _ self world.
	myWorld ifNotNil: [ self invalidRect: self fullBounds].
	submorphs do: [:m | m privateOwner: nil].
	oldMorphs _ submorphs.
	submorphs _ EmptyArray.
	oldMorphs do: [ :m | self removedMorph: m ].
	self layoutChanged! !


!EntryField2LW methodsFor: 'event handling' stamp: 'jmv 3/2/2010 17:00'!
keyStroke: aKeyboardEvent
	"Handle a keystroke event."

	| k |
	aKeyboardEvent commandKeyPressed
		ifTrue: [ ^super keyStroke: aKeyboardEvent ].
	
	k _ aKeyboardEvent keyValue.
	k = 13 ifTrue: [
		crAction ifNotNil: [	
			self performActionWith: contents.
			self updateView.
			^target perform: crAction ].
		^ aKeyboardEvent hand keyboardFocusNext ].
	(k = 30 or: [ k = 31 ])
		ifTrue: [ ^super keyStroke: aKeyboardEvent ].
	(k = 28 and: [ editor isAtStart ])
		ifTrue: [ ^super keyStroke: aKeyboardEvent ].
	(k = 29 and: [ editor isAtEnd ])
		ifTrue: [ ^super keyStroke: aKeyboardEvent ].

	self handleInteraction: [ editor processKeyStroke: aKeyboardEvent ].
	self updateFromContents! !


!ImageLW methodsFor: 'drawing' stamp: 'jmv 3/2/2010 17:06'!
drawOn: aCanvas 
	| f |
	f _ self formToDraw.
	f ifNotNil: [
		aCanvas drawImage: f at: bounds topLeft ]! !

!ImageLW methodsFor: 'drawing' stamp: 'jmv 3/2/2010 16:06'!
generateStretchedForm
	| scale smoothPix pair |
	form ifNil: [
		self formToDraw: nil.
		^self ].
	scale _ 1.0 * bounds extent / form extent.
	smoothPix _ (scale x < 1.0 or: [scale y < 1.0]) 
		ifTrue: [2]
		ifFalse: [1].
	self formToDraw: (scale = (1 @ 1) 
				ifTrue: [form]
				ifFalse: [
					pair := WarpBlt current 
								rotate: form
								degrees: 0
								center: form boundingBox center
								scaleBy: scale
								smoothing: smoothPix.
					pair first])! !


!CheapImageLW methodsFor: 'updating' stamp: 'jmv 3/2/2010 15:46'!
updateView
	| m |
	target ifNil: [
		self form: nil.
		updateTime _ nil.
		^ self].
	
	m _ self findAnyExisting.
	m ifNotNil: [
		updateTime _ m updateTime.
		self form: m formToDraw.
		^ self ].
		
	updateTime _ target updateTime.
	self form: (target formPreferredSize: bounds extent)! !


!ListLW methodsFor: 'submorphs-add/remove' stamp: 'jmv 3/2/2010 17:07'!
addItem: aString height: h font: f target: anObject action: aSymbol argument: anotherObject

	| item |
	item _ self defaultItemClass 
		target: anObject action: aSymbol argument: anotherObject label: aString.
	f ifNotNil: [ item font: f ].
	h ifNotNil: [ item height: h ].
	item width: self itemWidth.
	self addMorph: item.
	^item! !


!ListOldLW methodsFor: 'submorphs-add/remove' stamp: 'jmv 3/2/2010 17:07'!
addItem: aString height: h font: f target: anObject action: aSymbol argument: anotherObject

	| item |
	item _ self defaultItemClass 
		target: anObject action: aSymbol argument: anotherObject label: aString.
	f ifNotNil: [ item font: f ].
	h ifNotNil: [ item height: h ].
	item width: self itemWidth.
	self addMorph: item.
	^item! !


!LiteralNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 16:10'!
printOn: aStream indent: level

	key isVariableBinding
		ifTrue: [
			key key
				ifNil: [
					aStream nextPutAll: '###'; nextPutAll: key value soleInstance name]
				ifNotNil: [
					aStream nextPutAll: '##'; nextPutAll: key key]]
		ifFalse: [
			key storeOn: aStream]! !

!LiteralNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 16:11'!
printWithClosureAnalysisOn: aStream indent: level

	key isVariableBinding
		ifTrue: [
			key key
				ifNil: [
					aStream nextPutAll: '###'; nextPutAll: key value soleInstance name]
				ifNotNil: [
					aStream nextPutAll: '##'; nextPutAll: key key]]
		ifFalse: [
			key storeOn: aStream]! !


!MessageNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 17:09'!
printCaseOn: aStream indent: level 
	"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"
	| braceNode otherwise extra |
	braceNode := arguments first.
	otherwise := arguments last.
	(arguments size = 1 or: [otherwise isJustCaseError]) ifTrue:
		[otherwise := nil].
	receiver
		printOn: aStream
		indent: level
		precedence: 3.
	aStream nextPutAll: ' caseOf: '.
	braceNode isVariableReference
		ifTrue: [braceNode printOn: aStream indent: level]
		ifFalse: 
			[aStream nextPutAll: '{'; crtab: level + 1.
			 braceNode casesForwardDo:
				[:keyNode :valueNode :last | 
				keyNode printOn: aStream indent: level + 1.
				aStream nextPutAll: ' -> '.
				valueNode isComplex
					ifTrue: 
						[aStream crtab: level + 2.
						extra := 1]
					ifFalse: [extra := 0].
				valueNode printOn: aStream indent: level + 1 + extra.
				last ifTrue: [aStream nextPut: $}]
					ifFalse: [aStream nextPut: $.;
							 crtab: level + 1]]].
	otherwise ifNotNil: [
		aStream crtab: level + 1; nextPutAll: ' otherwise: '.
		 extra := otherwise isComplex
					ifTrue: [
						aStream crtab: level + 2.
						1]
					ifFalse: [0].
		 otherwise printOn: aStream indent: level + 1 + extra]! !

!MessageNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 17:09'!
printWithClosureAnalysisCaseOn: aStream indent: level 
	"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"
	| braceNode otherwise extra |
	braceNode := arguments first.
	otherwise := arguments last.
	(arguments size = 1 or: [otherwise isJustCaseError]) ifTrue:
		[otherwise := nil].
	receiver
		printWithClosureAnalysisOn: aStream
		indent: level
		precedence: 3.
	aStream nextPutAll: ' caseOf: '.
	braceNode isVariableReference
		ifTrue: [braceNode printWithClosureAnalysisOn: aStream indent: level]
		ifFalse: 
			[aStream nextPutAll: '{'; crtab: level + 1.
			 braceNode casesForwardDo:
				[:keyNode :valueNode :last | 
				keyNode printWithClosureAnalysisOn: aStream indent: level + 1.
				aStream nextPutAll: ' -> '.
				valueNode isComplex
					ifTrue: 
						[aStream crtab: level + 2.
						extra := 1]
					ifFalse: [extra := 0].
				valueNode printWithClosureAnalysisOn: aStream indent: level + 1 + extra.
				last ifTrue: [aStream nextPut: $}]
					ifFalse: [aStream nextPut: $.;
							 crtab: level + 1]]].
	otherwise ifNotNil: [
		aStream crtab: level + 1; nextPutAll: ' otherwise: '.
		 extra := otherwise isComplex
					ifTrue: [
						aStream crtab: level + 2.
						1]
					ifFalse: [0].
		 otherwise printWithClosureAnalysisOn: aStream indent: level + 1 + extra]! !

!MessageNode methodsFor: 'code generation' stamp: 'jmv 3/2/2010 17:08'!
emitForValue: stack on: strm
	"For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly."
	special > 0
		ifTrue: [
			pc := 0.
			self perform: (MacroEmitters at: special) with: stack with: strm with: true]
		ifFalse: [
			receiver ifNotNil: [receiver emitForValue: stack on: strm].
			arguments do: [:argument | argument emitForValue: stack on: strm].
			pc := strm position + 1. "debug pc is first byte of the send, i.e. the next byte".
			selector
				emit: stack
				args: arguments size
				on: strm
				super: receiver == NodeSuper]! !

!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:08'!
emitCodeForValue: stack encoder: encoder
	"For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly."
	special > 0
		ifTrue: [
			pc := 0.
			self perform: (NewStyleMacroEmitters at: special) with: stack with: encoder with: true]
		ifFalse: [
			receiver ifNotNil: [receiver emitCodeForValue: stack encoder: encoder].
			arguments do: [:argument | argument emitCodeForValue: stack encoder: encoder].
			pc := encoder methodStreamPosition + 1. "debug pc is first byte of the send, i.e. the next byte".
			selector
				emitCode: stack
				args: arguments size
				encoder: encoder
				super: receiver == NodeSuper]! !

!MessageNode methodsFor: 'initialize-release' stamp: 'jmv 3/2/2010 16:12'!
receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder 
	"Compile."

	self receiver: rcvr
		arguments: args
		precedence: p.
	self noteSpecialSelector: aSelector.
	(self transform: encoder)
		ifTrue:  [
			selector ifNil: [
				selector := SelectorNode new 
								key: (MacroSelectors at: special)
								code: #macro]]
		ifFalse: [
			selector := encoder encodeSelector: aSelector.
			rcvr == NodeSuper ifTrue: [encoder noteSuper]].
	self pvtCheckForPvtSelector: encoder! !


!MethodContext methodsFor: 'nil' stamp: 'jmv 3/2/2010 17:09'!
cannotReturn: result
	closureOrNil ifNotNil: [
		^self cannotReturn: result to: sender].
	Debugger
		openContext: thisContext
		label: 'computation has been terminated'
		contents: nil! !


!MethodProperties methodsFor: 'properties' stamp: 'jmv 3/2/2010 16:12'!
at: aKey ifAbsent: aBlock
	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
	
	properties ifNil: [ ^ aBlock value ].
	^ properties at: aKey ifAbsent: aBlock! !

!MethodProperties methodsFor: 'properties' stamp: 'jmv 3/2/2010 16:13'!
removeKey: aKey ifAbsent: aBlock
	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
	
	| answer |
	properties ifNil: [ ^ aBlock value ].
	answer := properties removeKey: aKey ifAbsent: aBlock.
	properties isEmpty ifTrue: [ properties := nil ].
	^ answer! !


!Monitor methodsFor: 'private' stamp: 'jmv 3/2/2010 16:14'!
exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	| lock delay |
	queuesMutex 
		critical: [
			lock _ anOrderedCollection addLast: Semaphore new].
	self exit.
	anIntegerOrNil
		ifNil: [
			lock wait ]
		ifNotNil: [
			delay _ MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection.
			lock wait.
			delay unschedule ].
	self enter.! !


!Morph methodsFor: 'debug and other' stamp: 'jmv 3/2/2010 16:15'!
allStringsAfter: aSubmorph 
	"return an OrderedCollection of strings of text in my submorphs.  If aSubmorph is non-nil, begin with that container."

	| list string ok |
	list := OrderedCollection new.
	ok := aSubmorph isNil.
	self allMorphsDo: [ :sub | 
			ok
				ifFalse: [ok := sub == aSubmorph].	"and do this one too"
			ok
				ifTrue: [
					(string := sub userString) ifNotNil: [
						string isString 
							ifTrue: [list add: string] 
							ifFalse: [list addAll: string]]]].
	^list! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'jmv 3/2/2010 16:16'!
formerOwner: aMorphOrNil 
	aMorphOrNil 
		ifNil: [self removeProperty: #formerOwner]
		ifNotNil: [self setProperty: #formerOwner toValue: aMorphOrNil]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'jmv 3/2/2010 16:16'!
formerPosition: formerPosition 
	formerPosition 
		ifNil: [self removeProperty: #formerPosition]
		ifNotNil: [self setProperty: #formerPosition toValue: formerPosition]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'jmv 3/2/2010 17:10'!
rejectDropMorphEvent: evt
	"The receiver has been rejected, and must be put back somewhere.  There are three cases:
	(1)  It remembers its former owner and position, and goes right back there
	(2)  It remembers its former position only, in which case it was torn off from a parts bin, and the UI is that it floats back to its donor position and then vanishes.
	(3)  Neither former owner nor position is remembered, in which case it is whisked to the Trash"

	self formerOwner ifNotNil: [
		^ self slideBackToFormerSituation: evt].

	self formerPosition ifNotNil: [  "Position but no owner -- can just make it vanish"
		^ self vanishAfterSlidingTo: self formerPosition event: evt].
	
	self error: 'Should I delete this morph?'.
	self delete! !

!Morph methodsFor: 'e-toy support' stamp: 'jmv 3/2/2010 16:16'!
unlockOneSubpart
	| unlockables aMenu reply |
	unlockables _ self submorphs select:
		[:m | m isLocked].
	unlockables size <= 1 ifTrue: [^ self unlockContents].
	aMenu _ SelectionMenu labelList: (unlockables collect: [:m | m externalName]) selections: unlockables.
	reply _ aMenu startUpWithCaption: 'Who should be be unlocked?' translated.
	reply ifNil: [^ self].
	reply unlock! !

!Morph methodsFor: 'printing' stamp: 'jmv 3/2/2010 16:15'!
colorString: aColor 
	aColor ifNil: [^'nil'].
	Color colorNames 
		do: [:colorName | aColor = (Color perform: colorName) ifTrue: [^'Color ' , colorName]].
	^aColor storeString! !

!Morph methodsFor: 'structure' stamp: 'jmv 3/2/2010 16:10'!
world
	^owner ifNotNil: [owner world]! !


!ColorPickerMorph methodsFor: 'private' stamp: 'jmv 3/2/2010 15:54'!
modalBalloonHelpAtPoint: cursorPoint 
	self flag: #arNote.	"Throw this away. There needs to be another way."
	self submorphsDo: 
			[:m | 
			m wantsBalloon 
				ifTrue: [
					(m valueOfProperty: #balloon)
						ifNil: [ 
							(m containsPoint: cursorPoint) ifTrue: [m showBalloon: m balloonText]]
						ifNotNil: [(m containsPoint: cursorPoint) ifFalse: [m deleteBalloon]]]]! !


!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/2/2010 16:01'!
updateColor
	"update the recevier's fillStyle"

	textPane ifNil: [
		^ self].
	textPane borderColor: #inset! !


!HaloMorph methodsFor: 'drawing' stamp: 'jmv 3/2/2010 16:03'!
drawOn: aCanvas 
	"Draw this morph only if it has no target."

	target ifNil: [^super drawOn: aCanvas].
	Preferences showBoundsInHalo 
		ifTrue: [
			aCanvas 
				frameAndFillRectangle: self bounds
				fillColor: Color transparent
				borderWidth: 1
				borderColor: Color blue]! !

!HaloMorph methodsFor: 'events' stamp: 'jmv 3/2/2010 16:03'!
popUpFor: aMorph event: evt 
	"This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame."

	| hand anEvent |
	self flag: #workAround.	"We should really have some event/hand here..."
	anEvent := evt 
				ifNil: [ 
					hand := aMorph world activeHand.
					hand ifNil: [hand := aMorph world primaryHand]. 
					hand lastEvent transformedBy: (aMorph transformedFrom: nil)]
				ifNotNil: [ 
					hand := evt hand.
					evt].
	self target: aMorph.
	hand halo: self.
	hand world addMorphFront: self.
	positionOffset := anEvent position 
				- (aMorph point: aMorph position in: owner).
	self startStepping! !

!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 3/2/2010 16:02'!
containsPoint: aPoint 
	"This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner."

	^target
		ifNil: [super containsPoint: aPoint] 
		ifNotNil: [false]! !


!HandMorph methodsFor: 'cursor' stamp: 'jmv 3/2/2010 16:06'!
showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset 
	"Set the temporary cursor to the given Form.
	If the argument is nil, revert to the normal hardware cursor."

	self changed.
	temporaryCursorOffset 
		ifNotNil: [ bounds := bounds translateBy: temporaryCursorOffset negated ].
	cursorOrNil
		ifNil: [temporaryCursor := temporaryCursorOffset := nil]
		ifNotNil: [
			temporaryCursor := (Preferences biggerCursors and: [ cursorOrNil is: #Cursor ])
					ifTrue: [ cursorOrNil asBigCursor asCursorForm ]
					ifFalse: [ cursorOrNil asCursorForm ].
			temporaryCursorOffset := temporaryCursor offset - hotSpotOffset ].
	bounds := self cursorBounds.
	self
		userInitials: userInitials andPicture: self userPicture;
		layoutChanged;
		changed! !

!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/2/2010 16:04'!
drawOn: aCanvas 
	"Draw the hand itself (i.e., the cursor)."

	 aCanvas paintImage: (temporaryCursor ifNil: [NormalCursor]) at: bounds topLeft.
	self hasUserInformation 
		ifTrue: [
			aCanvas 
				drawString: userInitials
				at: self cursorBounds topRight + (0 @ 4)
				font: nil
				color: color.
			self userPicture ifNotNil: [ :userPic |
					aCanvas paintImage: userPic at: self cursorBounds topRight + (0 @ 24)]]! !

!HandMorph methodsFor: 'event handling' stamp: 'jmv 3/2/2010 17:05'!
processEvents
	"Process user input events from the local input devices."

	| evt evtBuf type hadAny |
	ActiveEvent ifNotNil: 
			["Meaning that we were invoked from within an event response.
		Make sure z-order is up to date"

			self mouseOverHandler processMouseOver: lastMouseEvent].
	hadAny := false.
	[(evtBuf := Sensor nextEvent) isNil] whileFalse: 
			[evt := nil.	"for unknown event types"
			type := evtBuf first.
			type = EventTypeMouse ifTrue: [evt := self generateMouseEvent: evtBuf].
			type = EventTypeKeyboard 
				ifTrue: [evt := self generateKeyboardEvent: evtBuf].
			"All other events are ignored"
			(evt isNil) ifTrue: [^self].
			evt isNil 
				ifFalse: 
					["Finally, handle it"

					self handleEvent: evt.
					hadAny := true.

					"For better user feedback, return immediately after a mouse event has been processed."
					evt isMouse ifTrue: [^self]]].
	"note: if we come here we didn't have any mouse events"
	mouseClickState 
		ifNotNil: [ 
			"No mouse events during this cycle. Make sure click states time out accordingly"
			mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
	hadAny 
		ifFalse: [
			"No pending events. Make sure z-order is up to date"
			"JMV
			Try to understand why this was ever needed.
			It is very expensive in slow hardware, for example in Cytec's STB.
			And in any case, why would this be needed if no event was processed?
			I believe that this is a bad solution for some problem.
			When we encounter it, we must think of a better one!!
			"
			"
			self mouseOverHandler processMouseOver: lastMouseEvent
			"
			]! !

!HandMorph methodsFor: 'focus handling' stamp: 'jmv 3/2/2010 16:05'!
keyboardFocusNext

	| firstCandidate candidate |
	firstCandidate _ keyboardFocus
		ifNil: [ World submorphs first ]
		ifNotNil: [ keyboardFocus nextMorph ].
	
	candidate _ firstCandidate.
	candidate handlesKeyboard ifFalse: [
		[
			candidate _ candidate nextMorph.
			candidate handlesKeyboard not and: [ candidate ~~ firstCandidate ] ] whileTrue ].

	candidate activateWindowAndSendTopToBack: true.
	self newKeyboardFocus: candidate! !

!HandMorph methodsFor: 'focus handling' stamp: 'jmv 3/2/2010 16:05'!
keyboardFocusPrevious

	| firstCandidate candidate |
	firstCandidate _ keyboardFocus
		ifNil: [ World ]
		ifNotNil: [ keyboardFocus previousMorph ].

	candidate _ firstCandidate.
	candidate handlesKeyboard ifFalse: [
		[
			candidate _ candidate previousMorph.
			candidate handlesKeyboard not and: [ candidate ~~ firstCandidate ] ] whileTrue ].

	candidate activateWindow.
	self newKeyboardFocus: candidate! !

!HandMorph methodsFor: 'focus handling' stamp: 'jmv 3/2/2010 16:06'!
newMouseFocus: aMorph event: event 
	aMorph ifNotNil: [ 
		targetOffset := event cursorPoint - aMorph position].
	^self newMouseFocus: aMorph! !


!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2010 17:08'!
deleteIfPopUp: evt
	"Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."

	stayUp ifFalse: [self delete].
	popUpOwner ifNotNil: [
		popUpOwner isSelected: false.
		popUpOwner deleteIfPopUp: evt].
	evt ifNotNil:[evt hand releaseMouseFocus: self].! !


!MinimalStringMorph methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:13'!
fontToUse
	| fontToUse |
	fontToUse := font ifNil: [StrikeFont default].
	^(emphasis isNil or: [emphasis = 0]) 
		ifTrue: [fontToUse]
		ifFalse: [fontToUse emphasized: emphasis]! !


!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'jmv 3/2/2010 16:18'!
layoutFrame: aLayoutFrame 

"lo tuve que sacar de los botoncitos de las ventanas... si no sirve mas, sacarlo!!"
self flag: #jmvRemove.

	aLayoutFrame
		ifNil: [self removeProperty: #layoutFrame]
		ifNotNil: [self setProperty: #layoutFrame toValue: aLayoutFrame]! !

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

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'jmv 3/2/2010 16:18'!
sortedPropertyNames
	"answer the receiver's property names in a sorted way"

	| props |
	props := WriteStream on: (Array new: 10).
	locked == true ifTrue: [props nextPut: #locked].
	visible == false ifTrue: [props nextPut: #visible].
	sticky == true ifTrue: [props nextPut: #sticky].
	balloonText ifNotNil: [props nextPut: #balloonText].
	eventHandler ifNotNil: [props nextPut: #eventHandler].
	self hasOtherProperties 
		ifTrue: [self otherProperties associationsDo: [:a | props nextPut: a key]].
	^props contents sort: [:s1 :s2 | s1 <= s2]! !

!MorphExtension methodsFor: 'other' stamp: 'jmv 3/2/2010 16:17'!
isDefault
	"Return true if the receiver is a default and can be omitted"
	locked == true
		ifTrue: [^ false].
	visible == false
		ifTrue: [^ false].
	sticky == true
		ifTrue: [^ false].
	balloonText
		ifNotNil: [^ false].
	eventHandler
		ifNotNil: [^ false].
	self hasOtherProperties
		ifTrue: [self otherProperties isEmpty
				ifFalse: [^ false]].
	^ true! !


!MorphicAlarm methodsFor: 'evaluating' stamp: 'jmv 3/2/2010 16:18'!
value: anArgument
	| nArgs |
	numArgs ifNil:[numArgs _ selector numArgs].
	nArgs _ arguments ifNil:[0] ifNotNil:[arguments size].
	nArgs = numArgs ifTrue:[
		"Ignore extra argument"
		^self value].
	^arguments
		ifNil: [ receiver perform: selector with: anArgument]
		ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: anArgument)]! !


!NetNameResolver class methodsFor: 'lookups' stamp: 'jmv 3/2/2010 16:18'!
addressForName: hostName timeout: secs
	"Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds."
	"NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30"
	"NetNameResolver addressForName: '100000jobs.de' timeout: 30"
	"NetNameResolver addressForName: '1.7.6.4' timeout: 30"
	"NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)"

	| deadline result |
	self initializeNetwork.
	"check if this is a valid numeric host address (e.g. 1.2.3.4)"
	result _ self addressFromString: hostName.
	result ifNotNil: [^result].

	"Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)"
	deadline _ Time millisecondClockValue + (secs * 1000).
	"Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction."
	self resolverMutex
		critical: [
			(self waitForResolverReadyUntil: deadline)
				ifTrue: [
					self primStartLookupOfName: hostName.
					(self waitForCompletionUntil: deadline)
						ifTrue: [result _ self primNameLookupResult]
						ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]]
				ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]].
	^result! !


!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:19'!
baseFont

	font ifNil: [ font _ StrikeFont default ].
	^font! !


!PasteUpMorph methodsFor: 'structure' stamp: 'jmv 3/2/2010 16:10'!
world
	worldState ifNil: [^super world].
	^self! !

!PasteUpMorph methodsFor: 'user interface' stamp: 'jmv 3/2/2010 16:20'!
modelWakeUp
	"I am the model of a SystemWindow, that has just been activated"

	| aWindow |
	owner ifNil: [^self].	"Not in Morphic world"
	(owner isKindOf: TransformMorph) ifTrue: [^self viewBox: self fullBounds].
	(aWindow := self containingWindow) ifNotNil: [
		self viewBox = aWindow panelRect 
			ifFalse: [self viewBox: aWindow panelRect]]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2010 16:20'!
install
	owner := nil.	"since we may have been inside another world previously"
	ActiveWorld := self.
	ActiveHand := self hands first.	"default"
	ActiveEvent := nil.
	submorphs do: [:ss | ss owner ifNil: [ss privateOwner: self]].
	"Transcript that was in outPointers and then got deleted."
	self viewBox: Display boundingBox.
	Sensor flushAllButDandDEvents.
	worldState handsDo: [:h | h initForEvents].
	self borderWidth: 0.	"default"
	SystemWindow noteTopWindowIn: self.
	self displayWorldSafely! !


!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 3/2/2010 16:20'!
getMenu: shiftPressed 
	"Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu |
	getMenuSelector ifNil: [^nil].
	menu := MenuMorph new defaultTarget: model.
	getMenuSelector numArgs = 1 
		ifTrue: [^model perform: getMenuSelector with: menu].
	getMenuSelector numArgs = 2 
		ifTrue: [
			^model 
				perform: getMenuSelector
				with: menu
				with: shiftPressed].
	^self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 3/2/2010 16:21'!
getModelState
	"Answer the result of sending the receiver's model the getStateSelector message."

	^ getStateSelector 
		ifNil: [false]
		ifNotNil: [model perform: getStateSelector]! !


!PluggableListMorph methodsFor: 'events' stamp: 'jmv 3/2/2010 16:21'!
doubleClick: event
	| index |
	doubleClickSelector ifNil: [^super doubleClick: event].
	index _ self rowAtLocation: event position.
	index = 0 ifTrue: [^super doubleClick: event].
	"selectedMorph ifNil: [self setSelectedMorph: aMorph]."
	^ self model perform: doubleClickSelector! !

!PluggableListMorph methodsFor: 'model access' stamp: 'jmv 3/2/2010 16:21'!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	getIndexSelector ifNil: [^0].
	^model perform: getIndexSelector! !

!PluggableListMorph methodsFor: 'model access' stamp: 'jmv 3/2/2010 16:21'!
modifierKeyPressed: aChar 
	| args |
	keystrokeActionSelector ifNil: [^nil].
	args := keystrokeActionSelector numArgs.
	args = 1 ifTrue: [^model perform: keystrokeActionSelector with: aChar].
	args = 2 
		ifTrue: [
			^model 
				perform: keystrokeActionSelector
				with: aChar
				with: self].
	^self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'! !


!PluggableTextMorph methodsFor: 'drawing' stamp: 'jmv 3/2/2010 17:12'!
drawOn: aCanvas 
	"Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame"

	| bw bc |
	super drawOn: aCanvas.
	bw _ Preferences focusIndicatorWidth.
	bc _ nil.
	self wantsFrameAdornments ifTrue: [
		((model is: #CodeHolder) and: [model refusesToAcceptCode])
			ifTrue: [  "Put up feedback showing that code cannot be submitted in this state"
				bc _ Color tan]
			ifFalse: [
				self hasEditingConflicts
					ifTrue: [
						bw _ 3.
						bc _ Color red ] 
					ifFalse: [
						self hasUnacceptedEdits
							ifTrue: [
								model wantsDiffFeedback
									ifTrue: [
										bw _ 4.
										bc _ Color green]
									ifFalse: [
										bc _ Color red]]
							ifFalse: [
								model wantsDiffFeedback
									ifTrue: [
										bc _ Color green]
									ifFalse: []]]]].
					
	textMorph hasKeyboardFocus ifTrue: [
		bc ifNil: [
			bc _ Preferences focusIndicatorColor ]]
	ifFalse: [
		bc ifNotNil: [
			bc _ bc alphaMixed: 0.4 with: Color white ]].
	bc ifNotNil: [
		aCanvas frameRectangle: self focusIndicatorRectangle width: bw color: bc ]! !

!PluggableTextMorph methodsFor: 'geometry' stamp: 'jmv 3/2/2010 17:12'!
resetExtent
	"Reset the extent while maintaining the current selection.  Needed when resizing while the editor is active (when inside the pane)."
	| tempSelection |
	textMorph ifNotNil: [
		"the current selection gets munged by resetting the extent, so store it"
		tempSelection _ self selectionInterval.
		
		"don't reset it if it's not active"
		tempSelection = (Interval from: 1 to: 0) 
						ifTrue: [retractableScrollBar
							ifTrue:[ ^ self]].
		self extent: self extent.
		self setSelection: tempSelection]! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'jmv 3/2/2010 16:21'!
getSelection
	"Answer the model's selection interval."

	getSelectionSelector ifNil: [^1 to: 0].	"null selection"
	^model perform: getSelectionSelector! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'jmv 3/2/2010 16:22'!
getText
	"Retrieve the current model text"

	| newText |
	getTextSelector ifNil: [^Text new].
	newText := model perform: getTextSelector.
	newText ifNil: [^Text new].
	^newText shallowCopy! !


!PolygonMorph methodsFor: 'smoothing' stamp: 'jmv 3/2/2010 16:22'!
computeNextToEndPoints
	| pointAfterFirst pointBeforeLast |
	pointAfterFirst := nil.
	self lineSegmentsDo: 
			[:p1 :p2 | 
			pointAfterFirst ifNil: [pointAfterFirst := p2 asIntegerPoint].
			pointBeforeLast := p1 asIntegerPoint].
	curveState at: 2 put: pointAfterFirst.
	curveState at: 3 put: pointBeforeLast! !

!PolygonMorph methodsFor: 'private' stamp: 'jmv 3/2/2010 16:23'!
curveBounds
	| curveBounds pointAfterFirst pointBeforeLast |
	smoothCurve 
		ifFalse: [
			^(Rectangle encompassing: vertices) expandBy: (borderWidth + 1) // 2].

	"Compute the bounds from actual curve traversal, with leeway for borderWidth.
	Also note the next-to-first and next-to-last points for arrow directions."
	curveState := nil.	"Force recomputation"
	curveBounds := vertices first corner: vertices last.
	pointAfterFirst := nil.
	self lineSegmentsDo: [ :p1 :p2 | 
			pointAfterFirst 
				ifNil: [ 
					pointAfterFirst := p2 asIntegerPoint.
					curveBounds := curveBounds encompass: p1 asIntegerPoint].
			curveBounds := curveBounds encompass: p2 asIntegerPoint.
			pointBeforeLast := p1 asIntegerPoint].
	curveState at: 2 put: pointAfterFirst.
	curveState at: 3 put: pointBeforeLast.
	^curveBounds expandBy: (borderWidth + 1) // 2! !


!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 17:12'!
defaultAction

	| delta savedArea textFrame barFrame outerFrame result range lastW w f h textWidth |
	f _ StrikeFont default.
	h _ f height * 3//2.
	textWidth _ (f widthOfString: progressTitle) + h.
	w _ 150 max: textWidth.
	barFrame _ Rectangle center: aPoint extent: w@h.
	textFrame _ 0@0 extent: w@h.
	textFrame _ textFrame align: textFrame bottomCenter
					with: barFrame topCenter + (0@2).
	outerFrame _ barFrame merge: textFrame.
	delta _ outerFrame amountToTranslateWithin: Display boundingBox.
	barFrame _ barFrame translateBy: delta.
	textFrame _ textFrame translateBy: delta.
	outerFrame _ outerFrame translateBy: delta.
	savedArea _ Form fromDisplay: outerFrame.
	Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2).
	Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2).
	progressTitle displayOn: Display at: textFrame topLeft + (w-textWidth+h//2@4).
	range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal].  "Avoid div by 0"
	lastW _ 0.
	result _ workBlock value:  "Supply the bar-update block for evaluation in the work block"
		[ :barVal |
		barVal 
			ifNotNil: [ currentVal _ barVal ]
			ifNil: [		
				currentVal _ currentVal + 1.
				currentVal >= maxVal
					ifTrue: [ currentVal _ minVal ]].
		w _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger.
		w < lastW ifTrue: [
			Display fillWhite: (barFrame insetBy: 2)].
		w ~= lastW ifTrue: [
			Display fillGray: (barFrame topLeft + (2@2) extent: w@16).
			lastW _ w]].
	savedArea displayOn: Display at: outerFrame topLeft.
	self resume: result! !


!PseudoClass methodsFor: 'class' stamp: 'jmv 3/2/2010 16:23'!
comment
	| rStr |
	rStr := self organization commentRemoteStr.
	^rStr
		ifNil: [ self name,' has not been commented in this file']
		ifNotNil: [ rStr string]! !

!PseudoClass methodsFor: 'removing' stamp: 'jmv 3/2/2010 16:24'!
removeAllUnmodified
	| stClass |
	self exists ifFalse:[^self].
	self removeUnmodifiedMethods: self selectors.
	stClass := self realClass.
	(self hasDefinition and:[stClass definition = self definition]) ifTrue:[definition := nil].
	(self hasComment and:[stClass comment asString = self commentString]) ifTrue:[ self classComment: nil].
	metaClass ifNotNil: [ metaClass removeAllUnmodified]! !

!PseudoClass methodsFor: 'testing' stamp: 'jmv 3/2/2010 16:24'!
hasChanges

	self sourceCode isEmpty ifFalse:[^true].
	self organization hasNoComment ifFalse:[^true].
	definition ifNotNil: [ ^true].
	metaClass ifNotNil: [ ^metaClass hasChanges].
	^false! !


!QueueSound methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:24'!
currentSound
	currentSound ifNil: [currentSound _ self nextSound].
	^ currentSound! !

!QueueSound methodsFor: 'sound generation' stamp: 'jmv 3/2/2010 17:13'!
doControl
	super doControl.
	self currentSound ifNotNil: [self currentSound doControl]! !

!QueueSound methodsFor: 'sound generation' stamp: 'jmv 3/2/2010 16:24'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a collection of sounds in sequence."

	| finalIndex i remaining count rate |
	self currentSound ifNil: [^ self].  "already done"
	self startTime > Time millisecondClockValue ifTrue: [^ self].
	rate _ self samplingRate.
	finalIndex _ (startIndex + n) - 1.
	i _ startIndex.
	[i <= finalIndex] whileTrue: [
		[
			self currentSound ifNil: [^ self].
			(remaining _ self currentSound samplesRemaining) <= 0]
				whileTrue: [self currentSound: self nextSound].
		count _ (finalIndex - i) + 1.
		remaining < count ifTrue: [count _ remaining].
		self currentSound mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
		i _ i + count]! !

!QueueSound methodsFor: 'sound generation' stamp: 'jmv 3/2/2010 17:13'!
reset
	super reset.
	self currentSound
		ifNotNil: [ self currentSound reset]
		ifNil: [ self currentSound: self nextSound]! !


!RandomEnvelope methodsFor: 'envelopeEditor compatibility' stamp: 'jmv 3/2/2010 16:25'!
points

	| env |
	points ifNil: [
		env _ self target envelopes first.
		points _ OrderedCollection new.
		points
			add: 0@(self delta * 5 + 0.5);
			add: (env points at: env loopStartIndex)x@(self highLimit -1 * 5 + 0.5);
			add: (env points at: env loopEndIndex)x@(self highLimit -1 * 5 + 0.5);
			add: (env points last)x@(self lowLimit -1 * 5 + 0.5).
		loopStartIndex _ 2.
		loopEndIndex _ 3.
	].
	^points! !


!SHParserST80 methodsFor: 'scan' stamp: 'jmv 3/2/2010 16:29'!
scanNext
	self scanWhitespace.
	currentTokenFirst := self currentChar.
	currentTokenFirst 
		ifNil: [" end of input "
			currentTokenFirst := $ .
			currentTokenSourcePosition := nil.
			currentToken := nil.
			^nil].
	currentTokenFirst isDigit ifTrue: [^self scanNumber].
	currentTokenFirst isLetter ifTrue: [^self scanIdentifier].
	^self scanBinary! !

!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 3/2/2010 17:13'!
initializeInstanceVariables
	instanceVariables := classOrMetaClass 
		ifNotNil: [classOrMetaClass allInstVarNames asArray]
		ifNil: [Set new]! !

!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/2/2010 16:26'!
parse: isAMethod 
	"Parse the receiver's text. If isAMethod is true
    then treat text as a method, if false as an
    expression with no message pattern"

	self initializeInstanceVariables.
	sourcePosition := 1.
	arguments := Dictionary new.
	temporaries := Dictionary new.
	blockDepth := bracketDepth := 0.
	ranges 
		ifNil: [ ranges := OrderedCollection new: 100]
		ifNotNil: [ ranges reset].
	errorBlock := [^false].
	[
		self scanNext.
		isAMethod 
			ifTrue: [
				self parseMessagePattern.
				self parsePragmaSequence].
		self parseMethodTemporaries.
		isAMethod ifTrue: [self parsePragmaSequence].
		self parseStatementList.
		currentToken ifNotNil: [self error]
	] ensure:[errorBlock := nil].
	^true! !

!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/2/2010 16:26'!
parseBinary 
	| binary type |
	self parseUnary.
	[self isBinary] 
		whileTrue: [
			binary := currentToken.
			type := #binary.
			(binary isEmpty or:[Symbol hasInterned: binary ifTrue: [:sym | ]])
				ifFalse:[
					type := (Symbol thatStartsCaseSensitive: binary skipping: nil)
						ifNil: [ #undefinedBinary]
						ifNotNil: [ #incompleteBinary]].	
			self scanPast: type. 	
			self parseTerm.
            	self parseUnary]
! !

!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/2/2010 16:27'!
parseKeyword 
    | keyword rangeIndices |
    self parseBinary.
	keyword := ''.
	rangeIndices := #().
	[
    		[self isKeyword]
        		whileTrue: [
				keyword := keyword, currentToken. 
				self rangeType: #keyword.
				"remember where this keyword token is in ranges"
				rangeIndices := rangeIndices copyWith: ranges size.
				self scanNext.
				self parseTerm.
				self parseBinary ]
	] ensure: [ | type |
		"do this in an ensure so that it happens even if the errorBlock evaluates before getting here"
		"patch up the keyword tokens, so that incomplete and undefined ones look different"
		(keyword isEmpty or: [ Symbol hasInterned: keyword ifTrue: [ :sym | ]])
			ifFalse:[
				type := (Symbol thatStartsCaseSensitive: keyword skipping: nil)
					ifNil: [ #undefinedKeyword]
					ifNotNil: [ #incompleteKeyword].
				rangeIndices do: [:i | (ranges at: i) type: type]]]! !

!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/2/2010 16:28'!
parseString
	| first c answer last |
	first := sourcePosition.
	answer := ''.
	
	[
		(c := self currentChar)
			ifNil: [
				self rangeType: #unfinishedString start: first - 1 end: source size.
				self error	": 'unfinished string'"].
		(c ~~ $' 	
			ifTrue: [answer := answer copyWith: c. true] 
			ifFalse: [false]
		) or: [
			self peekChar == $' 
				ifTrue: [
					sourcePosition := sourcePosition + 1.
					answer := answer copyWith: $'.
					true]
				ifFalse: [false]]
	] whileTrue: [sourcePosition := sourcePosition + 1].
	last := sourcePosition.
	self nextChar.
	self scanPast: #string start: first - 1 end: last.
	^answer! !

!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/2/2010 16:29'!
parseSymbolString
	| first c last |
	first := sourcePosition.
	self nextChar.
	[
		(c := self currentChar) 
			ifNil: [
				self rangeType: #unfinishedString start: first end: source size.
				self error	": 'unfinished string'"].
		c ~~ $' or: [
			self peekChar == $' 
				ifTrue: [sourcePosition := sourcePosition + 1.true] 
				ifFalse: [false]]
	] whileTrue: [sourcePosition := sourcePosition + 1].
	last := sourcePosition.
	self nextChar.
	self scanPast: #stringSymbol start: first - 1 end: last! !

!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/2/2010 16:29'!
parseUnary
	| unary type |
	
    [self isName]
        whileTrue: [
			unary := currentToken.
			type := #unary.
			(unary isEmpty or:[Symbol hasInterned: unary ifTrue: [:sym | ]])
				ifFalse:[
					type := (Symbol thatStartsCaseSensitive: unary skipping: nil)
						ifNil: [ #undefinedUnary]
						ifNotNil: [ #incompleteUnary]].
			self scanPast: type]
! !


!SHTextStyler methodsFor: 'styling' stamp: 'jmv 3/2/2010 17:14'!
styleInBackgroundProcess: aText

	self terminateBackgroundStylingProcess.
	stylingEnabled ifTrue: [
		text := aText copy.
		self monitor critical: [
			sem := Semaphore new. 
			[
				sem ifNotNil: [
					sem wait.
					view ifNotNil:[view stylerStyledInBackground: text]]
			] forkAt: Processor activePriority.

			backgroundProcess :=  [
				self privateStyle: text.
				sem signal] newProcess.
			backgroundProcess priority: Processor userBackgroundPriority.
			backgroundProcess resume
		] 
	]! !

!SHTextStyler methodsFor: 'private' stamp: 'jmv 3/2/2010 16:29'!
monitor
	monitor
		ifNil: [monitor := Monitor new].
	^monitor! !


!Scanner methodsFor: 'expression types' stamp: 'jmv 3/2/2010 17:14'!
scanAllTokenPositionsInto: aBlock
	"Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments."

	| lastMark |
	lastMark := 1.
	[currentComment ifNotNil:
		[currentComment do:
			[:cmnt| | idx |
			 idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark.
			 (idx > 0 and: [idx < mark]) ifTrue:
				[aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]].
		 currentComment := nil].
	mark ifNotNil:
		[(token == #- 
		  and: [(self typeTableAt: hereChar) = #xDigit]) ifTrue:
			[| savedMark |
			 savedMark := mark.
			 self scanToken.
			 token := token negated.
			 mark := savedMark].
		"Compensate for the fact that the parser uses two character lookahead.  Normally we must
		  remove the extra two chaacters.  But this mustn't happen for the last token at the end of stream."
		 aBlock
			value: mark
			value: (source atEnd
					ifTrue: [tokenType := #doIt. "to cause an immediate ^self" source position]
					ifFalse: [source position - 2])].
	 (tokenType = #rightParenthesis
	  or: [tokenType == #doIt]) ifTrue:
		[^self].
	tokenType = #leftParenthesis
		ifTrue: 
			[self scanToken; scanAllTokenPositionsInto: aBlock]
		ifFalse: 
			[(tokenType = #word or: [tokenType = #keyword or: [tokenType = #colon]])
				ifTrue: 
					[self scanLitWord.
					 token = #true ifTrue: [token := true].
					 token = #false ifTrue: [token := false].
					 token = #nil ifTrue: [token := nil]]
				ifFalse:
					[(token == #- 
					  and: [(self typeTableAt: hereChar) = #xDigit])
						ifTrue: 
							[self scanToken.
							 token := token negated]]].
		self scanToken.
	true] whileTrue! !


!Parser methodsFor: 'private' stamp: 'jmv 3/2/2010 17:11'!
addComment

	parseNode
		ifNotNil: [
			parseNode comment: currentComment.
			currentComment := nil]! !

!Parser methodsFor: 'error handling' stamp: 'jmv 3/2/2010 16:19'!
notify: string at: location
	requestor
		ifNil: [
			(encoder == self or: [encoder isNil]) ifTrue: [^ self fail  "failure setting up syntax error"].
				SyntaxErrorNotification
					inClass: encoder classEncoding
					category: category
					withCode: 
						(source contents
							copyReplaceFrom: location
							to: location - 1
							with: string , ' ->')
					doitFlag: doitFlag
					errorMessage: string
					location: location]
		ifNotNil: [
			requestor
					notify: string , ' ->'
					at: location
					in: source].
	^self fail! !

!Parser methodsFor: 'public access' stamp: 'jmv 3/2/2010 16:19'!
encoder
	encoder ifNil: [
		encoder := EncoderForV3PlusClosures new].
	^encoder! !

!Parser methodsFor: 'public access' stamp: 'jmv 3/2/2010 17:11'!
encoderClass: anEncoderClass
	encoder ifNotNil: [
		self error: 'encoder already set'].
	encoder := anEncoderClass new! !


!ScrollBar methodsFor: 'scroll timing' stamp: 'jmv 3/2/2010 16:29'!
waitForDelay1: delay1 delay2: delay2 
	"Return true if an appropriate delay has passed since the last scroll operation.
	The delay decreases exponentially from delay1 to delay2."

	| now scrollDelay |
	timeOfLastScroll ifNil: [self resetTimer].	"Only needed for old instances"
	now := Time millisecondClockValue.
	(scrollDelay := currentScrollDelay) isNil 
		ifTrue: [scrollDelay := delay1	"initial delay"].
	currentScrollDelay := scrollDelay * 9 // 10 max: delay2.	"decrease the delay"
	timeOfLastScroll := now.
	^true! !


!SelectionMorph methodsFor: 'halo commands' stamp: 'jmv 3/2/2010 16:30'!
doDup: evt fromHalo: halo handle: dupHandle

	selectedItems _ self duplicateMorphCollection: selectedItems.
	selectedItems do: [:m | self owner addMorph: m].
	dupDelta
		ifNil: [	"First duplicate operation -- note starting location"
				dupLoc _ self position.
				evt hand grabMorph: self.
				halo removeAllHandlesBut: dupHandle]
		ifNotNil: ["Subsequent duplicate does not grab, but only moves me and my morphs"
				dupLoc _ nil.
				self position: self position + dupDelta]! !

!SelectionMorph methodsFor: 'private' stamp: 'jmv 3/2/2010 16:30'!
setOtherSelection: otherOrNil 
	otherSelection := otherOrNil.
	otherOrNil 
		ifNil: [super borderColor: Color blue]
		ifNotNil: [
			itemsAlreadySelected := otherSelection selectedItems.
			super borderColor: Color green]! !


!SimpleEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 3/2/2010 16:30'!
forwardDelete: aKeyboardEvent
	"Delete forward over the next character.
	  Make Undo work on the whole type-in, not just the one char.
	wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered."

	| startIndex stopIndex |
	startIndex _ self markIndex.
	startIndex > string size ifTrue: [
		^ false].
	self hasSelection ifTrue: [
		"there was a selection"
		self zapSelectionWith: ''.
		^ false].
	"Null selection - do the delete forward"
	beginTypeInIndex	"no previous typing.  openTypeIn"
		ifNil: [self openTypeIn].
	stopIndex := startIndex.
	(aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ])
		ifTrue: [ stopIndex := (self nextWord: stopIndex) - 1 ].
	self selectFrom: startIndex to: stopIndex.
	self replaceSelectionWith: ''.
	self selectFrom: startIndex to: startIndex-1.
	^false! !


!CellStyleEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 3/2/2010 15:45'!
nextCellCharFor: keystroke after: toBeReplaced
	| line |
	line _ #(
		' 0'
		'.,?!!"1-()@/:_'
		'abc2ABC'
		'def3DEF'
		'ghi4GHI'
		'jkl5JKL'
		'mno6MNO'
		'pqrs7PQRS'
		'tuv8TUV'
		'wxyz9WXYZ'
	) at: keystroke digitValue + 1.

	toBeReplaced ifNil: [
		^line first ].
	^line after: toBeReplaced ifNone: [ line first ]! !


!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'jmv 3/2/2010 16:31'!
keyStroke: event 
	"Process potential command keys"

	| args aCharacter |
	(event commandKeyPressed and: [ self focusKeyboardFor: event ])
		ifTrue: [ ^ self ].
	(self scrollByKeyboard: event) ifTrue: [^self].
	aCharacter := event keyCharacter.
	keystrokeActionSelector ifNil: [^self arrowKey: aCharacter].
	(args := keystrokeActionSelector numArgs) = 1 
		ifTrue: [^model perform: keystrokeActionSelector with: aCharacter].
	args = 2 
		ifTrue: [
			^model 
				perform: keystrokeActionSelector
				with: aCharacter
				with: self].
	^self 
		error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! !


!SimpleServiceEntry methodsFor: 'printing' stamp: 'jmv 3/2/2010 17:15'!
printOn: aStream

	aStream nextPutAll: self class name; nextPutAll: ': ('.
	self provider
		ifNotNil: [ aStream nextPutAll: provider printString].
	aStream nextPutAll: ' --- '. 
	self selector
		ifNotNil: [ aStream nextPutAll: selector asString].
	aStream nextPut: $)

! !


!Socket class methodsFor: 'registry' stamp: 'jmv 3/2/2010 16:33'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry ifNil: [
		Registry := WeakRegistry new]! !


!SortedCollection methodsFor: 'private' stamp: 'jmv 3/2/2010 16:33'!
indexForInserting: newObject

	| index low high |
	low _ firstIndex.
	high _ lastIndex.
	sortBlock
		ifNil: [
			[index _ high + low // 2.  low > high]
				whileFalse: [
					((array at: index) <= newObject)
						ifTrue: [low _ index + 1]
						ifFalse: [high _ index - 1]]]
		ifNotNil: [
			[index _ high + low // 2.  low > high]
				whileFalse: [
					(sortBlock value: (array at: index) value: newObject)
						ifTrue: [low _ index + 1]
						ifFalse: [high _ index - 1]]].
	^low! !


!SpaceTallyItem methodsFor: 'printing' stamp: 'jmv 3/2/2010 16:34'!
printOn: aStream

	analyzedClassName
		ifNotNil: [ aStream nextPutAll: analyzedClassName asString]. 
	aStream nextPutAll: ' ('.
	codeSize
		ifNotNil: [ aStream nextPutAll: 'code size: ' ;  nextPutAll: codeSize asString]. 
	instanceCount
		ifNotNil: [ aStream nextPutAll: ' instance count: ' ;  nextPutAll: instanceCount asString]. 
	spaceForInstances
		ifNotNil: [ aStream nextPutAll: ' space for instances: ' ;  nextPutAll: spaceForInstances asString]. 
	aStream nextPut: $).
	! !


!StandardFileStream class methodsFor: 'file creation' stamp: 'jmv 3/2/2010 16:35'!
forceNewFileNamed: fileName 
	"Create a new file with the given name, and answer a stream opened 
	for writing on that file. If the file already exists, delete it without 
	asking before creating the new file."
	| dir localName fullName f |
	fullName _ self fullName: fileName.
	(self isAFileNamed: fullName)
		ifFalse: [
			f _ self new open: fullName forWrite: true.
			^ f
				ifNil: ["Failed to open the file"
					(FileDoesNotExistException fileName: fullName) signal]].
	dir _ FileDirectory forFileName: fullName.
	localName _ FileDirectory localNameFor: fullName.
	dir
		deleteFileNamed: localName
		ifAbsent: [(CannotDeleteFileException new
			messageText: 'Could not delete the old version of file ' , fullName) signal].
	f _ self new open: fullName forWrite: true.
	^ f
		ifNil: ["Failed to open the file"
			(FileDoesNotExistException fileName: fullName) signal]! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'jmv 3/2/2010 16:35'!
readOnlyFileNamed: fileName 
	"Open an existing file with the given name for reading."

	| fullName f |
	fullName _ self fullName: fileName.
	f _ self new open: fullName forWrite: false.
	^ f
		ifNil: ["File does not exist..."
			((FileDoesNotExistException fileName: fullName) readOnly: true) signal].

	"StandardFileStream readOnlyFileNamed: 'kjsd.txt' "! !

!StandardFileStream class methodsFor: 'registry' stamp: 'jmv 3/2/2010 16:35'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry
		ifNil: [ Registry := WeakRegistry new]! !


!StrikeFont methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:36'!
widthOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."

	| ascii |
	ascii _ characterToGlyphMap
		ifNil: [ aCharacter asciiValue ]
		ifNotNil: [ characterToGlyphMap at: aCharacter asciiValue + 1 ].
	(ascii >= minAscii and:[ascii <= maxAscii]) ifFalse: [ascii _ maxAscii + 1].
	^ (xTable at: ascii + 2) - (xTable at: ascii + 1) - self baseKern
! !

!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 3/2/2010 17:17'!
reset
	"Reset the cache of derivative emphasized fonts"
	
	derivativeFonts ifNotNil: [
		derivativeFonts withIndexDo: [ :f :i |
			(f notNil and: [ f isSynthetic ]) 
				ifTrue: [ derivativeFonts at: i put: nil ]]].
	"
	derivativeFonts _ Array new: 32.
	#('B' 'I' 'BI') doWithIndex:
		[:tag :index | 
		(style _ TextStyle named: self familyName) ifNotNil:
			[(font _ style fontArray
				detect: [:each | each name = (self name , tag)]
				ifNone: [nil]) ifNotNil: [derivativeFonts at: index put: font]]]
	"! !


!String methodsFor: 'converting' stamp: 'jmv 3/2/2010 16:36'!
correctAgainst: wordList continuedFrom: oldCollection
	"Like correctAgainst:.  Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList."

	^ wordList
		ifNil: [
			self correctAgainstEnumerator: nil continuedFrom: oldCollection ]
		ifNotNil: [
			self
				correctAgainstEnumerator: [ :action | wordList do: action without: nil]
				continuedFrom: oldCollection ]! !

!String methodsFor: 'converting' stamp: 'jmv 3/2/2010 16:37'!
correctAgainstDictionary: wordDict continuedFrom: oldCollection
	"Like correctAgainst:continuedFrom:.  Use when you want to correct against a dictionary."

	^ wordDict
		ifNil: [
			self correctAgainstEnumerator: nil continuedFrom: oldCollection ]
		ifNotNil: [
			self
				correctAgainstEnumerator: [ :action | wordDict keysDo: action ]
				continuedFrom: oldCollection ]! !

!String methodsFor: 'private' stamp: 'jmv 3/2/2010 16:38'!
correctAgainstEnumerator: wordBlock continuedFrom: oldCollection
	"The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it."

	| choices scoreMin results score maxChoices |
	scoreMin _ self size // 2 min: 3.
	maxChoices _ 10.
	choices _ oldCollection
		ifNil: [ SortedCollection sortBlock: [ :x :y | x value > y value ] ].
	wordBlock
		ifNil: [
			results _ OrderedCollection new.
			1 to: (maxChoices min: choices size) do: [ :i | results add: (choices at: i) key ] ]
		ifNotNil: [
			wordBlock value: [ :word |
				(score _ self alike: word) >= scoreMin ifTrue: [
					choices add: (Association key: word value: score).
						(choices size >= maxChoices) ifTrue: [ scoreMin _ (choices at: maxChoices) value] ] ].
			results _ choices ].
	^ results! !


!StringMorph methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:38'!
fontToUse
	| fontToUse |
	fontToUse := font ifNil: [StrikeFont default].
	^(emphasis isNil or: [emphasis = 0]) 
		ifTrue: [ fontToUse]
		ifFalse: [ fontToUse emphasized: emphasis]! !


!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:11'!
contentString: aString 
	aString 
		ifNil: [self removeProperty: #contentString]
		ifNotNil: [self setProperty: #contentString toValue: aString]! !

!MenuItemMorph methodsFor: 'copying' stamp: 'jmv 3/2/2010 17:07'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

	super veryDeepFixupWith: deepCopier.
	target _ deepCopier references at: target ifAbsent: [target].
	arguments ifNotNil: [
	arguments _ arguments collect: [:each |
		deepCopier references at: each ifAbsent: [each]]]! !

!MenuItemMorph methodsFor: 'events' stamp: 'jmv 3/2/2010 16:11'!
mouseLeaveDragging: evt 
	"The mouse left the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
	owner ifNil: [^self].
	evt hand mouseFocus == owner ifFalse: [^self].
	"If we have a submenu, make sure we've got some time to enter it before actually leaving the menu item"
	subMenu 
		ifNil: [owner selectItem: nil event: evt]
		ifNotNil: [
			self 
				addAlarm: #deselectTimeOut:
				with: evt
				after: 500]! !


!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 3/2/2010 16:39'!
saveAs
	"Put up the 'saveAs' prompt, obtain a name, and save the image  under that new name."

	| newName |
	newName _ self getFileNameFromUser.
	newName ifNil: [^ self].
	(SourceFiles at: 2) ifNotNil: [
		self closeSourceFiles; "so copying the changes file will always work"
			 saveChangesInFileNamed: (self fullNameForChangesNamed: newName)].
	self saveImageInFileNamed: (self fullNameForImageNamed: newName)! !


!SystemWindow methodsFor: 'panes' stamp: 'jmv 3/2/2010 17:17'!
paneColor: aColor
	paneColor _ aColor.
	aColor
		ifNotNil: [ self color: aColor veryMuchLighter ].
	self adoptPaneColor: aColor.! !


!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/2/2010 17:18'!
isReferencedWithinBlockExtent: anInterval 
	readingScopes ifNotNil: [
		readingScopes do:
			[:set "<Set of <Integer>>"|
			set do:
				[:location|
				 (anInterval rangeIncludes: location) ifTrue:
					[^true]]]].
	writingScopes ifNotNil: [
		writingScopes do:
			[:set "<Set of <Integer>>"|
			set do:
				[:location|
				 (anInterval rangeIncludes: location) ifTrue:
					[^true]]]].
	^false! !

!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/2/2010 17:19'!
referenceScopesAndIndicesDo: aBinaryBlock
	"Evaluate aBinaryBlock with all read or write scopes and locations.
	 This is used to copy the reference information into RemoteTempVectorNodes"
	readingScopes ifNotNil: [
		readingScopes keysAndValuesDo:
			[:scopeBlock "<BlockNode>" :set "<Set of <Integer>>"|
			set do: [:location| aBinaryBlock value: scopeBlock value: location]]].
	writingScopes ifNotNil: [
		writingScopes keysAndValuesDo:
			[:scopeBlock "<BlockNode>" :set "<Set of <Integer>>"|
			set do: [:location| aBinaryBlock value: scopeBlock value: location]]]! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:18'!
emitCodeForLoad: stack encoder: encoder
	remoteNode ifNotNil: [
		remoteNode emitCodeForLoadFor: self stack: stack encoder: encoder]! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:18'!
emitCodeForStore: stack encoder: encoder
	remoteNode ifNotNil: [
		^remoteNode emitCodeForStoreInto: self stack: stack encoder: encoder].
	encoder genStoreTemp: index! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:18'!
emitCodeForStorePop: stack encoder: encoder
	remoteNode ifNotNil: [
		^remoteNode emitCodeForStorePopInto: self stack: stack encoder: encoder].
	encoder genStorePopTemp: index.
	stack pop: 1! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:18'!
emitCodeForValue: stack encoder: encoder
	remoteNode ifNotNil: [
		^remoteNode emitCodeForValueOf: self stack: stack encoder: encoder].
	encoder genPushTemp: index.
	stack push: 1! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 16:39'!
sizeCodeForLoad: encoder
	^remoteNode
		ifNil: [0]
		ifNotNil: [remoteNode sizeCodeForLoadFor: self encoder: encoder]! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:19'!
sizeCodeForStore: encoder
	remoteNode ifNotNil: [
		^remoteNode sizeCodeForStoreInto: self encoder: encoder].
	self reserve: encoder.
	^encoder sizeStoreTemp: index! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:19'!
sizeCodeForStorePop: encoder
	remoteNode ifNotNil: [
		^remoteNode sizeCodeForStorePopInto: self encoder: encoder].
	self reserve: encoder.
	^encoder sizeStorePopTemp: index! !

!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/2/2010 17:20'!
sizeCodeForValue: encoder
	remoteNode ifNotNil: [
		^remoteNode sizeCodeForValueOf: self encoder: encoder].
	self reserve: encoder.
	^encoder sizePushTemp: index! !

!TempVariableNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 17:19'!
printDefinitionForClosureAnalysisOn: aStream 
	| refs |
	aStream
		nextPut: ${;
		nextPutAll: key.
	definingScope ifNotNil: [definingScope blockExtent ifNotNil: [:be| aStream nextPutAll: ' d@'; print: be first]].
	readingScopes ifNotNil: [
		refs := Set new.
		readingScopes do: [:elems| refs addAll: elems].
		refs asSortedCollection do: [:read| aStream nextPutAll: ' r@'; print: read]].
	writingScopes ifNotNil: [
		refs := Set new.
		writingScopes do: [:elems| refs addAll: elems].
		refs asSortedCollection do: [:write| aStream nextPutAll: ' w@'; print: write]].
	aStream nextPut: $}! !

!TempVariableNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 17:19'!
printWithClosureAnalysisOn: aStream indent: level 

	aStream nextPutAll: name.
	readingScopes ifNotNil: [
		(readingScopes inject: Set new into: [:them :reads| them addAll: reads. them]) asSortedCollection do:
			[:location|
			aStream space; nextPut: $r; nextPut: $@; print: location]].
	writingScopes ifNotNil: [
		(writingScopes inject: Set new into: [:them :writes| them addAll: writes. them]) asSortedCollection do:
			[:location|
			aStream space; nextPut: $w; nextPut: $@; print: location]]! !


!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/2/2010 16:25'!
addRemoteTemp: aTempVariableNode encoder: encoder
	remoteTemps ifNil: [
		remoteTemps := OrderedCollection new].
	remoteTemps addLast: aTempVariableNode.
	aTempVariableNode referenceScopesAndIndicesDo: [:scopeBlock "<BlockNode>" :location "<Integer>"|
		self addReadWithin: scopeBlock at: location].
	encoder supportsClosureOpcodes ifFalse: [
		encoder encodeLiteral: remoteTemps size.
		readNode := encoder encodeSelector: #at:.
		writeNode := encoder encodeSelector: #at:put:]! !

!RemoteTempVectorNode methodsFor: 'printing' stamp: 'jmv 3/2/2010 17:13'!
printDefinitionForClosureAnalysisOn: aStream 
	| refs |
	aStream
		nextPut: ${;
		nextPutAll: key.
	definingScope ifNotNil: [definingScope blockExtent ifNotNil: [:be| aStream nextPutAll: ' d@'; print: be first]].
	readingScopes ifNotNil: [
		refs := Set new.
		readingScopes do: [:elems| refs addAll: elems].
		refs asSortedCollection do: [:read| aStream nextPutAll: ' r@'; print: read]].
	remoteTemps
		do: [:rt| rt printDefinitionForClosureAnalysisOn: aStream]
		separatedBy: [aStream nextPut: $,; space].
	aStream nextPut: $}! !


!TestResource methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:40'!
description

	^description ifNil: [ '' ]! !

!TestResource methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:40'!
name

	^name ifNil: [ self printString]! !


!TestResource class methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:40'!
current

	current
		ifNil: [ current := self new].

	^current
			! !

!TestResource class methodsFor: 'Creation' stamp: 'jmv 3/2/2010 17:20'!
reset

	current ifNotNil: [
		[current tearDown] ensure: [
			current := nil]]
			! !


!TestResult methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:41'!
errors

	errors
		ifNil: [errors := OrderedCollection new].
	^errors
			! !

!TestResult methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:41'!
failures
	failures
		ifNil: [failures := Set new].
	^failures
			! !

!TestResult methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:41'!
passed

	passed
		ifNil: [passed := OrderedCollection new].

	^passed
			! !


!TestSuite methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:41'!
resources
	resources ifNil: [resources := self defaultResources].
	^resources
			! !

!TestSuite methodsFor: 'Accessing' stamp: 'jmv 3/2/2010 16:41'!
tests
	tests ifNil: [tests := OrderedCollection new].
	^tests
			! !


!TextEditor methodsFor: 'accessing' stamp: 'jmv 3/2/2010 17:20'!
replaceSelectionWith: aText
	"Remember the selection text in UndoSelection.
	 Deselect, and replace the selection text by aText.
	 Remember the resulting selectionInterval in UndoInterval and PriorInterval.
	 Set up undo to use UndoReplace."

	beginTypeInBlock ifNotNil: [^self zapSelectionWith: aText]. "called from old code"
	UndoSelection _ self selection.
	self zapSelectionWith: aText.
	self undoer: #undoReplace! !

!TextEditor methodsFor: 'attributes' stamp: 'jmv 3/2/2010 17:20'!
changeEmphasisOrAlignment
	| aList reply  code align menuList startIndex attribute |
	startIndex _ self startIndex.
	aList _ #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified).	
	align _ paragraph text alignmentAt: startIndex.
	code _ paragraph text emphasisAt: startIndex.
	menuList _ WriteStream on: Array new.
	menuList nextPut: (code isZero ifTrue:['<on>'] ifFalse:['<off>']), 'normal' translated.
	menuList nextPutAll: (#(bold italic underlined struckOut) collect:[:emph|
		(code anyMask: (TextEmphasis perform: emph) emphasisCode)
			ifTrue: [ '<on>', emph asString translated ]
			ifFalse: [ '<off>',emph asString translated ]]).
	((paragraph text attributesAt: startIndex)
		anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]]) 
			ifTrue: [ menuList nextPut:'<on>', 'narrow' translated ]
			ifFalse: [ menuList nextPut:'<off>', 'narrow' translated ].
	menuList nextPutAll: (#(leftFlush centered rightFlush justified) collectWithIndex: [ :type :i |
		align = (i-1)
			ifTrue: [ '<on>',type asString translated ]
			ifFalse: [ '<off>',type asString translated ]]).
	aList _ #(normal bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
	reply _ (SelectionMenu labelList: menuList contents lines: #(1 6) selections: aList) startUpWithoutKeyboard.
	reply ifNotNil: [
		(#(leftFlush centered rightFlush justified) includes: reply)
			ifTrue: [
				attribute _TextAlignment perform: reply]
			ifFalse: [
				attribute _ TextEmphasis perform: reply].
		self applyAttribute:  attribute].
	^ true! !


!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 3/2/2010 16:32'!
debug: aCompiledMethod receiver: anObject in: evalContext

	| selector guineaPig debugger context |
	selector _ evalContext ifNil: [#DoIt] ifNotNil: [#DoItIn:].
	anObject class addSelectorSilently: selector withMethod: aCompiledMethod.
	guineaPig _ evalContext
		ifNil: [[anObject DoIt] newProcess]
		ifNotNil: [[anObject DoItIn: evalContext] newProcess].
	context _ guineaPig suspendedContext.
	debugger _ Debugger new
		process: guineaPig
		controller: nil
		context: context.
	debugger openFullNoSuspendLabel: 'Debug it'.
	[debugger interruptedContext method == aCompiledMethod]
		whileFalse: [debugger send].
	anObject class basicRemoveSelector: selector! !

!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 3/2/2010 17:16'!
debugIt

	| method receiver context |
	(model respondsTo: #doItReceiver) 
		ifTrue: [
			FakeClassPool adopt: model selectedClass.
			receiver _ model doItReceiver.
			context _ model doItContext]
		ifFalse: [
			receiver _ context _ nil].
	self lineSelectAndEmptyCheck: [^self].
	method _ self compileSelectionFor: receiver in: context.
	method ifNotNil: [
		self debug: method receiver: receiver in: context].
	FakeClassPool adopt: nil! !

!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 3/2/2010 16:31'!
browseIt
	"Launch a browser for the current selection, if appropriate"

	| aSymbol anEntry brow |

	Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt].

	self lineSelectAndEmptyCheck: [^ self].
	(aSymbol _ self selectedSymbol) ifNil: [^ morph flash].

	aSymbol first isUppercase
		ifTrue:
			[anEntry _ (Smalltalk
				at: aSymbol
				ifAbsent:
					[ Smalltalk browseAllImplementorsOf: aSymbol.
					^ nil]).
			anEntry ifNil: [^ morph flash].
			(anEntry isKindOf: Class)
				ifFalse:	[anEntry _ anEntry class].
			brow _ Preferences browseToolClass new.
			brow setClass: anEntry selector: nil.
			brow class
				openBrowserView: (brow openEditString: nil)
				label: 'System Browser']
		ifFalse:
			[Smalltalk browseAllImplementorsOf: aSymbol]! !

!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 3/2/2010 16:31'!
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) ifNil: [^ morph flash].

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

!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 3/2/2010 17:16'!
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)
					ifNotNil: [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 17: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)
		ifNotNil: [
			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...''."']
		ifNil: [ 
			"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! !

!SmalltalkEditor methodsFor: 'private' stamp: 'jmv 3/2/2010 17:16'!
explainDelimitor: string
	"Is string enclosed in delimitors?"

	| str |
	(string at: 1) isLetter ifTrue: [^nil].  "only special chars"
	(string first = string last) ifTrue:
			[^ self explainChar: (String with: string first)]
		ifFalse:
			[(string first = $( and: [string last = $)]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $[ and: [string last = $]]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = ${ and: [string last = $}]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $< and: [string last = $>]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $# and: [string last = $)]) ifTrue:
				[^'"An instance of class Array.  The Numbers, Characters, or Symbols between the parenthesis are the elements of the Array."'].
			string first = $# ifTrue:
				[^'"An instance of class Symbol."'].
			(string first = $$ and: [string size = 2]) ifTrue:
				[^'"An instance of class Character.  This one is the character ', (String with: string last), '."'].
			(string first = $:) ifTrue:
				[str := string allButFirst.
				(self explainTemp: str) ifNotNil: [
					^'"An argument to this block will be bound to the temporary variable ',
						str, '."']]].
	^ nil! !


!TextMorph methodsFor: 'event handling' stamp: 'jmv 3/2/2010 16:42'!
keyboardFocusChange: aBoolean 
	"rr 3/21/2004 22:55 : removed the #ifFalse: branch, 
	which was responsible of the deselection of text when the 
	paragraph lost focus. This way selection works in a more standard 
	way, and this permits the menu keyboard control to be really effective"
	
	paragraph ifNotNil: [paragraph focused: aBoolean].
	aBoolean ifTrue: [
		"A hand is wanting to send us characters..."
		editor ifNil: [ self editor	"Forces install"]].
	self changed! !

!TextMorph methodsFor: 'geometry' stamp: 'jmv 3/2/2010 16:42'!
privateMoveBy: delta 
	super privateMoveBy: delta.
	editor 
		ifNil: [ paragraph ifNotNil: [paragraph moveBy: delta]]
		ifNotNil: [ 
			"When moving text with an active editor, save and restore all state."
			paragraph moveBy: delta.
			self installEditorToReplace: editor]! !


!TraslucentImageLW methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 17:21'!
drawOn: aCanvas 

	self formToDraw ifNotNil: [ :f |
		aCanvas image: f at: bounds topLeft sourceRect: f boundingBox rule: 31 alpha: 0.7 ]! !


!Utilities class methodsFor: 'tailoring system' stamp: 'jmv 3/2/2010 17:21'!
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)) ifNotNil: [
				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']]! !


!VersionsBrowser methodsFor: 'init & update' stamp: 'jmv 3/2/2010 16:43'!
scanVersionsOf: method class: class meta: meta category: category selector: selector
	| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp |
	selectorOfMethod _ selector.
	currentCompiledMethod _ method.
	classOfMethod _ meta ifTrue: [class class] ifFalse: [class].
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	self addedChangeRecord ifNotNil: [ :change |
		self addItem: change text: ('{1} (in {2})' translated format: { change stamp. change fileName }) ].
	listIndex _ 0.
	position _ method filePosition.
	sourceFilesCopy _ SourceFiles collect:
		[:x | x ifNotNil: [ x readOnlyCopy]].
	method fileIndex = 0 ifTrue: [^ nil].
	file _ sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].

		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens _ Smalltalk actualScannerClass new scanTokens: preamble]
			ifFalse: [tokens _ Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size-2.
						prevPos _ tokens last.
						prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]
				ifFalse: ["Old format gives no stamp; prior pointer in two parts"
						prevPos _ tokens at: tokens size-2.
						prevFileIndex _ tokens last].
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size]].
 		self addItem:
				(ChangeRecord new file: file position: position type: #method
						class: class name category: category meta: meta stamp: stamp)
			text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector.
		position _ prevPos.
		prevPos notNil ifTrue:
			[file _ sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections _ Array new: list size withAll: false! !


!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'jmv 3/2/2010 15:47'!
scanVersionsOf: class 
	"Scan for all past versions of the class comment of the given class"

	| oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex |

	classOfMethod _ class.
	oldCommentRemoteStr _ class  organization commentRemoteStr.
	currentCompiledMethod _ oldCommentRemoteStr.
	selectorOfMethod _ #Comment.
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer].

	sourceFilesCopy _ SourceFiles collect:
		[:x | x ifNotNil: [x readOnlyCopy]].
	position _ oldCommentRemoteStr position.
	file _ sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  " Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].

		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'commentStamp:' startingAt: 1) > 0
			ifTrue: [tokens _ Smalltalk actualScannerClass new scanTokens: preamble.
				(tokens at: tokens size-3) = #commentStamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size-2.
						prevPos _ tokens last.
						prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]]
			ifFalse: ["The stamp get lost, maybe after a condenseChanges"
					stamp _ '<historical>'].
 		self addItem:
				(ChangeRecord new file: file position: position type: #classComment
						class: class name category: nil meta: class stamp: stamp)
			text: stamp , ' ' , class name , ' class comment'. 
		prevPos = 0 ifTrue:[prevPos _ nil].
		position _ prevPos.
		prevPos notNil 
					ifTrue:[file _ sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections _ Array new: list size withAll: false! !


!WeakArray class methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:43'!
addWeakDependent: anObject
	self isFinalizationSupported ifFalse: [ ^self ].
	FinalizationLock critical: [
		| finished index weakDependent |
		finished := false.
		index := 0.
		[index := index + 1.
		finished not and:[index <= FinalizationDependents size]] whileTrue:[
			weakDependent := FinalizationDependents at: index.
			weakDependent ifNil:[
				FinalizationDependents at: index put: anObject.
				finished := true.
			].
		].
		finished ifFalse:[
			"Grow linearly"
			FinalizationDependents := FinalizationDependents, (WeakArray new: 10).
			FinalizationDependents at: index put: anObject.
		].
	] ifError:[:msg :rcvr| rcvr error: msg].! !


!WeakKeyAssociation methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:43'!
key
	^key ifNotNil: [ key at: 1]! !


!WeakKeyDictionary methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:43'!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a new
	entry for key and set is value to anObject. Answer anObject."
	| index element |
	key ifNil: [ ^anObject].
	index _ self findElementOrNil: key.
	element _ array at: index.
	element
		ifNil: [self atNewIndex: index put: (WeakKeyAssociation key: key value: anObject)]
		ifNotNil: [element value: anObject].
	^ anObject! !


!WeakMessageSend methodsFor: 'evaluating' stamp: 'jmv 3/2/2010 16:44'!
value
	^ arguments
		ifNil: [
			self withEnsuredReceiverDo: [ :r | r perform: selector ]]
		ifNotNil: [
			self withEnsuredReceiverAndArgumentsDo: [ :r :a |
				r
					perform: selector
					withArguments: a ]]! !


!WeakRegistry methodsFor: 'finalization' stamp: 'jmv 3/2/2010 16:45'!
finalizeValues
	"Some of our elements may have gone away. Look for those and activate the associated executors."
	| finiObjects |
	finiObjects _ nil.
	"First collect the objects."
	self protected:[
		valueDictionary associationsDo:[:assoc|
			assoc key ifNil: [
				finiObjects 
					ifNil: [ finiObjects := OrderedCollection with: assoc value]
					ifNotNil: [ finiObjects add: assoc value]]
		].
		finiObjects ifNotNil: [ valueDictionary finalizeValues: finiObjects asArray].
	].
	"Then do the finalization"
	finiObjects ifNotNil: [
		finiObjects do:[:each| each finalize]]! !

!WeakRegistry methodsFor: 'private' stamp: 'jmv 3/2/2010 16:45'!
protected: aBlock
	"Execute aBlock protected by the accessLock"
	^accessLock
		ifNil: [ aBlock value]
		ifNotNil: [ accessLock critical: aBlock ifError:[:msg :rcvr| rcvr error: msg]]! !

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


!Workspace methodsFor: 'binding' stamp: 'jmv 3/2/2010 16:46'!
bindingOf: aString
	bindings
		ifNil: [ bindings _ Dictionary new].
	(bindings includesKey: aString)
		ifFalse: [bindings at: aString put: nil].
	^bindings associationAt: aString! !

!Workspace methodsFor: 'as yet unclassified' stamp: 'jmv 3/2/2010 17:22'!
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 ifNotNil: [^textMorph saveContentsInFile]! !


!WorldState methodsFor: 'alarms' stamp: 'jmv 3/2/2010 16:47'!
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 ifNotNil: [self alarms remove: alarm]! !

!WorldState methodsFor: 'canvas' stamp: 'jmv 3/2/2010 16:46'!
assuredCanvas
	(canvas isNil or: [(canvas extent ~= viewBox extent) or: [canvas form depth ~= Display depth]])
		ifTrue: [
			"allocate a new offscreen canvas the size of the window"
			self canvas: (Display defaultCanvasClass extent: viewBox extent)].
	^ self canvas! !

!WorldState methodsFor: 'canvas' stamp: 'jmv 3/2/2010 16:46'!
canvas: x 
	canvas := x.
	damageRecorder
		ifNil: [ damageRecorder := DamageRecorder new]
		ifNotNil: [ damageRecorder doFullRepaint]! !

