'From Cuis 2.0 of 24 February 2010 [latest update: #440] on 1 March 2010 at 1:58:44 pm'!

!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 3/1/2010 13:11'!
cannotInterpret: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector.  Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose."

"If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent."

	(self class lookupSelector: aMessage selector) ifNotNil: [
		"Simulated lookup succeeded -- resend the message."
		^ aMessage sentTo: self].

	"Could not recover by simulated lookup -- it's an error"
	Error signal: 'MethodDictionary fault'.

	"Try again in case an error handler fixed things"
	^ aMessage sentTo: self! !


!Object methodsFor: 'private' stamp: 'jmv 3/1/2010 11:50'!
primitiveError: aString 
	"This method is called when the error handling results in a recursion in 
	calling on error: or halt or halt:."

	| context |
	(String
		streamContents: 
			[:s |
			s nextPutAll: '***System error handling failed***'.
			s cr; nextPutAll: aString.
			context _ thisContext sender sender.
			20 timesRepeat: [context ifNotNil: [s cr; print: (context _ context sender)]].
			s cr; nextPutAll: '-------------------------------'.
			s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
			s cr; nextPutAll: 'Type any other character to restart.'])
		displayAt: 0 @ 0.
	[Sensor keyboardPressed] whileFalse.
	Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator].
	World install "init hands and redisplay"! !


!Behavior methodsFor: 'accessing' stamp: 'jmv 2/28/2010 22:50'!
methodDict
	methodDict ifNil: [self recoverFromMDFaultWithTrace].
	^ methodDict! !

!Behavior methodsFor: 'accessing class hierarchy' stamp: 'jmv 2/28/2010 22:48'!
allSuperclasses
	"Answer an OrderedCollection of the receiver's and the receiver's  
	ancestor's superclasses. The first element is the receiver's immediate  
	superclass, followed by its superclass; the last element is Object."
	| temp |
	^ superclass
		ifNil: [ OrderedCollection new]
		ifNotNil: [temp _ superclass allSuperclasses.
			temp addFirst: superclass.
			temp]! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'jmv 2/28/2010 22:47'!
addSelectorSilently: selector withMethod: compiledMethod 
	"Add the message selector with the corresponding compiled method to the 
	receiver's method dictionary.
	Do this without sending system change notifications"

	| oldMethodOrNil |
	oldMethodOrNil _ self lookupSelector: selector.
	self methodDict at: selector put: compiledMethod.

	"Now flush Squeak's method cache, either by selector or by method"
	oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache].
	selector flushCache.! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'jmv 2/28/2010 22:51'!
selectorAtMethod: method setClass: classResultBlock 
	"Answer both the message selector associated with the compiled method 
	and the class in which that selector is defined."

	| sel |
	sel _ self methodDict keyAtIdentityValue: method
				ifAbsent: [ | sel2 |
					superclass
						ifNil: [
							classResultBlock value: self.
							^method defaultSelector].
					sel2 _ superclass selectorAtMethod: method setClass: classResultBlock.
					"Set class to be self, rather than that returned from superclass. "
					sel2 == method defaultSelector ifTrue: [ classResultBlock value: self ].
					^sel2].
	classResultBlock value: self.
	^sel! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 2/28/2010 22:47'!
allInstVarNames
	"Answer an Array of the names of the receiver's instance variables. The 
	Array ordering is the order in which the variables are stored and 
	accessed by the interpreter."

	| vars |
	superclass
		ifNil: [vars _ self instVarNames copy]	"Guarantee a copy is answered."
		ifNotNil: [vars _ superclass allInstVarNames , self instVarNames].
	^vars! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 2/28/2010 22:50'!
instVarNames
	"Answer an Array of the instance variable names. Behaviors must make 
	up fake local instance variable names because Behaviors have instance 
	variables for the purpose of compiling methods, but these are not named 
	instance variables."

	| mySize superSize |
	mySize _ self instSize.
	superSize _ 
		superclass
			ifNil: [0]
			ifNotNil: [superclass instSize].
	mySize = superSize ifTrue: [^#()].	
	^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'jmv 2/28/2010 22:49'!
canUnderstand: selector 
	"Answer whether the receiver can respond to the message whose selector 
	is the argument. The selector can be in the method dictionary of the 
	receiver's class or any of its superclasses."

	(self includesSelector: selector) ifTrue: [^true].
	superclass ifNil: [^false].
	^superclass canUnderstand: selector! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'jmv 2/28/2010 22:52'!
whichClassIncludesSelector: aSymbol 
	"Answer the class on the receiver's superclass chain where the 
	argument, aSymbol (a message selector), will be found. Answer nil if none found."
	"Rectangle whichClassIncludesSelector: #inspect."
	(self includesSelector: aSymbol)
		ifTrue: [^ self].
	superclass
		ifNil: [^ nil].
	^ superclass whichClassIncludesSelector: aSymbol! !

!Behavior methodsFor: 'enumerating' stamp: 'jmv 2/28/2010 22:49'!
allSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."

	superclass ifNotNil: [
		aBlock value: superclass.
		superclass allSuperclassesDo: aBlock]! !

!Behavior methodsFor: 'enumerating' stamp: 'jmv 2/28/2010 22:53'!
withAllSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."
	aBlock value: self.
	superclass
		ifNotNil: [superclass withAllSuperclassesDo: aBlock]! !


!BitBlt methodsFor: 'accessing' stamp: 'jmv 2/28/2010 22:54'!
fillColor: aColorOrPattern 
	"The destForm will be filled with this color or pattern of colors.  May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form.  6/18/96 tk"

	aColorOrPattern ifNil: [halftoneForm _ nil. ^ self].
	destForm ifNil: [self error: 'Must set destForm first'].
	halftoneForm _ destForm bitPatternFor: aColorOrPattern ! !

!BitBlt methodsFor: 'copying' stamp: 'jmv 2/28/2010 22:53'!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule
	"Specify a Color to fill, not a Form. 6/18/96 tk"  
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	srcForm
		ifNotNil: [colorMap := srcForm colormapIfNeededFor: destForm].
	^ self copyBits! !

!BitBlt methodsFor: 'line drawing' stamp: 'jmv 2/28/2010 22:54'!
drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint
	"Draw a line whose end points are startPoint and stopPoint.
	The line is formed by repeatedly calling copyBits at every
	point along the line.  If drawFirstPoint is false, then omit
	the first point so as not to overstrike at line junctions."
	| offset point1 point2 forwards |
	"Always draw down, or at least left-to-right"
	forwards _ (startPoint y = stopPoint y and: [startPoint x < stopPoint x])
				or: [startPoint y < stopPoint y].
	forwards
		ifTrue: [point1 _ startPoint. point2 _ stopPoint]
		ifFalse: [point1 _ stopPoint. point2 _ startPoint].
	sourceForm
		ifNil: [
			destX := point1 x.
			destY := point1 y]
		ifNotNil: [
			width := sourceForm width.
			height := sourceForm height.
			offset := sourceForm offset.
			destX := (point1 x + offset x) rounded.
			destY := (point1 y + offset y) rounded].

	"Note that if not forwards, then the first point is the last and vice versa.
	We agree to always paint stopPoint, and to optionally paint startPoint."
	(drawFirstPoint or: [forwards == false  "ie this is stopPoint"])
		ifTrue: [self copyBits].
	self drawLoopX: (point2 x - point1 x) rounded 
				  Y: (point2 y - point1 y) rounded.
	(drawFirstPoint or: [forwards  "ie this is stopPoint"])
		ifTrue: [self copyBits].
! !

!BitBlt methodsFor: 'private' stamp: 'jmv 2/28/2010 22:54'!
setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect

	| aPoint |
	destForm _ df.
	sourceForm _ sf.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ cr.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourceOrigin x.
	sourceY _ sourceOrigin y.
	width _ extent x.
	height _ extent y.
	aPoint _ clipRect origin.
	clipX _ aPoint x.
	clipY _ aPoint y.
	aPoint _ clipRect corner.
	clipWidth _ aPoint x - clipX.
	clipHeight _ aPoint y - clipY.
	sourceForm ifNotNil: [
		colorMap _ sourceForm colormapIfNeededFor: destForm]! !


!ChangeSet methodsFor: 'accessing' stamp: 'jmv 2/28/2010 23:04'!
name
	"The name of this changeSet.
	 2/7/96 sw: If name is nil, we've got garbage.  Help to identify."

	^ name
		ifNil: ['<no name -- garbage?>']
		ifNotNil: [name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 2/28/2010 23:03'!
assurePostscriptExists
	"Make sure there is a StringHolder holding the postscript.  "

	"NOTE: FileIn recognizes the postscript by the line with Postscript: on it"
	postscript
		ifNil: [postscript _ CodeHolder new contents: '"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 2/28/2010 23:04'!
postscriptString
	"Answer the string representing the postscript.  "

	^ postscript
		ifNil: [postscript]
		ifNotNil: [postscript contents asString]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 2/28/2010 23:04'!
preambleString
	"Answer the string representing the preamble"

	^ preamble
		ifNil: [preamble]
		ifNotNil: [preamble contents asString]! !


!CharacterScanner methodsFor: 'scanning' stamp: 'jmv 2/28/2010 23:11'!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
	"Primitive. This is the inner loop of text display--but see 
	scanCharactersFrom: to:rightX: which would get the string, 
	stopConditions and displaying from the instance. March through source 
	String from startIndex to stopIndex. If any character is flagged with a 
	non-nil entry in stops, then return the corresponding value. Determine 
	width of each character from xTable, indexed by map. 
	If dextX would exceed rightX, then return stops at: 258. 
	Advance destX by the width of the character. If stopIndex has been
	reached, then return stops at: 257. Optional. 
	See Object documentation whatIsAPrimitive."
	| ascii nextDestX char |
	<primitive: 103>
	lastIndex _ startIndex.
	[lastIndex <= stopIndex]
		whileTrue: 
			[char _ (sourceString at: lastIndex).
			ascii _ char asciiValue + 1.
			(stops at: ascii) ifNotNil: [^stops at: ascii].
			"Note: The following is querying the font about the width
			since the primitive may have failed due to a non-trivial
			mapping of characters to glyphs or a non-existing xTable."
			nextDestX _ destX + (font widthOf: char).
			nextDestX > rightX ifTrue: [^stops at: CharacterScanner crossedXCode].
			destX _ nextDestX + kernDelta.
			lastIndex _ lastIndex + 1].
	lastIndex _ stopIndex.
	^stops at: CharacterScanner endOfRunCode! !


!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'jmv 2/28/2010 23:09'!
crossedX
	"Text display has wrapping. The scanner just found a character past the x 
	location of the cursor. We know that the cursor is pointing at a character 
	or before one."

	| currentX |
	characterIndex ifNotNil: [
		"If the last character of the last line is a space,
		and it crosses the right margin, then locating
		the character block after it is impossible without this hack."
		characterIndex > text size ifTrue: [
			lastIndex _ characterIndex.
			characterPoint _ leftMargin @ (destY + line lineHeight).
			^true]].
	characterPoint x <= (destX + (lastCharacterExtent x // 2))
		ifTrue:	[lastCharacter _ (text at: lastIndex).
				characterPoint _ destX @ destY.
				^true].
	lastIndex >= line last 
		ifTrue:	[lastCharacter _ (text at: line last).
				characterPoint _ destX @ destY.
				^true].

	"Pointing past middle of a character, return the next character."
	lastIndex _ lastIndex + 1.
	lastCharacter _ text at: lastIndex.
	currentX _ destX + lastCharacterExtent x + kern.
	self lastCharacterExtentSetX: (font widthOf: lastCharacter).
	characterPoint _ currentX @ destY.
	lastCharacter = Character space ifFalse: [^ true].

	"Yukky if next character is space or tab."
	alignment = CharacterScanner justifiedCode ifTrue:
		[self lastCharacterExtentSetX:
			(lastCharacterExtent x + 	(line justifiedPadFor: (spaceCount + 1))).
		^ true].

	^ true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'jmv 3/1/2010 11:01'!
endOfRun
	"Before arriving at the cursor location, the selection has encountered an 
	end of run. Answer false if the selection continues, true otherwise. Set 
	up indexes for building the appropriate CharacterBlock."

	| runLength lineStop |
	((characterIndex ~~ nil and:
		[runStopIndex < characterIndex and: [runStopIndex < text size]])
			or:	[characterIndex == nil and: [lastIndex < line last]])
		ifTrue:	["We're really at the end of a real run."
				runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
				lineStop _ characterIndex		"scanning for index"
					ifNil: [ line last ].			"scanning for point"
				(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
					ifTrue: 	[runStopIndex _ lineStop].
				self setStopConditions.
				^false].

	lastCharacter _ text at: lastIndex.
	characterPoint _ destX @ destY.
	((lastCharacter = Character space and: [alignment = CharacterScanner justifiedCode])
		or: [lastCharacter = Character tab and: [lastSpaceOrTabExtent notNil]])
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent].
	characterIndex
		ifNotNil: ["If scanning for an index and we've stopped on that index,
				then we back destX off by the width of the character stopped on
				(it will be pointing at the right side of the character) and return"
				runStopIndex = characterIndex
					ifTrue:	[self characterPointSetX: destX - lastCharacterExtent x.
							^true].
				"Otherwise the requested index was greater than the length of the
				string.  Return string size + 1 as index, indicate further that off the
				string by setting character to nil and the extent to 0."
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].

	"Scanning for a point and either off the end of the line or off the end of the string."
	runStopIndex = text size
		ifTrue:	["off end of string"
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].
	"just off end of line without crossing x"
	lastIndex _ lastIndex + 1.
	^true! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 3/1/2010 11:03'!
characterBlockAtPoint: aPoint index: index in: textLine
	"This method is the Morphic characterBlock finder.  It combines
	MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:"
	| runLength lineStop done stopCondition |
	line _ textLine.
	rightMargin _ line rightMargin.
	lastIndex _ line first.
	self setStopConditions.		"also sets font"
	characterIndex _ index.  " == nil means scanning for point"
	characterPoint _ aPoint.
	(characterPoint == nil or: [characterPoint y > line bottom])
		ifTrue: [characterPoint _ line bottomRight].
	(text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left])
				or: [characterIndex ~~ nil and: [characterIndex < line first]]])
		ifTrue:	[^ (CharacterBlock new stringIndex: line first text: text
					topLeft: line leftMargin@line top extent: 0 @ actualTextStyle initialLineGrid)
					textLine: line].
	destX _ leftMargin _ line leftMarginForAlignment: alignment.
	destY _ line top.
	runLength _ text runLengthFor: line first.
	characterIndex ~~ nil
		ifTrue:	[lineStop _ characterIndex  "scanning for index"]
		ifFalse:	[lineStop _ line last  "scanning for point"].
	runStopIndex _ lastIndex + (runLength - 1) min: lineStop.
	lastCharacterExtent _ 0 @ line lineHeight.
	spaceCount _ 0.

	done  _ false.
	[ done ] whileFalse: [
		stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.
		"see setStopConditions for stopping conditions for character block 	operations."
		self lastCharacterExtentSetX: (specialWidth ifNil: [ font widthOf: (text at: lastIndex) ]).
		(self perform: stopCondition) ifTrue: [
			^characterIndex
				ifNil: ["Result for characterBlockAtPoint: "
						(CharacterBlock new stringIndex: lastIndex
							text: text topLeft: characterPoint + (font descentKern @ 0)
							extent: lastCharacterExtent - (font baseKern @ 0))
									textLine: line]
				ifNotNil: ["Result for characterBlockForIndex: "
						(CharacterBlock new stringIndex: characterIndex
							text: text topLeft: characterPoint + ((font descentKern - kern max: 0)@ 0)
							extent: lastCharacterExtent)
									textLine: line]]]! !


!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 3/1/2010 11:10'!
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 ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[
			self notify: oldClass name asText allBold, 
						' should not be redefined!! \Proceed to store over it.' withCRs]].

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

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

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

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

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

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

!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 2/28/2010 23:17'!
needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass
	"Answer whether we need a new subclass to conform to the requested changes"
	| newFormat |
	"Compute the format of the new class"
	newFormat _ 
		self computeFormat: type 
			instSize: instVars size 
			forSuper: newSuper 
			ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).
	newFormat
		ifNil: [^ nil].

	"Check if we really need a new subclass"
	oldClass ifNil:[^true]. "yes, it's a new class"
	newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change"
	newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change"
	instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change"

	^false
! !

!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 3/1/2010 11:03'!
newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass
	"Create a new subclass of the given superclass with the given specification."
	| newFormat newClass |
	"Compute the format of the new class"
	newFormat _ 
		self computeFormat: type 
			instSize: instVars size 
			forSuper: newSuper 
			ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).

	newFormat
		ifNil: [^ nil].

	(oldClass == nil or:[oldClass isMeta not]) 
		ifTrue:[newClass _ self privateNewSubclassOf: newSuper from: oldClass]
		ifFalse:[newClass _ oldClass clone].

	newClass 
		superclass: newSuper
		methodDictionary: MethodDictionary new
		format: newFormat;
		setInstVarNames: instVars.

	oldClass ifNotNil:[
		newClass organization: oldClass organization.
		"Recompile the new class"
		oldClass hasMethods 
			ifTrue:[newClass compileAllFrom: oldClass].
		self recordClass: oldClass replacedBy: newClass.
	].

	(oldClass == nil or:[oldClass isObsolete not]) 
		ifTrue:[newSuper addSubclass: newClass]
		ifFalse:[newSuper addObsoleteSubclass: newClass].

	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 2/28/2010 23:18'!
recompile: force from: oldClass to: newClass mutate: forceMutation
	"Do the necessary recompilation after changine oldClass to newClass.
	If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass
	and all its subclasses. If forceMutation is true force a mutation even
	if oldClass and newClass are the same."

	oldClass
		ifNil: [^ newClass].

	(newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[
		^newClass].

	currentClassIndex _ 0.
	maxClassIndex _ oldClass withAllSubclasses size.

	(oldClass == newClass and:[forceMutation not]) ifTrue:[
		"Recompile from newClass without mutating"
		self informUserDuring:[
			newClass withAllSubclassesDo:[:cl|
				self showProgressFor: cl.
				cl compileAll]].
		^newClass].
	"Recompile and mutate oldClass to newClass"
	self informUserDuring:[
		self mutate: oldClass to: newClass.
	].
	^oldClass "now mutated to newClass"! !

!ClassBuilder methodsFor: 'validation' stamp: 'jmv 3/1/2010 11:11'!
validateClassvars: classVarArray from: oldClass forSuper: newSuper
	"Check if any of the classVars of oldClass conflict with the new superclass"
	| usedNames classVars temp |
	classVarArray isEmpty ifTrue:[^true]. "Okay"

	"Validate the class var names"
	usedNames _ classVarArray asSet.
	usedNames size = classVarArray size 
		ifFalse:[	classVarArray do:[:var|
					usedNames remove: var ifAbsent:[temp _ var]].
				self error: temp,' is multiply defined'. ^false].
	(usedNames includesAnyOf: self reservedNames) 
		ifTrue:[	self reservedNames do:[:var|
					(usedNames includes: var) ifTrue:[temp _ var]].
				self error: temp,' is a reserved name'. ^false].

	newSuper ifNotNil: [
		usedNames _ newSuper allClassVarNames asSet.
		classVarArray do:[:iv|
			(usedNames includes: iv) ifTrue:[
				newSuper withAllSuperclassesDo:[:cl|
					(cl classVarNames includes: iv) ifTrue:[temp _ cl]].
				self error: iv, ' is already defined in ', temp name.
				^false]]].

	oldClass ifNotNil: [
		usedNames _ Set new: 20.
		oldClass allSubclassesDo:[:cl| usedNames addAll: cl classVarNames].
		classVars _ classVarArray.
		newSuper ifNotNil: [ classVars _ classVars, newSuper allClassVarNames asArray].
		classVars do: [ :iv |
			(usedNames includes: iv) ifTrue: [
				self error: iv, ' is already defined in a subclass of ', oldClass name.
				^false]]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'jmv 2/28/2010 23:20'!
validateInstvars: instVarArray from: oldClass forSuper: newSuper
	"Check if any of the instVars of oldClass conflict with the new superclass"
	| instVars usedNames temp |
	instVarArray isEmpty ifTrue:[^true]. "Okay"
	newSuper allowsSubInstVars ifFalse: [
		self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ^ false].

	"Validate the inst var names"
	usedNames _ instVarArray asSet.
	usedNames size = instVarArray size 
		ifFalse:[	instVarArray do:[:var|
					usedNames remove: var ifAbsent:[temp _ var]].
				self error: temp,' is multiply defined'. ^false].
	(usedNames includesAnyOf: self reservedNames) 
		ifTrue:[	self reservedNames do:[:var|
					(usedNames includes: var) ifTrue:[temp _ var]].
				self error: temp,' is a reserved name'. ^false].

	newSuper ifNotNil: [
		usedNames _ newSuper allInstVarNames asSet.
		instVarArray do:[:iv|
			(usedNames includes: iv) ifTrue:[
				newSuper withAllSuperclassesDo:[:cl|
					(cl instVarNames includes: iv) ifTrue:[temp _ cl]].
				self error: iv,' is already defined in ', temp name.
				^false]]].
	oldClass ifNotNil: [
		usedNames _ Set new: 20.
		oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames].
		instVars _ instVarArray.
		newSuper ifNotNil: [instVars _ instVars, newSuper allInstVarNames].
		instVars do:[:iv|
			(usedNames includes: iv) ifTrue:[
				self error: iv, ' is already defined in a subclass of ', oldClass name.
				^false]]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'jmv 3/1/2010 09:24'!
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 notNil)
		ifTrue: [deltaSize _ deltaSize - oldClass instVarNames size].
	(newSuper notNil)
		ifTrue: [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! !

!ClassBuilder methodsFor: 'validation' stamp: 'jmv 3/1/2010 11:12'!
validateSuperclass: aSuperClass forSubclass: aClass
	"Check if it is okay to use aSuperClass as the superclass of aClass"
	aClass ifNil: [ "New class"
		(aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]])
			ifFalse:[self error: aSuperClass name,' is not a valid superclass'.
					^false].
		^true].
	aSuperClass == aClass superclass ifTrue:[^true]. "No change"
	(aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy"
		ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name].
	"Check for circular references"
	(aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]])
		ifTrue:[self error: aSuperClass name,' inherits from ', aClass name.
				^false].
	^true! !

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


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

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

!ClassChangeRecord methodsFor: 'method changes' stamp: 'jmv 3/1/2010 09:27'!
noteNewMethod: newMethod selector: selector priorMethod: methodOrNil

	| methodChange |
	methodChange _ self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil.
	methodOrNil
		ifNil: [ methodChange noteChangeType: #add ]
		ifNotNil: [ methodChange noteChangeType: #change ].
	methodChange noteNewMethod: newMethod.
! !


!ClassDescription methodsFor: 'copying' stamp: 'jmv 3/1/2010 11:14'!
copy: sel from: class classified: cat 
	"Install the method associated with the first arugment, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under the third 
	argument, cat."

	| code category |
	"Useful when modifying an existing class"
	code _ class sourceMethodAt: sel.
	code ifNotNil: [
			category _ cat
				ifNil: [ class organization categoryOfElement: sel].
			(self methodDict includesKey: sel)
				ifTrue: [code asString = (self sourceMethodAt: sel) asString 
							ifFalse: [self error: self name 
										, ' ' 
										, sel 
										, ' will be redefined if you proceed.']].
			self compile: code classified: category]! !

!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 3/1/2010 11:14'!
instVarNames
	"Answer an Array of the receiver's instance variable names."

	^instanceVariables ifNil: [ #() ]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 3/1/2010 09:33'!
definition
	"Answer a String that defines the receiver."

	| aStream path |
	aStream _ WriteStream on: (String new: 300).
	superclass
		ifNil: [aStream nextPutAll: 'ProtoObject']
		ifNotNil: [
			path _ ''.
				Smalltalk scopeFor: superclass name from: nil
						envtAndPathIfFound: [:envt :remotePath | path _ remotePath].
				aStream nextPutAll: path , superclass name].
	aStream nextPutAll: self kindOfSubclass;
			store: self name.
	aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: ';
			store: self classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: self sharedPoolsString.
	aStream cr; tab; nextPutAll: 'category: ';
			store: (SystemOrganization categoryOfElement: self name) asString.

	superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: self name.
		aStream space; nextPutAll: 'superclass: nil'. ].

	^ aStream contents! !


!Class methodsFor: 'initialize-release' stamp: 'jmv 2/28/2010 23:14'!
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) notNil
				ifTrue: 
					[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! !

!Class methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:09'!
classPool
	"Answer the dictionary of class variables."

	^classPool
		ifNil: [Dictionary new]! !

!Class methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:09'!
name
	"Answer the name of the receiver."

	^name ifNil: [super name]! !

!Class methodsFor: 'class variables' stamp: 'jmv 2/28/2010 23:11'!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol oldState |
	oldState _ self copy.
	aString first isLowercase
		ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		(subclass bindingOf: symbol) ifNotNil:[
			^ self error: aString 
				, ' is already used as a variable name in class ' 
				, subclass name]].
	classPool ifNil: [classPool _ Dictionary new].
	(classPool includesKey: symbol) ifFalse: [
		"Pick up any refs in Undeclared"
		classPool declare: symbol from: Undeclared.
		SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! !

!Class methodsFor: 'class variables' stamp: 'jmv 2/28/2010 23:13'!
allClassVarNames
	"Answer a Set of the names of the receiver's class variables, including those
	defined in the superclasses of the receiver."

	| aSet |
	superclass
		ifNil: [^ self classVarNames].	 "This is the keys so it is a new Set."
	aSet _ superclass allClassVarNames.
	aSet addAll: self classVarNames.
	^ aSet! !

!Class methodsFor: 'pool variables' stamp: 'jmv 2/28/2010 23:12'!
addSharedPool: aSharedPool 
	"Add the argument, aSharedPool, as one of the receiver's shared pools. 
	Create an error if the shared pool is already one of the pools.
	This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses"

	(self sharedPools includes: aSharedPool)
		ifTrue: [^self error: 'This is already in my shared pool list'].
	sharedPools
		ifNil: [sharedPools _ OrderedCollection with: aSharedPool]
		ifNotNil: [sharedPools add: aSharedPool]! !

!Class methodsFor: 'pool variables' stamp: 'jmv 2/28/2010 23:13'!
allSharedPools
	"Answer a Set of the pools the receiver shares, including those defined  
	in the superclasses of the receiver."
	| aSet | 
	^ superclass
		ifNil: [self sharedPools copy]
		ifNotNil: [
			aSet _ superclass allSharedPools.
			aSet addAll: self sharedPools.
			aSet]! !

!Class methodsFor: 'pool variables' stamp: 'jmv 3/1/2010 11:09'!
sharedPools
	"Answer a Set of the pool dictionaries declared in the receiver."

	^sharedPools
		ifNil: [OrderedCollection new]! !

!Class methodsFor: 'compiling' stamp: 'jmv 2/28/2010 23:15'!
possibleVariablesFor: misspelled continuedFrom: oldResults

	| results |
	results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults.
	self sharedPools do: [:pool | 
		results _ misspelled correctAgainstDictionary: pool continuedFrom: results ].
	^ superclass
		ifNil: [misspelled correctAgainstDictionary: Smalltalk continuedFrom: results]
		ifNotNil: [superclass possibleVariablesFor: misspelled continuedFrom: results]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'jmv 2/28/2010 23:12'!
addSubclass: aSubclass 
	"Make the argument, aSubclass, be one of the subclasses of the receiver. 
	Create an error notification if the argument's superclass is not the receiver."
	
	aSubclass superclass ~~ self 
		ifTrue: [^self error: aSubclass name , ' is not my subclass'].
	subclasses ifNil: [
		subclasses _ Array with: aSubclass.
		^self].
	subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass"
	subclasses _ subclasses copyWith: aSubclass.! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'jmv 2/28/2010 23:16'!
removeSubclass: aSubclass 
	"If the argument, aSubclass, is one of the receiver's subclasses, remove it."

	subclasses
		ifNotNil: [
			subclasses _ subclasses copyWithout: aSubclass.
			subclasses isEmpty
				ifTrue: [subclasses _ nil]]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'jmv 2/28/2010 23:16'!
subclasses
	"Answer a Set containing the receiver's subclasses."

	^ subclasses
		ifNil: [#()]
		ifNotNil: [subclasses copy]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'jmv 2/28/2010 23:16'!
subclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses
		ifNotNil: [subclasses do: aBlock]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'jmv 2/28/2010 23:16'!
subclassesDoGently: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses
		ifNotNil: [subclasses do: aBlock]! !


!Collection methodsFor: 'enumerating' stamp: 'jmv 3/1/2010 09:38'!
detectMax: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the highest magnitude.
	If collection empty, return nil.  This method might also be called elect:."

	| maxElement maxValue val |
	self do: [ :each | 
		maxValue
			ifNil: ["first element"
				maxElement _ each.
				maxValue _ aBlock value: each]
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."
			ifNotNil: [
				(val _ aBlock value: each) > maxValue ifTrue: [
					maxElement _ each.
					maxValue _ val]]].
	^ maxElement! !

!Collection methodsFor: 'enumerating' stamp: 'jmv 3/1/2010 09:39'!
detectMin: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the lowest number.
	If collection empty, return nil."

	| minElement minValue val |
	self do: [:each | 
		minValue
			ifNil: ["first element"
				minElement _ each.
				minValue _ aBlock value: each]
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."
			ifNotNil: [
				(val _ aBlock value: each) < minValue ifTrue: [
					minElement _ each.
					minValue _ val]]].
	^ minElement! !


!Color methodsFor: 'private' stamp: 'jmv 3/1/2010 09:39'!
setPrivateRed: r green: g blue: b
	"Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax].  Encoded in a single variable as 3 integers in [0..1023]."

	rgb ifNotNil: [self attemptToMutateError].
	rgb _ ((r min: ComponentMask max: 0) bitShift: RedShift) +
		((g min: ComponentMask max: 0) bitShift: GreenShift) +
		 (b min: ComponentMask max: 0).
	cachedDepth _ nil.
	cachedBitPattern _ nil! !

!Color methodsFor: 'private' stamp: 'jmv 3/1/2010 09:39'!
setRGB: rgb0
	rgb ifNotNil: [self attemptToMutateError].
	rgb _ rgb0! !

!Color methodsFor: 'private' stamp: 'jmv 3/1/2010 09:40'!
setRed: r green: g blue: b
	"Initialize this color's r, g, and b components to the given values in the range [0.0..1.0].  Encoded in a single variable as 3 integers in [0..1023]."

	rgb ifNotNil: [self attemptToMutateError].
	rgb _
		(((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) +
		(((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) +
		 ((b * ComponentMax) rounded bitAnd: ComponentMask).
	cachedDepth _ nil.
	cachedBitPattern _ nil! !

!Color methodsFor: 'private' stamp: 'jmv 3/1/2010 09:40'!
setRed: r green: g blue: b range: range
	"Initialize this color's r, g, and b components to the given values in the range [0..r]."

	rgb ifNotNil: [self attemptToMutateError].
	rgb _
		((((r * ComponentMask) // range) bitAnd: ComponentMask) bitShift: RedShift) +
		((((g * ComponentMask) // range) bitAnd: ComponentMask) bitShift: GreenShift) +
		 (((b * ComponentMask) // range) bitAnd: ComponentMask).
	cachedDepth _ nil.
	cachedBitPattern _ nil! !


!ColorMap methodsFor: 'pixel mapping' stamp: 'jmv 3/1/2010 11:16'!
pixelMap: pixelValue
	"Perform a reverse pixel mapping operation"
	| pv |
	pv _ colors
		ifNil: [pixelValue]
		ifNotNil: [colors at: pixelValue].
	(shifts == nil and:[masks == nil]) 
		ifFalse:[pv _ (((pv bitAnd: self redMask) bitShift: self redShift) bitOr: 
				((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr:
					(((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: 
						((pv bitAnd: self alphaMask) bitShift: self alphaShift))].
	"Need to check for translucency else Form>>paint goes gaga"
	pv = 0 ifTrue:[pixelValue = 0 ifFalse:[pv _ 1]].
	^pv! !


!Compiler methodsFor: 'public access' stamp: 'jmv 3/1/2010 09:45'!
compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
	"Compiles the sourceStream into a parse tree, then generates code
	 into a method, and answers it.  If receiver is not nil, then the text can
	 refer to instance variables of that receiver (the Inspector uses this).
	 If aContext is not nil, the text can refer to temporaries in that context
	 (the Debugger uses this). If aRequestor is not nil, then it will receive a 
	 notify:at: message before the attempt to evaluate is aborted."

	| methodNode method |
	class _ (aContext
				ifNil: [receiver]
				ifNotNil: [aContext receiver]) class.
	self from: textOrStream class: class context: aContext notifying: aRequestor.
	methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value].
	method := methodNode generate: #(0 0 0 0).
	self interactive ifTrue:
		[method := method copyWithTempsFromMethodNode: methodNode].
	logFlag ifTrue:
		[SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext].
	^method! !

!Compiler methodsFor: 'public access' stamp: 'jmv 3/1/2010 09:45'!
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
	"Compiles the sourceStream into a parse tree, then generates code into a 
	method. This method is then installed in the receiver's class so that it 
	can be invoked. In other words, if receiver is not nil, then the text can 
	refer to instance variables of that receiver (the Inspector uses this). If 
	aContext is not nil, the text can refer to temporaries in that context (the 
	Debugger uses this). If aRequestor is not nil, then it will receive a 
	notify:at: message before the attempt to evaluate is aborted. Finally, the 
	compiled method is invoked from here as DoIt or (in the case of 
	evaluation in aContext) DoItIn:. The method is subsequently removed 
	from the class, but this will not get done if the invocation causes an 
	error which is terminated. Such garbage can be removed by executing: 
	Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: 
	#DoItIn:]."

	| methodNode method value toLog itsSelection itsSelectionString |
	class _ (aContext
				ifNil: [receiver]
				ifNotNil: [aContext receiver]) class.
	self from: textOrStream class: class context: aContext notifying: aRequestor.
	methodNode := self translate: sourceStream noPattern: true ifFail: [
		^failBlock value].
	method := methodNode generate: #(0 0 0 0).
	self interactive ifTrue: [
		method := method copyWithTempsFromMethodNode: methodNode].
	
	value := receiver
				withArgs: (context ifNil: [#()] ifNotNil: [{context}])
				executeMethod: method.

	logFlag ifTrue:[
		toLog := ((requestor respondsTo: #selection)  
			and:[(itsSelection := requestor selection) notNil
			and:[(itsSelectionString := itsSelection asString) isEmptyOrNil not]])
				ifTrue:[itsSelectionString]
				ifFalse:[sourceStream contents].
		SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext].
	^ value! !

!Compiler methodsFor: 'error handling' stamp: 'jmv 3/1/2010 09:47'!
notify: aString at: location
	"Refer to the comment in Object|notify:."

	^requestor
		ifNil: [ SyntaxErrorNotification
					inClass: class
					category: category
					withCode: 
						(sourceStream contents
							copyReplaceFrom: location
							to: location - 1
							with: aString)
					doitFlag: false
					errorMessage: aString
					location: location]
		ifNotNil: [ requestor
					notify: aString
					at: location
					in: sourceStream]! !


!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 3/1/2010 09:47'!
setActualFont: aFont
	"Keep track of max height and ascent for auto lineheight"
	| descent |
	super setActualFont: aFont.
	lineHeight
		ifNil: [
			descent _ font descent.
			baseline _ font ascent.
			lineHeight _ baseline + descent]
		ifNotNil: [
			descent _ lineHeight - baseline max: font descent.
			baseline _ baseline max: font ascent.
			lineHeight _ lineHeight max: baseline + descent]! !


!CompressedSoundData methodsFor: 'asSound' stamp: 'jmv 3/1/2010 09:47'!
reset
	"This message is the cue to start behaving like a real sound in order to be played.
	We do this by caching a decompressed version of this sound.
	See also samplesRemaining."

	cachedSound
		ifNil: [cachedSound _ self asSound].
	cachedSound reset
! !


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

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

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


!ContextPart methodsFor: 'debugger access' stamp: 'jmv 3/1/2010 09:50'!
singleRelease
	"Remove information from the receiver in order to break circularities."

	stackp ifNotNil: [1 to: stackp do: [:i | self at: i put: nil]].
	sender _ nil.
	pc _ nil! !

!ContextPart methodsFor: 'controlling' stamp: 'jmv 3/1/2010 09:50'!
send: selector to: rcvr with: args super: superFlag 
	"Simulate the action of sending a message with selector, selector, and 
	arguments, args, to receiver. The argument, superFlag, tells whether the 
	receiver of the message was specified with 'super' in the source method."

	| class meth val |
	class _ superFlag
			ifTrue: [(self method literalAt: self method numLiterals) value superclass]
			ifFalse: [rcvr class].
	meth _ class lookupSelector: selector.
	meth
		ifNil: [^ self send: #doesNotUnderstand:
					to: rcvr
					with: (Array with: (Message selector: selector arguments: args))
					super: superFlag].
	val _ self tryPrimitiveFor: meth
			receiver: rcvr
			args: args.
	val == PrimitiveFailToken ifFalse: [^ val].
	(selector == #doesNotUnderstand: and: [class == ProtoObject]) ifTrue: [
		^ self error: 'Simulated message ' , (args at: 1) selector
						, ' not understood'].
	^ self activateMethod: meth
		withArgs: args
		receiver: rcvr
		class: class! !

!ContextPart methodsFor: 'printing' stamp: 'jmv 3/1/2010 09:48'!
printOn: aStream 
	| selector class mclass |
	self method
		ifNil: [^ super printOn: aStream].
	class := self receiver class.
	mclass := self methodClass.
	selector := self selector ifNil: [ self method defaultSelector].
	aStream nextPutAll: class name.
	mclass == class 
		ifFalse: 
			[aStream nextPut: $(.
			aStream nextPutAll: mclass name.
			aStream nextPut: $)].
	aStream nextPutAll: '>>'.
	aStream nextPutAll: selector.
	selector = #doesNotUnderstand: ifTrue: [
		aStream space.
		(self tempAt: 1) selector printOn: aStream.
	].
! !

!ContextPart methodsFor: 'private' stamp: 'jmv 3/1/2010 09:50'!
tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
	"Hack. Attempt to execute the named primitive from the given compiled method"
	| selector theMethod spec |
	arguments size > 8 ifTrue:[^PrimitiveFailToken].
	selector _ #(
		tryNamedPrimitive 
		tryNamedPrimitive: 
		tryNamedPrimitive:with: 
		tryNamedPrimitive:with:with: 
		tryNamedPrimitive:with:with:with:
		tryNamedPrimitive:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1.
	theMethod _ aReceiver class lookupSelector: selector.
	theMethod ifNil: [ ^PrimitiveFailToken].
	spec _ theMethod literalAt: 1.
	spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1.
	^aReceiver perform: selector withArguments: arguments! !


!BlockContext methodsFor: 'printing' stamp: 'jmv 2/28/2010 22:43'!
printOn: aStream
	| decompilation blockString truncatedBlockString |

	home ifNil: [^aStream nextPutAll: 'a BlockContext with home=nil'].
	aStream nextPutAll: '[] in '.
	super printOn: aStream.
	decompilation := [self decompile ifNil: ['--source missing--']]
						on: Error
						do: [:ex| ' (error in decompilation)'].
	blockString := ((decompilation isString
					ifTrue: [decompilation]
					ifFalse: [decompilation printString])
						replaceAll: Character cr with: Character space)
							replaceAll: Character tab with: Character space.
	truncatedBlockString := blockString truncateWithElipsisTo: 80.
	truncatedBlockString size < blockString size ifTrue:
		[truncatedBlockString := truncatedBlockString, ']}'].
	aStream space; nextPutAll: truncatedBlockString! !

!BlockContext methodsFor: 'printing' stamp: 'jmv 2/28/2010 22:43'!
printOnStream: aStream

	home ifNil: [^aStream print: 'a BlockContext with home=nil'].
	aStream print: '[] in '.
	super printOnStream: aStream! !


!ContextPart class methodsFor: 'examples' stamp: 'jmv 3/1/2010 09:51'!
tallyMethods: aBlock
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. Results are given in order of decreasing counts."
	| prev tallies |
	tallies _ Bag new.
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: [ "call or return"
				prev sender ifNotNil: [ "call only"
					tallies add: current printString].
				prev _ current]].
	^tallies sortedCounts

	"ContextPart tallyMethods: [3.14159 printString]"! !


!Decompiler methodsFor: 'instruction decoding' stamp: 'jmv 3/1/2010 09:54'!
pushConstant: value 
	| node |
	node _ value == true
				ifTrue: [constTable at: 2]
				ifFalse: [
					value == false
						ifTrue: [constTable at: 3]
						ifFalse: [
							value
								ifNil: [constTable at: 4]
								ifNotNil: [constructor codeAnyLiteral: value]]].
	stack addLast: node! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'jmv 3/1/2010 09:55'!
pushReceiverVariable: offset

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

!Decompiler methodsFor: 'private' stamp: 'jmv 3/1/2010 09:53'!
convertToDoLoop
	"If statements contains the pattern
		var := startExpr.
		[var <= limit] whileTrue: [...statements... var := var + incConst]
	then replace this by
		startExpr to: limit by: incConst do: [:var | ...statements...]"
	| initStmt toDoStmt limitStmt |
	statements size < 2 ifTrue: [^ self].
	initStmt := statements at: statements size-1.
	(toDoStmt := statements last toDoFromWhileWithInit: initStmt)
		ifNil: [^ self].
	initStmt variable scope: -1.  "Flag arg as block temp"
	statements removeLast; removeLast; addLast: toDoStmt.

	"Attempt further conversion of the pattern
		limitVar := limitExpr.
		startExpr to: limitVar by: incConst do: [:var | ...statements...]
	to
		startExpr to: limitExpr by: incConst do: [:var | ...statements...]"
	statements size < 2 ifTrue: [^ self].
	limitStmt := statements at: statements size-1.
	((limitStmt isMemberOf: AssignmentNode)
		and: [limitStmt variable isTemp
		and: [limitStmt variable == toDoStmt arguments first
		and: [self blockScopeRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]])
		ifFalse: [^ self].
	toDoStmt arguments at: 1 put: limitStmt value.
	limitStmt variable scope: -2.  "Flag limit var so it won't print"
	statements removeLast; removeLast; addLast: toDoStmt.

! !


!Delay class methodsFor: 'snapshotting' stamp: 'jmv 3/1/2010 09:57'!
restoreResumptionTimes
	"Private!! Restore the resumption times of all scheduled Delays after a snapshot or clock roll-over. This method should be called only while the AccessProtect semaphore is held."

	| newBaseTime |
	newBaseTime _ Time millisecondClockValue.
	SuspendedDelays
		do: [ :d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime].
	ActiveDelay
		ifNotNil: [ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime]! !

!Delay class methodsFor: 'snapshotting' stamp: 'jmv 3/1/2010 09:56'!
saveResumptionTimes
	"Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting or adjusting the resumption times after a clock roll-over. This method should be called only while the AccessProtect semaphore is held."

	| oldBaseTime |
	oldBaseTime _ Time millisecondClockValue.
	ActiveDelay
		ifNotNil: [
			oldBaseTime < ActiveDelayStartTime
				ifTrue: [oldBaseTime _ ActiveDelayStartTime].  "clock rolled over"
			ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
	SuspendedDelays do:
		[:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
! !


!Envelope methodsFor: 'accessing' stamp: 'jmv 3/1/2010 10:00'!
duration
	"Return the time of the final point."

	loopEndMSecs
		ifNil: [^ points last x].
	^ loopEndMSecs + self decayTime
! !

!Envelope methodsFor: 'applying' stamp: 'jmv 3/1/2010 10:00'!
computeValueAtMSecs: mSecs
	"Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope."
	"Note: Unlike the private method incrementalComputeValueAtMSecs:, this method does is not increment. Thus it is slower, but it doesn't depend on being called sequentially at fixed time intervals."

	| t i |
	mSecs < 0 ifTrue: [^ 0.0].

	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i ifNil: [^ 0.0].  "past end"
		^ (self interpolate: t between: (points at: i - 1) and: (points at: i)) * decayScale].

	mSecs < loopStartMSecs ifTrue: [  "attack phase"
		i _ self indexOfPointAfterMSecs: mSecs startingAt: 1.
		i = 1 ifTrue: [^ (points at: 1) y * scale].
		^ self interpolate: mSecs between: (points at: i - 1) and: (points at: i)].

	"sustain phase"
	loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y * scale].  "looping on a single point"
	t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
	i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex.

	^ self interpolate: t between: (points at: i - 1) and: (points at: i)
! !

!Envelope methodsFor: 'private' stamp: 'jmv 3/1/2010 11:19'!
incrementalComputeValueAtMSecs: mSecs
	"Compute the current value, per-step increment, and the time of the next inflection point."
	"Note: This method is part of faster, but less general, way of computing envelope values. It depends on a known, fixed control updating rate."

	| t i |
	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i ifNil: [  "past end"
			currValue _ points last y * scale * decayScale.
			valueIncr _ 0.0.
			nextRecomputeTime _ mSecs + 1000000.
			^ currValue].
		nextRecomputeTime _ mSecs + ((points at: i) x - t).
		^ self computeIncrementAt: t
			between: (points at: i - 1)
			and: (points at: i)
			scale: scale * decayScale].

	mSecs < loopStartMSecs
		ifTrue: [  "attack phase"
			t _ mSecs.
			i _ self indexOfPointAfterMSecs: t startingAt: 1.
			nextRecomputeTime _ mSecs + ((points at: i) x - t)]
		ifFalse: [  "sustain (looping) phase"
			noChangesDuringLoop ifTrue: [
				currValue _ (points at: loopEndIndex) y * scale.
				valueIncr _ 0.0.
					loopEndMSecs
						ifNil: [nextRecomputeTime _ mSecs + 10]	 "unknown end time"
						ifNotNil: [nextRecomputeTime _ loopEndMSecs].
				^ currValue].
			t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
			i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
			nextRecomputeTime _ (mSecs + ((points at: i) x - t)) min: loopEndMSecs].

	^ self computeIncrementAt: t
		between: (points at: i - 1)
		and: (points at: i)
		scale: scale.
! !


!EventSensor methodsFor: 'accessing' stamp: 'jmv 3/1/2010 10:01'!
nextEvent
	"Return the next event from the receiver."
	eventQueue
		ifNil: [^ self nextEventSynthesized].
	^ self nextEventFromQueue! !


!Exception methodsFor: 'exceptionDescription' stamp: 'jmv 3/1/2010 10:02'!
description
	
"Return a textual description of the exception."

	| desc |
	desc := self class name asString.
	^ self messageText
		ifNil: [ desc]
		ifNotNil: [ :mt | desc , ': ' , mt ]! !

!Exception methodsFor: 'exceptionDescription' stamp: 'jmv 3/1/2010 11:19'!
tag
       "Return an exception's tag value."

	^tag ifNil: [ self messageText ]! !


!AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'jmv 2/28/2010 22:45'!
description
	"Return a textual description of the exception."

	| desc |
	desc := 'Error'.
	^self messageText
		ifNil: [ desc]
		ifNotNil: [ :mt | desc, ': ', mt ]! !


!FakeClassPool class methodsFor: 'as yet unclassified' stamp: 'jmv 3/1/2010 11:20'!
adopt: classOrNil
	"Temporarily use the classPool and sharedPools of another class"
	
	classOrNil
		ifNil: [
			classPool _ nil.
			sharedPools _ nil]
		ifNotNil: [
			classPool _ classOrNil classPool.
			sharedPools _ classOrNil sharedPools]! !


!FileDirectory methodsFor: 'file operations' stamp: 'jmv 3/1/2010 11:22'!
deleteFileNamed: localFileName ifAbsent: failBlock
	"Delete the file of the given name if it exists, else evaluate failBlock.
	If the first deletion attempt fails do a GC to force finalization of any lost references. ar 3/21/98 17:53"
	| fullName |
	fullName _ self fullNameFor: localFileName.
	(StandardFileStream 
		retryWithGC:[self primDeleteFileNamed: (self fullNameFor: localFileName)]
		until:[:result| result notNil]
		forFileNamed: fullName) ifNil: [
			^failBlock value].
! !

!FileDirectory methodsFor: 'private' stamp: 'jmv 3/1/2010 11:22'!
directoryContentsFor: fullPath
	"Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details."
	"FileDirectory default directoryContentsFor: ''"

	| entries index done entryArray |
	entries _ OrderedCollection new: 200.
	index _ 1.
	done _ false.
	[done] whileFalse: [
		entryArray _ self primLookupEntryIn: fullPath index: index.
		#badDirectoryPath = entryArray ifTrue: [
			^(InvalidDirectoryError pathName: pathName) signal].
		entryArray
			ifNil: [done _ true]
			ifNotNil: [entries addLast: (DirectoryEntry fromArray: entryArray)].
		index _ index + 1].

	^ entries asArray! !


!FileStreamException methodsFor: 'exceptionDescription' stamp: 'jmv 3/1/2010 11:25'!
messageText
	
	"Return an exception's message text."

	^messageText ifNil: [fileName printString]! !


!Form methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:25'!
bitsSize
	| pixPerWord |
	depth ifNil: [depth _ 1].
	pixPerWord _ 32 // self depth.
	^ width + pixPerWord - 1 // pixPerWord * height! !

!Form methodsFor: 'fileIn/Out' stamp: 'jmv 3/1/2010 11:25'!
unhibernate
	"If my bitmap has been compressed into a ByteArray,
	then expand it now, and return true."
	| resBits |
	(bits is: #Form) ifTrue:[
		resBits _ bits.
		bits _ Bitmap new: self bitsSize.
		resBits displayResourceFormOn: self.
		^true].
	bits ifNil: [ bits _ Bitmap new: self bitsSize. ^true].
	(bits isMemberOf: ByteArray)
		ifTrue: [bits _ Bitmap decompressFromByteArray: bits. ^ true].
	^ false! !


!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41'!
colormapIfNeededForDepth: destDepth
	"Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."

	| newMap |
	colors ifNil: [
		"use the standard colormap"
		^ Color colorMapIfNeededFrom: self depth to: destDepth].

	(destDepth = cachedDepth and:[cachedColormap isColormap not]) 
		ifTrue: [^ cachedColormap].
	newMap _ Bitmap new: colors size.
	1 to: colors size do: [:i |
		newMap
			at: i
			put: ((colors at: i) pixelValueForDepth: destDepth)].

	cachedDepth _ destDepth.
	^ cachedColormap _ newMap.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41'!
replaceColorAtIndex: index with: newColor
	"Replace a color map entry with newColor."

	self ensureColorArrayExists.
	colors at: index put: newColor.
	cachedColormap ifNotNil: [
		cachedColormap at: index put: (newColor pixelValueForDepth: cachedDepth)]! !

!ColorForm methodsFor: 'color mapping' stamp: 'jmv 3/1/2010 09:41'!
colormapIfNeededFor: destForm
	| newMap color pv |
	(self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifFalse:[
		^self colormapIfNeededForDepth: destForm depth.
	].
	colors ifNil: [
		"use the standard colormap"
		^ super colormapIfNeededFor: destForm].

	(destForm depth = cachedDepth and:[cachedColormap isColormap]) 
		ifTrue: [^ cachedColormap].
	newMap _ WordArray new: (1 bitShift: self depth).
	1 to: colors size do: [:i |
		color _ colors at: i.
		pv _ destForm pixelValueFor: color.
		(pv = 0 and: [ color isTransparent not]) ifTrue: [ pv _ 1].
		newMap at: i put: pv].

	cachedDepth _ destForm depth.
	^cachedColormap _ ColorMap shifts: nil masks: nil colors: newMap.! !


!DisplayScreen methodsFor: 'other' stamp: 'jmv 3/1/2010 09:58'!
boundingBox
	clippingBox
		ifNil: [clippingBox _ super boundingBox].
	^ clippingBox! !


!Form class methodsFor: 'examples' stamp: 'jmv 3/1/2010 11:26'!
toothpaste: diam		"Display restoreAfter: [Form toothpaste: 30]"
	"Draws wormlike lines by laying down images of spheres.
	See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352.
	Draw with mouse button down; terminate by option-click."
	| facade ball filter point queue port color q colors colr colr2 |
	colors _ Display depth = 1
		ifTrue: [Array with: Color black]
		ifFalse: [Color red wheel: 12].
	facade _ Form extent: diam@diam offset: (diam//-2) asPoint.
	(Form dotOfSize: diam) displayOn: facade
			at: (diam//2) asPoint clippingBox: facade boundingBox
			rule: Form under fillColor: Color white.
	#(1 2 3) do:
		[:x |  "simulate facade by circles of gray"
		(Form dotOfSize: x*diam//5) displayOn: facade
			at: (diam*2//5) asPoint clippingBox: facade boundingBox
			rule: Form under
			fillColor: (Color perform: 
					(#(black gray lightGray) at: x)).
		"facade displayAt: 50*x@50"].
	ball _ Form dotOfSize: diam.
	color _ 8.
	[ true ] whileTrue:
		[port _ BitBlt current toForm: Display.
		"Expand 1-bit forms to any pixel depth"
		port colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
		queue _ OrderedCollection new: 32.
		16 timesRepeat: [queue addLast: -20@-20].
		Sensor waitButton.
		Sensor yellowButtonPressed ifTrue: [^ self].
		filter _ Sensor cursorPoint.
		colr _ colors atWrap: (color _ color + 5).  "choose increment relatively prime to colors size"
		colr2 _ colr alphaMixed: 0.3 with: Color white.
		[Sensor redButtonPressed or: [queue size > 0]] whileTrue:
			[filter _ filter * 4 + Sensor cursorPoint // 5.
			point _ Sensor redButtonPressed
				ifTrue: [filter] ifFalse: [-20@-20].
			port copyForm: ball to: point rule: Form paint fillColor: colr.
			(q _ queue removeFirst) ifNil: [^ self].	"exit"
			Display depth = 1
				ifTrue: [port copyForm: facade to: q rule: Form erase]
				ifFalse: [port copyForm: facade to: q rule: Form paint fillColor: colr2].
			Sensor redButtonPressed ifTrue: [queue addLast: point]]].
! !


!HandMorph methodsFor: 'cursor' stamp: 'jmv 3/1/2010 11:27'!
cursorBounds

	^temporaryCursor
		ifNil: [ self position extent: NormalCursor extent]
		ifNotNil: [self position + temporaryCursorOffset
								extent: temporaryCursor extent]! !


!Heap methodsFor: 'testing' stamp: 'jmv 3/1/2010 11:27'!
sorts: element1 before: element2
	"Return true if element1 should be sorted before element2.
	This method defines the sort order in the receiver"
	^ sortBlock
		ifNil: [element1 <= element2]
		ifNotNil: [sortBlock value: element1 value: element2]! !


!LinkedList methodsFor: 'removing' stamp: 'jmv 3/1/2010 11:30'!
remove: aLink ifAbsent: aBlock  
	"Remove aLink from the receiver. If it is not there, answer the result of
	evaluating aBlock."

	| tempLink |
	aLink == firstLink
		ifTrue: [firstLink _ aLink nextLink.
				aLink == lastLink
					ifTrue: [lastLink _ nil]]
		ifFalse: [tempLink _ firstLink.
				[tempLink ifNil: [^aBlock value].
				 tempLink nextLink == aLink]
					whileFalse: [tempLink _ tempLink nextLink].
				tempLink nextLink: aLink nextLink.
				aLink == lastLink
					ifTrue: [lastLink _ tempLink]].
	aLink nextLink: nil.
	^aLink! !


!Message methodsFor: 'sending' stamp: 'jmv 3/1/2010 11:31'!
sentTo: receiver
	"answer the result of sending this message to receiver"

	^lookupClass
		ifNil: [receiver perform: selector withArguments: args]
		ifNotNil: [receiver perform: selector withArguments: args inSuperclass: lookupClass]! !


!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'jmv 3/1/2010 11:34'!
messageText
	"Return an exception's message text."

	^ messageText
		ifNil: [
			message
				ifNil: [super messageText]
				ifNotNil: [message lookupClass printString , '>>' , message selector asString]]! !


!MessageTally methodsFor: 'collecting leaves' stamp: 'jmv 3/1/2010 11:36'!
bump: hitCount fromSender: senderTally
	"Add this hitCount to the total, and include a reference to the
	sender responsible for the increment"
	self bump: hitCount.
	senders ifNil: [senders _ OrderedCollection new].
	senderTally == nil
		ifFalse: [senders add: (senderTally copyWithTally: hitCount)]! !

!MessageTally methodsFor: 'printing' stamp: 'jmv 3/1/2010 11:36'!
printOn: aStream total: total totalTime: totalTime tallyExact: isExact 

	isExact 
		ifTrue: [
			| myTally |
			myTally := tally.
			receivers
				ifNotNil: [receivers do: [:r | myTally := myTally - r tally]].
			aStream
				print: myTally;
				space]
		ifFalse: [
			| percentage |
			percentage := tally asFloat / total * 100.0 roundTo: 0.1.
			aStream
				print: percentage;
				nextPutAll: '% {';
				print: (percentage * totalTime / 100) rounded;
				nextPutAll: 'ms} '].
	receivers
		ifNil: [
			aStream
				nextPutAll: 'primitives';
				cr]
		ifNotNil: [
			| className aSelector aClass |
			aSelector := class selectorAtMethod: method setClass: [ :c | aClass := c].
			className := aClass name contractTo: self maxClassNameSize.
			aStream
				nextPutAll: class name;
				nextPutAll: (aClass = class 
							ifTrue: ['>>']
							ifFalse: ['(' , aClass name , ')>>']);
				nextPutAll: (aSelector 
							contractTo: self maxClassPlusSelectorSize - className size);
				cr]! !


!MessageTally class methodsFor: 'spying' stamp: 'jmv 3/1/2010 11:37'!
tallySendsTo: receiver inBlock: aBlock showTree: treeOption
	"
	MessageTally tallySends: [3.14159 printString]
	"
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. If receiver is not nil, then only sends
	to that receiver are tallied.
	Results are presented as leaves, sorted by frequency,
	preceded, optionally, by the whole tree."
	| prev tallies startTime totalTime |
	startTime _ Time millisecondClockValue.
	tallies _ MessageTally new class: aBlock receiver class method: aBlock method.
	tallies reportOtherProcesses: true.	"Do NOT filter nodes with nil process"
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep: [ :current |
			current == prev ifFalse: [ "call or return"
				prev sender ifNotNil: [ "call only"
					(receiver == nil or: [ current receiver == receiver ])
						ifTrue: [ tallies tally: current by: 1 ]].
				prev _ current]].

	totalTime _ Time millisecondClockValue - startTime // 1000.0 roundTo: 0.01.
	(CodeHolder new contents:
		(String streamContents: [ :s |
			s nextPutAll: 'This simulation took ' , totalTime printString, ' seconds.'; cr.
			treeOption
				ifTrue: [ tallies fullPrintExactOn: s ]
				ifFalse: [ tallies leavesPrintExactOn: s ]]))
		openLabel: 'Spy Results' wrap: false! !


!Metaclass methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:39'!
name
	"Answer a String that is the name of the receiver, either 'Metaclass' or 
	the name of the receiver's class followed by ' class'."

	^thisClass
		ifNil: [ 'a Metaclass']
		ifNotNil: [ thisClass name , ' class']! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'jmv 3/1/2010 11:39'!
obsoleteSubclasses
	"Answer the receiver's subclasses."
	thisClass
		ifNil: [^ #()].
	^thisClass obsoleteSubclasses 
		select:[:aSubclass| aSubclass isMeta not] 
		thenCollect:[:aSubclass| aSubclass class]

	"Metaclass allInstancesDo:
		[:m | Compiler evaluate: 'subclasses_nil' for: m logged: false]"! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'jmv 3/1/2010 11:39'!
subclasses
	"Answer the receiver's subclasses."
	thisClass
		ifNil: [^ #()].
	^thisClass subclasses 
		select:[:aSubclass| aSubclass isMeta not] 
		thenCollect:[:aSubclass| aSubclass class]

	"Metaclass allInstancesDo:
		[:m | Compiler evaluate: 'subclasses_nil' for: m logged: false]"! !

!Metaclass methodsFor: 'testing' stamp: 'jmv 3/1/2010 11:38'!
canZapMethodDictionary
	"Return true if it is safe to zap the method dictionary on #obsolete"
	^thisClass
		ifNil: [ true ]
		ifNotNil: [ thisClass canZapMethodDictionary ]! !


!MethodContext methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:40'!
home 
	"Answer the context in which the receiver was defined."

	closureOrNil
		ifNil: [^ self].
	^closureOrNil outerContext home! !

!MethodContext methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:40'!
methodReturnContext
	"Answer the context from which an ^-return should return from."

	closureOrNil
		ifNil: [^ self].
	^closureOrNil outerContext methodReturnContext! !

!MethodContext methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:40'!
outerContext
	"Answer the context within which the receiver is nested."

	^ closureOrNil
		ifNotNil: [closureOrNil outerContext]! !


!Model methodsFor: 'dependents' stamp: 'jmv 3/1/2010 11:50'!
hasUnacceptedEdits
	"Answer true if any of the views on this model has unaccepted edits."

	dependents
		ifNil: [^ false].
	^ super hasUnacceptedEdits
! !


!Browser methodsFor: 'annotation' stamp: 'jmv 2/28/2010 23:01'!
annotation
	"Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver."

	|  aSelector aClass |
	(aClass _ self selectedClassOrMetaClass)
		ifNil: [^ '------'].
	self editSelection == #editComment
		ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass].
	self editSelection == #editClass
		ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass].
	(aSelector _ self selectedMessageName)
		ifNil: [^ '------'].
	^ self annotationForSelector: aSelector ofClass: aClass! !

!Browser methodsFor: 'class functions' stamp: 'jmv 2/28/2010 23:01'!
findMethod
	"Pop up a list of the current class's methods, and select the one chosen by the user"

	| aClass selectors reply cat messageCatIndex messageIndex |
	self classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	aClass _ self selectedClassOrMetaClass.
	selectors _ aClass selectors asSortedArray.
	selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self].
	reply _ (SelectionMenu labelList: selectors selections: selectors) startUp.
	reply
		ifNil: [^ self].
	cat _ aClass whichCategoryIncludesSelector: reply.
	messageCatIndex _ self messageCategoryList indexOf: cat.
	self messageCategoryListIndex: messageCatIndex.
	messageIndex _ (self messageList indexOf: reply).
	self messageListIndex: messageIndex! !

!Browser methodsFor: 'class list' stamp: 'jmv 2/28/2010 23:01'!
recent
	"Let the user select from a list of recently visited classes.  11/96 stp.
	 12/96 di:  use class name, not classes themselves.
	 : dont fall into debugger in empty case"

	| className class recentList |
	recentList _ RecentClasses select: [:n | Smalltalk includesKey: n].
	recentList size = 0 ifTrue: [^ Beeper beep].
	className := (SelectionMenu selections: recentList) startUp.
	className
		ifNil: [^ self].
	class := Smalltalk at: className.
	self selectCategoryForClass: class.
	self classListIndex: (self classList indexOf: class name)! !

!Browser methodsFor: 'message functions' stamp: 'jmv 2/28/2010 23:01'!
defineMessageFrom: aString notifying: aController
	"Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under  the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise."
	| selectedMessageName selector category oldMessageList |
	selectedMessageName _ self selectedMessageName.
	oldMessageList _ self messageList.
	contents _ nil.
	selector _ (Smalltalk actualParserClass new parseSelector: aString).
	(self metaClassIndicated
		and: [(self selectedClassOrMetaClass includesSelector: selector) not
		and: [Metaclass isScarySelector: selector]])
		ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses"
				(self confirm: ((selector , ' is used in the existing class system.
Overriding it could cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size))
				ifFalse: [^nil]].
	selector _ self selectedClassOrMetaClass
				compile: aString
				classified: (category _ self selectedMessageCategoryName)
				notifying: aController.
	selector
		ifNil: [^ nil].
	contents _ aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self changed: #classList.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageList].
			self messageListIndex: (self messageList indexOf: selector)].
	^ selector! !

!Browser methodsFor: 'message list' stamp: 'jmv 2/28/2010 23:01'!
selectedMessage
	"Answer a copy of the source code for the selected message."

	| class selector method |
	contents
		ifNotNil: [^ contents copy].
	self showingDecompile ifTrue:
		[^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	method _ class compiledMethodAt: selector ifAbsent: [^ ''].	"method deleted while in another project"
	currentCompiledMethod _ method.

	^ contents _ (self showingDocumentation
		ifFalse: [ self sourceStringPrettifiedAndDiffed ]
		ifTrue: [ self commentContents ])
			copy asText makeSelectorBoldIn: class! !


!ChangeList class methodsFor: 'public access' stamp: 'jmv 2/28/2010 23:02'!
browseRecentLogOn: origChangesFile startingFrom: initialPos 
	"Prompt with a menu of how far back to go when browsing a changes file."

	| end banners positions pos chunk i changesFile |
	changesFile _ origChangesFile readOnlyCopy.
	banners _ OrderedCollection new.
	positions _ OrderedCollection new.
	end _ changesFile size.
	pos _ initialPos.
	[pos = 0
		or: [banners size > 20]]
		whileFalse: [changesFile position: pos.
			chunk _ changesFile nextChunk.
			i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
			i > 0
				ifTrue: [positions addLast: pos.
					banners
						addLast: (chunk copyFrom: 5 to: i - 2).
					pos _ Number
								readFrom: (chunk copyFrom: i + 13 to: chunk size)]
				ifFalse: [pos _ 0]].
	changesFile close.
	banners size = 0 ifTrue: [^ self inform: 
'this image has never been saved
since changes were compressed'].
	pos _ (SelectionMenu labelList: banners selections: positions)
				startUpWithCaption: 'Browse as far back as...'.
	pos
		ifNil: [^ self].
	self browseRecent: end - pos on: origChangesFile! !

!ChangeList class methodsFor: 'public access' stamp: 'jmv 2/28/2010 23:03'!
getRecentLocatorWithPrompt: aPrompt
	"Prompt with a menu of how far back to go.  Return nil if user backs out.  Otherwise return the number of characters back from the end of the .changes file the user wishes to include"
	 "ChangeList getRecentPosition"
	| end changesFile banners positions pos chunk i |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	banners _ OrderedCollection new.
	positions _ OrderedCollection new.
	end _ changesFile size.
	pos _ Smalltalk lastQuitLogPosition.
	[pos = 0 or: [banners size > 20]] whileFalse:
		[changesFile position: pos.
		chunk _ changesFile nextChunk.
		i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
		i > 0 ifTrue: [positions addLast: pos.
					banners addLast: (chunk copyFrom: 5 to: i-2).
					pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
			ifFalse: [pos _ 0]].
	changesFile close.
	pos _ (SelectionMenu labelList: banners selections: positions)
				startUpWithCaption: aPrompt.
	pos
		ifNil: [^ nil].
	^ end - pos! !


!ChangeSorter methodsFor: 'code pane' stamp: 'jmv 2/28/2010 23:07'!
setContents
	"return the source code that shows in the bottom pane"

	| sel class strm changeType |
	self clearUserEditFlag.
	currentClassName ifNil: [^ contents _ myChangeSet preambleString ifNil: ['']].
	class _ self selectedClassOrMetaClass.
	(sel _ currentSelector)
		ifNotNil: [
			changeType _ (myChangeSet atSelector: (sel _ sel asSymbol) class: class).
			changeType == #remove
				ifTrue: [^ contents _ 'Method has been removed (see versions)'].
			changeType == #addedThenRemoved
				ifTrue: [^ contents _ 'Added then removed (see versions)'].
			class ifNil: [^ contents _ 'Method was added, but cannot be found!!'].
			(class includesSelector: sel)
				ifFalse: [^ contents _ 'Method was added, but cannot be found!!'].
			contents _ class sourceCodeAt: sel.
			(#(prettyPrint prettyLineDiffs prettyWordDiffs) includes: contentsSymbol) ifTrue:
				[contents _ class compilerClass new
						format: contents 
						in: class 
						notifying: nil].
			self showingAnyKindOfDiffs
				ifTrue: [contents _ self diffFromPriorSourceFor: contents].
			^ contents _ contents asText makeSelectorBoldIn: class]
		ifNil: 
			[strm _ WriteStream on: (String new: 100).
			(myChangeSet classChangeAt: currentClassName) do:
				[:each |
				each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr].
				each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.'].
				each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr].
				each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr].
				each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr].
				each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr].
				each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr.
				]].
			^ contents _ strm contents].! !


!ChangeSorter class methodsFor: 'class initialization' stamp: 'jmv 2/28/2010 23:08'!
initialize
	"Initialize the class variables"

	AllChangeSets
		ifNil: [AllChangeSets _ OrderedCollection new].
	self gatherChangeSets.

	"ChangeSorter initialize"

	FileList registerFileReader: self.
! !


!ContextVariablesInspector methodsFor: 'accessing' stamp: 'jmv 3/1/2010 09:51'!
fieldList 
	"Refer to the comment in Inspector|fieldList."

	object
		ifNil: [^ Array with: 'thisContext'].
	^fieldList ifNil:[fieldList := (Array with: 'thisContext' with: 'stack top' with: 'all temp vars') , object tempNames]! !


!Debugger methodsFor: 'initialize' stamp: 'jmv 3/1/2010 09:53'!
windowIsClosing
	"My window is being closed; clean up. Restart the low space watcher."

	interruptedProcess
		ifNil: [^ self].
	interruptedProcess terminate.
	interruptedProcess _ nil.
	contextStack _ nil.
	contextStackTop _ nil.
	receiverInspector _ nil.
	contextVariablesInspector _ nil.
	Smalltalk installLowSpaceWatcher.  "restart low space handler"
! !

!Debugger methodsFor: 'accessing' stamp: 'jmv 3/1/2010 09:51'!
contents 
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information.  This information is the
	method in the currently selected context."

	contents
		ifNil: [^ String new].
	^ contents copy! !

!Debugger methodsFor: 'accessing' stamp: 'jmv 3/1/2010 09:52'!
stringContents 
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information.  This information is the
	method in the currently selected context."

	contents
		ifNil: [^ String new].
	^ contents copy! !

!Debugger methodsFor: 'dependents access' stamp: 'jmv 3/1/2010 09:52'!
updateInspectors 
	"Update the inspectors on the receiver's variables."

	receiverInspector
		ifNotNil: [receiverInspector update].
	contextVariablesInspector
		ifNotNil: [contextVariablesInspector update]! !


!Debugger class methodsFor: 'instance creation' stamp: 'jmv 3/1/2010 11:18'!
informExistingDebugger: aContext label: aString
	"Walking the context chain, we try to find out if we're in a debugger stepping situation.
	If we find the relevant contexts, we must rearrange them so they look just like they would
	if the methods were excuted outside of the debugger."
	| ctx quickStepMethod oldSender baseContext |
	ctx _ thisContext.
	quickStepMethod _ ContextPart compiledMethodAt: #quickSend:to:with:super:.
	[ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx _ ctx sender].
	ctx sender ifNil: [^self].
	baseContext _ ctx.
	"baseContext is now the context created by the #quickSend... method."
	oldSender _ ctx _ ctx sender home sender.
	"oldSender is the context which originally sent the #quickSend... method"
	[ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx _ ctx sender].
	ctx == nil ifTrue: [^self].
	"ctx is the context of the Debugger method #doStep"
	ctx receiver labelString: aString.
	ctx receiver externalInterrupt: false; proceedValue: aContext receiver.
	baseContext swapSender: baseContext sender sender sender.	"remove intervening contexts"
	thisContext swapSender: oldSender.	"make myself return to debugger"
	ErrorRecursion _ false.
	^aContext! !


!FileContentsBrowser methodsFor: 'class list' stamp: 'jmv 3/1/2010 11:21'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	^self selectedClassName ifNotNil: [ :scn |
		self selectedPackage classAt: scn ]! !


!FileList methodsFor: 'initialization' stamp: 'jmv 3/1/2010 11:23'!
directory: dir
	"Set the path of the volume to be displayed."

	self okToChange ifFalse: [^ self].

	self modelSleep.
	directory _ dir.
	self modelWakeUp.

	sortMode ifNil: [ sortMode _ #date].
	volList _ ((Array with: '[]'), directory pathParts)  "Nesting suggestion from RvL"
			withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each].
	volListIndex := volList size.
	self changed: #relabel.
	self changed: #volumeList.
	self pattern: pattern! !

!FileList methodsFor: 'private' stamp: 'jmv 3/1/2010 11:23'!
defaultContents
	contents _ list
		ifNil: [String new]
		ifNotNil: [String streamContents:
					[:s | s nextPutAll: 'NO FILE SELECTED' translated; cr.
					s nextPutAll: '  -- Folder Summary --' translated; cr.
					list do: [:item | s nextPutAll: item; cr]]].
	brevityState _ #FileList.
	^ contents! !

!FileList methodsFor: 'private' stamp: 'jmv 3/1/2010 11:23'!
readContentsHex: brevity
	"retrieve the contents from the external file unless it is too long.
	  Don't create a file here.  Check if exists."
	| f size data hexData s |

	f := directory oldFileOrNoneNamed: self fullName. 
	f ifNil: [^ 'For some reason, this file cannot be read' translated].
	((size := f size)) > 5000 & brevity
		ifTrue: [data := f next: 10000. f close. brevityState := #briefHex]
		ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex].

	s := WriteStream on: (String new: data size*4).
	0 to: data size-1 by: 16 do:
		[:loc | s nextPutAll: loc hex; space;
			nextPut: $(; print: loc; nextPut: $); space; tab.
		loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) hex; space].
		s cr].
	hexData := s contents.

	^ contents := ((size > 5000) & brevity
		ifTrue: ['File ''{1}'' is {2} bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 5000 characters...
------------------------------------------
{3}
------------------------------------------
... end of the first 5000 characters.' translated format: {fileName. size. hexData}]
		ifFalse: [hexData]).
! !

!FileList methodsFor: 'private' stamp: 'jmv 3/1/2010 11:24'!
recentDirs
	"Put up a menu and let the user select from the list of recently visited directories."

	| dirName |
	RecentDirs isEmpty ifTrue: [^self].
	dirName := (SelectionMenu selections: RecentDirs) startUp.
	dirName ifNil: [^self].
	self directory: (FileDirectory on: dirName)! !


!FileList2 methodsFor: 'initialization' stamp: 'jmv 3/1/2010 11:25'!
directory: dir
	"Set the path of the volume to be displayed."

	self okToChange ifFalse: [^ self].

	self modelSleep.
	directory _ dir.
	self modelWakeUp.

	sortMode ifNil: [sortMode _ #date].
	volList _ Array with: '[]'.
	directory ifNotNil: [
		volList _ volList, directory pathParts.  "Nesting suggestion from RvL"
	].
	volList _ volList withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each].
	self changed: #relabel.
	self changed: #volumeList.
	self pattern: pattern.
	directoryChangeBlock ifNotNil: [directoryChangeBlock value: directory].! !


!HierarchyBrowser methodsFor: 'initialization' stamp: 'jmv 3/1/2010 11:27'!
selectedClassName
	"Answer the name of the class currently selected.   di
	  bug fix for the case where name cannot be found -- return nil rather than halt"

	| aName |
	aName _ super selectedClassName.
	^ aName
		ifNotNil: [(aName copyWithout: $ ) asSymbol]! !


!MessageSet methodsFor: 'class list' stamp: 'jmv 3/1/2010 11:35'!
selectedClass 
	"Return the base class for the current selection.  1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected"

	^ self selectedClassOrMetaClass
		ifNotNil: [ :c | c theNonMetaClass]! !

!MessageSet methodsFor: 'contents' stamp: 'jmv 3/1/2010 11:36'!
stringContents
	"Answer the contents of the receiver"

	^ contents
		ifNil: [currentCompiledMethod _ nil. '']
		ifNotNil: [messageListIndex = 0 
			ifTrue: [currentCompiledMethod _ nil. contents]
			ifFalse: [self showingByteCodes
				ifTrue: [self selectedBytecodes]
				ifFalse: [self selectedMessage]]]! !

!MessageSet methodsFor: 'private' stamp: 'jmv 3/1/2010 11:34'!
contents: aString notifying: aController 
	"Compile the code in aString. Notify aController of any syntax errors. 
	Answer false if the compilation fails. Otherwise, if the compilation 
	created a new method, deselect the current selection. Then answer true."

	| category selector class oldSelector |
	self okayToAccept ifFalse: [^ false].
	self setClassAndSelectorIn: [:c :os | class _ c.  oldSelector _ os].
	class ifNil: [^ false].
	(oldSelector ~~ nil and: [oldSelector first isUppercase]) ifTrue:
		[oldSelector = #Comment ifTrue:
			[class comment: aString stamp: Utilities changeStamp.
			self changed: #annotation.
 			self clearUserEditFlag.
			^ false].
		oldSelector = #Definition ifTrue:
			["self defineClass: aString notifying: aController."
			class subclassDefinerClass
				evaluate: aString
				notifying: aController
				logged: true.
			self clearUserEditFlag.
 			^ false].
		oldSelector = #Hierarchy ifTrue:
			[self inform: 'To change the hierarchy, edit the class definitions'. 
			^ false]].
	"Normal method accept"
	category _ class organization categoryOfElement: oldSelector.
	selector _ class compile: aString
				classified: category
				notifying: aController.
	selector
		ifNil: [^ false].
	selector == oldSelector ifFalse:
		[self reformulateListNoting: selector].
	contents _ aString copy.
	self changed: #annotation.
	^ true! !


!MethodHolder methodsFor: 'contents' stamp: 'jmv 3/1/2010 11:49'!
contents: input notifying: aController 
	| selector |
	(selector _ Smalltalk actualParserClass new parseSelector: input asText) ifNil:
		[self inform: 'Sorry - invalid format for the 
method name and arguments -- cannot accept.'.
		^ false].

	selector == methodSelector ifFalse:
		[self inform:
'You cannot change the name of
the method here -- it must continue
to be ', methodSelector.
		^ false].

	selector _ methodClass
				compile: input asText
				classified: self selectedMessageCategoryName
				notifying: aController.
	selector
		ifNil: [^ false].
	contents _ input asString copy.
	currentCompiledMethod _ methodClass compiledMethodAt: methodSelector.
	^ true! !


!ParseNode methodsFor: 'printing' stamp: 'jmv 3/1/2010 11:51'!
printCommentOn: aStream indent: indent 
	| thisComment |
	self comment
		ifNil: [^ self].
	1 to: self comment size
	   do: [:index |
		index > 1 ifTrue: [aStream crtab: indent].
		aStream nextPut: $".
		thisComment := self comment at: index.
		self printSingleComment: thisComment
			on: aStream
			indent: indent.
		aStream nextPut: $"]! !


!BlockNode methodsFor: 'code generation (closures)' stamp: 'jmv 2/28/2010 22:56'!
addRemoteTemp: aTempVariableNode rootNode: rootNode "<MethodNode>"
	"Add aTempVariableNode to my actualScope's sequence of
	 remote temps.  If I am an optimized block then the actual
	 scope is my actualScopeIfOptimized, otherwise it is myself."
	(temporaries is: #Array) ifTrue: [
		temporaries := temporaries asOrderedCollection].
	remoteTempNode ifNil: [
		remoteTempNode := RemoteTempVectorNode new
								name: self remoteTempNodeName
								index: arguments size + temporaries size
								type: LdTempType
								scope: 0.
		 actualScopeIfOptimized
			ifNil:
				[temporaries addLast: remoteTempNode.
				 remoteTempNode definingScope: self]
			ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]].
	remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder.
	"use remove:ifAbsent: because the deferred analysis for optimized
	 loops can result in the temp has already been hoised into the root."
	temporaries remove: aTempVariableNode ifAbsent: [].
	^remoteTempNode! !

!BlockNode methodsFor: 'printing' stamp: 'jmv 2/28/2010 22:56'!
printStatementsOn: aStream indent: levelOrZero
	| len shown thisStatement level |
	level := 1 max: levelOrZero.
	comment ifNotNil: [
		self printCommentOn: aStream indent: level.
		aStream crtab: level].
	len := shown := statements size.
	(levelOrZero = 0 "top level" and: [statements last isReturnSelf])
		ifTrue: [shown := 1 max: shown - 1]
		ifFalse: ["should a trailing nil be printed or not? Not if it is an implicit result."
				(arguments size = 0
				and: [len >= 1
				and: [(statements at: len) == NodeNil
				and: [len = 1
					or: [len > 1
						and: [(statements at: len - 1) isMessageNode
						and: [(statements at: len - 1) isNilIf]]]]]])
					ifTrue: [shown := shown - 1]].
	1 to: shown do: 
		[:i | 
		thisStatement := statements at: i.
		thisStatement printOn: aStream indent: level.
		i < shown ifTrue: [aStream nextPut: $.; crtab: level].
		(thisStatement comment ~~ nil and: [thisStatement comment size > 0])
			ifTrue: 
				[i = shown ifTrue: [aStream crtab: level].
				thisStatement printCommentOn: aStream indent: level.
				i < shown ifTrue: [aStream crtab: level]]]! !

!BlockNode methodsFor: 'printing' stamp: 'jmv 2/28/2010 22:57'!
printWithClosureAnalysisStatementsOn: aStream indent: levelOrZero
	| len shown thisStatement level |
	level := 1 max: levelOrZero.
	comment ifNotNil: [
		self printCommentOn: aStream indent: level.
		aStream crtab: level].
	len := shown := statements size.
	(levelOrZero = 0 "top level" and: [statements last isReturnSelf])
		ifTrue: [shown := 1 max: shown - 1]
		ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)])
					ifTrue: [shown := shown - 1]].
	1 to: shown do: 
		[:i | 
		thisStatement := statements at: i.
		thisStatement printWithClosureAnalysisOn: aStream indent: level.
		i < shown ifTrue: [aStream nextPut: $.; crtab: level].
		(thisStatement comment ~~ nil and: [thisStatement comment size > 0])
			ifTrue: 
				[i = shown ifTrue: [aStream crtab: level].
				thisStatement printCommentOn: aStream indent: level.
				i < shown ifTrue: [aStream crtab: level]]]! !


!Encoder methodsFor: 'encoding' stamp: 'jmv 3/1/2010 11:18'!
environment
	"Answer the environment of the current compilation context,
	 be it in a class or global (e.g. a workspace)"
	^Smalltalk "No environments in Cuis..."! !

!Encoder methodsFor: 'error handling' stamp: 'jmv 3/1/2010 09:59'!
notify: string
	"Put a separate notifier on top of the requestor's window"
	| req |
	requestor
		ifNotNil: [
			req _ requestor.
			self release.
			req notify: string].
	^false! !

!Encoder methodsFor: 'error handling' stamp: 'jmv 3/1/2010 09:59'!
notify: string at: location

	| req |
	requestor
		ifNotNil: [
			req _ requestor.
			self release.
			req notify: string at: location].
	^false! !


!MessageNode methodsFor: 'code generation (closures)' stamp: 'jmv 3/1/2010 11:31'!
analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>"
	"Assignments within optimized loops are tricky.  Because a loop repeats a
	 write to a temporary in an optimized loop effectively occurs after the loop.
	 To handle this collect the set of temps assigned to in optimized loops and
	 add extra writes after traversing the optimized loop constituents."
	| writtenToTemps |
	self isOptimizedLoop ifTrue:
		[{ receiver }, arguments do:
			[:node|
			(node notNil and: [node isBlockNode and: [node optimized]]) ifTrue:
				[assignmentPools at: node put: Set new]]].
	"receiver is nil in cascades"
	receiver ifNotNil: [
		receiver analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools].
	arguments do:
		[:node|
		node == nil ifFalse: "last argument of optimized to:do: can be nil"
			[node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]].
	"Add assignments representing subsequent iterations
	 and redo the closure analysis for the written-to temps."
	self isOptimizedLoop ifTrue:
		[writtenToTemps := Set new.
		 { receiver }, arguments do:
			[:node|
			(node notNil and: [node isBlockNode and: [node optimized]]) ifTrue:
				[(assignmentPools removeKey: node) do:
					[:temp|
					temp isBlockArg ifFalse: "ignore added assignments to to:do: loop args"
						[writtenToTemps add: temp.
						 temp addWriteWithin: node at: rootNode locationCounter]]]].
		 writtenToTemps isEmpty ifFalse:
			[(writtenToTemps asSortedCollection: ParseNode tempSortBlock) do:
				[:each| each analyseClosure: rootNode].
			 (writtenToTemps collect: [:each| each definingScope]) do:
				[:blockNode|
				blockNode ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode]]]! !

!MessageNode methodsFor: 'code generation' stamp: 'jmv 3/1/2010 11:31'!
emitToDo: stack on: strm value: forValue 
	" var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: "
	| loopSize initStmt limitInit test block incStmt blockSize |
	initStmt := arguments at: 4.
	limitInit := arguments at: 7.
	test := arguments at: 5.
	block := arguments at: 3.
	incStmt := arguments at: 6.
	blockSize := sizes at: 1.
	loopSize := sizes at: 2.
	limitInit
		ifNotNil: [limitInit emitForEffect: stack on: strm].
	initStmt emitForEffect: stack on: strm.
	test emitForValue: stack on: strm.
	self emitBranchOn: false dist: blockSize pop: stack on: strm.
	pc := strm position.
	block emitForEvaluatedEffect: stack on: strm.
	incStmt emitForEffect: stack on: strm.
	self emitJump: 0 - loopSize on: strm.
	forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! !

!MessageNode methodsFor: 'code generation' stamp: 'jmv 3/1/2010 11:32'!
sizeForValue: encoder
	| total argSize |
	special > 0 
		ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true].
	receiver == NodeSuper
		ifTrue: [selector := selector copy "only necess for splOops"].
	total := selector size: encoder args: arguments size super: receiver == NodeSuper.
	receiver ifNotNil: [
		total := total + (receiver sizeForValue: encoder)].
	sizes := arguments collect: 
					[:arg | 
					argSize := arg sizeForValue: encoder.
					total := total + argSize.
					argSize].
	^total! !

!MessageNode methodsFor: 'code generation' stamp: 'jmv 3/1/2010 11:33'!
sizeToDo: encoder value: forValue 
	" var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: "
	| loopSize initStmt test block incStmt blockSize blockVar initSize limitInit |
	block := arguments at: 3.
	blockVar := block firstArgument.
	initStmt := arguments at: 4.
	test := arguments at: 5.
	incStmt := arguments at: 6.
	limitInit := arguments at: 7.
	initSize := initStmt sizeForEffect: encoder.
	limitInit ifNotNil: [
		initSize := initSize + (limitInit sizeForEffect: encoder)].
	blockSize := (block sizeForEvaluatedEffect: encoder)
			+ (incStmt sizeForEffect: encoder) + 2.  "+2 for Jmp backward"
	loopSize := (test sizeForValue: encoder)
			+ (self sizeBranchOn: false dist: blockSize)
			+ blockSize.
	sizes := Array with: blockSize with: loopSize.
	^ initSize + loopSize
			+ (forValue ifTrue: [1] ifFalse: [0])    " +1 for value (push nil) "! !

!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/1/2010 11:31'!
emitCodeForToDo: stack encoder: encoder value: forValue 
	" var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: "
	| loopSize initStmt limitInit test block incStmt blockSize |
	initStmt := arguments at: 4.
	limitInit := arguments at: 7.
	test := arguments at: 5.
	block := arguments at: 3.
	incStmt := arguments at: 6.
	blockSize := sizes at: 1.
	loopSize := sizes at: 2.
	limitInit
		ifNotNil: [limitInit emitCodeForEffect: stack encoder: encoder].
	initStmt emitCodeForEffect: stack encoder: encoder.
	test emitCodeForValue: stack encoder: encoder.
	self emitCodeForBranchOn: false dist: blockSize pop: stack encoder: encoder.
	pc := encoder methodStreamPosition.
	block emitCodeForEvaluatedEffect: stack encoder: encoder.
	incStmt emitCodeForEffect: stack encoder: encoder.
	self emitCodeForJump: 0 - loopSize encoder: encoder.
	forValue ifTrue: [encoder genPushSpecialLiteral: nil. stack push: 1]! !

!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/1/2010 11:32'!
sizeCodeForToDo: encoder value: forValue 
	" var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: "
	| loopSize initStmt test block incStmt blockSize initSize limitInit |
	block := arguments at: 3.
	initStmt := arguments at: 4.
	test := arguments at: 5.
	incStmt := arguments at: 6.
	limitInit := arguments at: 7.
	initSize := initStmt sizeCodeForEffect: encoder.
	limitInit ifNotNil: [
		initSize := initSize + (limitInit sizeCodeForEffect: encoder)].
	blockSize := (block sizeCodeForEvaluatedEffect: encoder)
			+ (incStmt sizeCodeForEffect: encoder)
			+ (encoder sizeJumpLong: -1).
	loopSize := (test sizeCodeForValue: encoder)
			+ (self sizeCode: encoder forBranchOn: false dist: blockSize)
			+ blockSize.
	sizes := Array with: blockSize with: loopSize.
	^initSize
	+ loopSize
	+ (forValue ifTrue: [encoder sizePushSpecialLiteral: nil] ifFalse: [0])! !

!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'jmv 3/1/2010 11:32'!
sizeCodeForValue: encoder
	| total argSize |
	special > 0 
		ifTrue: [^self perform: (NewStyleMacroSizers at: special) with: encoder with: true].
	receiver == NodeSuper
		ifTrue: [selector := selector copy "only necess for splOops"].
	total := selector sizeCode: encoder args: arguments size super: receiver == NodeSuper.
	receiver ifNotNil: [
		total := total + (receiver sizeCodeForValue: encoder)].
	sizes := arguments collect: 
					[:arg | 
					argSize := arg sizeCodeForValue: encoder.
					total := total + argSize.
					argSize].
	^total! !


!MethodNode methodsFor: 'printing' stamp: 'jmv 3/1/2010 11:49'!
printOn: aStream
	| selectorNode |
	selectorNode := self selectorNode.
	precedence = 1
		ifTrue:
			[selectorNode isForFFICall
				ifTrue: [selectorNode
							printAsFFICallWithArguments: arguments
							on: aStream
							indent: 0]
				ifFalse: [aStream nextPutAll: selectorNode key]]
		ifFalse:
			[selectorNode key keywords with: arguments do:
				[:kwd :arg |
				aStream nextPutAll: kwd; space; nextPutAll: arg key; space]].
	comment ifNotNil: [
		aStream crtab: 1.
		self printCommentOn: aStream indent: 1].
	block printTemporaries: temporaries on: aStream doPrior: [aStream crtab: 1].
	primitive > 0 ifTrue:
		[(primitive between: 255 and: 519) ifFalse:  "Dont decompile quick prims  e.g, ^ self or ^instVar"
			[aStream crtab: 1.
			 self printPrimitiveOn: aStream]].
	self printPropertiesOn: aStream.
	self printPragmasOn: aStream.
	aStream crtab: 1.
	block printStatementsOn: aStream indent: 0! !

!MethodNode methodsFor: 'printing' stamp: 'jmv 3/1/2010 11:50'!
printWithClosureAnalysisOn: aStream 

	precedence = 1
		ifTrue: 
			[(self selector includesSubString: '()/')
				ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)).
						arguments
							do: [:arg| aStream nextPutAll: arg key]
							separatedBy: [aStream nextPutAll: ', '].
						aStream nextPut: $)]
				ifFalse: [aStream nextPutAll: self selector]]  "no node for method selector"
		ifFalse: 
			[self selector keywords with: arguments do: 
				[:kwd :arg | 
				aStream nextPutAll: kwd; space.
				arg printDefinitionForClosureAnalysisOn: aStream.
				aStream space]].
	comment ifNotNil: [
			aStream crtab: 1.
			self printCommentOn: aStream indent: 1].
	temporaries size > 0 ifTrue: [
			aStream crtab: 1; nextPut: $|.
			temporaries do: [ :temp | 
				aStream space.
				temp printDefinitionForClosureAnalysisOn: aStream].
			aStream space; nextPut: $|].
	primitive > 0 ifTrue: [
		(primitive between: 255 and: 519) ifFalse: [ "Dont decompile quick prims  e.g, ^ self or ^instVar"
			aStream crtab: 1.
			self printPrimitiveOn: aStream]].
	self printPropertiesOn: aStream.
	self printPragmasOn: aStream.
	aStream crtab: 1.
	block printWithClosureAnalysisStatementsOn: aStream indent: 0! !


!PolygonMorph methodsFor: 'drawing' stamp: 'jmv 3/1/2010 13:09'!
drawOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight line segments."
	| lineColor bevel topLeftColor bottomRightColor bigClipRect brush p1i p2i |
	vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point'].
	closed & color isTransparent not ifTrue:
		[self filledForm colors: (Array with: Color transparent with: color).
		aCanvas image: self filledForm at: bounds topLeft-1].
	lineColor _ borderColor.  bevel _ false.
	"Border colors for bevelled effects depend on CW ordering of vertices"
	borderColor == #raised ifTrue: [topLeftColor _ color lighter.
						bottomRightColor _ color darker.  bevel _ true].
	borderColor == #inset ifTrue: [topLeftColor _ owner colorForInsets darker.
						bottomRightColor _ owner colorForInsets lighter.  bevel _ true].
	bigClipRect _ aCanvas clipRect expandBy: self borderWidth+1//2.
	brush _ nil.
	self lineSegmentsDo:
		[:p1 :p2 | p1i _ p1 asIntegerPoint.  p2i _ p2 asIntegerPoint.
		(closed or: ["bigClipRect intersects: (p1i rect: p2i) optimized:"
					((p1i min: p2i) max: bigClipRect origin) <=
					((p1i max: p2i) min: bigClipRect corner)]) ifTrue:
			[bevel ifTrue: [((p1i quadrantOf: p2i) > 2)
						ifTrue: [lineColor _ topLeftColor]
						ifFalse: [lineColor _ bottomRightColor]].
			(borderWidth > 3 and: [borderColor is: #Color])
			ifTrue: [brush ifNil: [
						brush _ (ColorForm dotOfSize: borderWidth)
								colors: (Array with: Color transparent with: borderColor)].
					aCanvas line: p1i to: p2i brushForm: brush]
			ifFalse: [aCanvas line: p1i to: p2i
							width: borderWidth color: lineColor]]].
	self arrowForms ifNotNil:
		[self arrowForms do:
			[:f | f colors: (Array with: Color transparent with: borderColor).
			aCanvas image: f at: f offset]]
! !


!PopUpMenu methodsFor: 'private' stamp: 'jmv 3/1/2010 13:10'!
rescan
	"Cause my form to be recomputed after a font change."

	labelString ifNil: [labelString _ 'NoText!!'].
	self labels: labelString lines: lineArray.

	"PopUpMenu allSubInstancesDo: [:m | m rescan]"! !


!PositionableStream methodsFor: 'accessing' stamp: 'jmv 3/1/2010 13:10'!
next: n into: aCollection startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| obj |
	0 to: n-1 do: [ :i |
		(obj _ self next) ifNil: [ ^aCollection copyFrom: 1 to: startIndex+i-1 ].
		aCollection at: startIndex+i put: obj].
	^aCollection! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 2/28/2010 22:40'!
nextWord
	"Answer the next two bytes from the receiver as an Integer."

	| high low |
	high _ self next.
		high ifNil: [^false].
	low _ self next.
		low ifNil: [^false].
	^(high asInteger bitShift: 8) + low asInteger! !


!DeflateStream methodsFor: 'deflating' stamp: 'jmv 3/1/2010 09:56'!
deflateBlock
	"Deflate the current contents of the stream"
	| flushNeeded lastIndex |
	blockStart ifNil: [
		"One time initialization for the first block"
		1 to: MinMatch-1 do:[:i| self updateHashAt: i].
		blockStart _ 0].

	[blockPosition < position] whileTrue:[
		(position + MaxMatch > writeLimit)
			ifTrue:[lastIndex _ writeLimit - MaxMatch]
			ifFalse:[lastIndex _ position].
		flushNeeded _ self deflateBlock: lastIndex-1
							chainLength: self hashChainLength
							goodMatch: self goodMatchLength.
		flushNeeded ifTrue:[
			self flushBlock.
			blockStart _ blockPosition].
		"Make room for more data"
		self moveContentsToFront].
! !


!InflateStream methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:29'!
next: n into: buffer startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| c numRead count |
	numRead _ 0.
	["Force decompression if necessary"
	(c _ self next)
		ifNil: [ ^buffer copyFrom: 1 to: startIndex+numRead-1 ].
	"Store the first value which provoked decompression"
	buffer at: startIndex + numRead put: c.
	numRead _ numRead + 1.
	"After collection has been filled copy as many objects as possible"
	count _ (readLimit - position) min: (n - numRead).
	buffer 
		replaceFrom: startIndex + numRead 
		to: startIndex + numRead + count - 1 
		with: collection 
		startingAt: position+1.
	position _ position + count.
	numRead _ numRead + count.
	numRead = n] whileFalse.
	^buffer! !

!InflateStream methodsFor: 'testing' stamp: 'jmv 3/1/2010 11:28'!
atEnd
	"Note: It is possible that we have a few bits left,
	representing just the EOB marker. To check for
	this we must force decompression of the next
	block if at end of data."
	super atEnd ifFalse:[^false]. "Primitive test"
	(position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true].
	"Force decompression, by calling #next. Since #moveContentsToFront
	will never move data to the beginning of the buffer it is safe to
	skip back the read position afterwards"
	self next
		ifNil: [^ true].
	position _ position - 1.
	^false! !

!InflateStream methodsFor: 'inflating' stamp: 'jmv 3/1/2010 11:29'!
proceedStoredBlock
	"Proceed decompressing a stored (e.g., uncompressed) block"
	| length decoded |
	"Literal table must be nil for a stored block"
	litTable
		ifNotNil: [^ self error: 'Bad state'].
	length _ distTable.
	[length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]] 
		whileTrue:[
			collection at: (readLimit _ readLimit + 1) put: 
				(source at: (sourcePos _ sourcePos + 1)).
			length _ length - 1].
	length = 0 ifTrue:[state _ state bitAnd: StateNoMoreData].
	decoded _ length - distTable.
	distTable _ length.
	^decoded! !

!InflateStream methodsFor: 'private' stamp: 'jmv 3/1/2010 11:29'!
getFirstBuffer
	"Get the first source buffer after initialization has been done"
	sourceStream
		ifNil: [^ self].
	source _ sourceStream next: 1 << 16. "This is more than enough..."
	sourceLimit _ source size! !

!InflateStream methodsFor: 'bit access' stamp: 'jmv 3/1/2010 11:28'!
bitPosition
	"Return the current bit position of the source"
	^sourceStream
		ifNil: [sourcePos * 8 + bitPos]
		ifNotNil: [sourceStream position + sourcePos * 8 + bitPos]! !


!ProcessorScheduler class methodsFor: 'background process' stamp: 'jmv 3/1/2010 13:11'!
startUp
	"Install a background process of the lowest possible priority that is always runnable."
	"Details: The virtual machine requires that there is aways some runnable process that can be scheduled; this background process ensures that this is the case."

	Smalltalk installLowSpaceWatcher.
	BackgroundProcess ifNotNil: [BackgroundProcess terminate].
	BackgroundProcess _ [self idleProcess] newProcess.
	BackgroundProcess priority: SystemRockBottomPriority.
	BackgroundProcess resume.
! !


!PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'jmv 3/1/2010 13:12'!
classComment
	"Answer the comment associated with the object that refers to the receiver."
	^classComment ifNil: [ '' ]! !


!Rectangle class methodsFor: 'instance creation' stamp: 'jmv 3/1/2010 13:13'!
encompassing: listOfPoints
	"A number of callers of encompass: should use this method."
	| topLeft bottomRight |
	topLeft _ bottomRight _ nil.
	listOfPoints do: [ :p |
		topLeft
			ifNil: [ topLeft _ bottomRight _ p]
			ifNotNil: [
				topLeft _ topLeft min: p.
				bottomRight _ bottomRight max: p]].
	^ topLeft corner: bottomRight! !


!ReferenceStream methodsFor: 'statistics' stamp: 'jmv 3/1/2010 13:15'!
statisticsOfRefs
	"Analyze the information in references, the objects being written out"

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


!RemoteString methodsFor: 'private' stamp: 'jmv 3/1/2010 13:14'!
string: aString onFileNumber: fileNumber
	"Store this as my string if source files exist."
	| theFile |
	(SourceFiles at: fileNumber) ifNotNil: [
		theFile _ SourceFiles at: fileNumber.
		theFile setToEnd; cr.
		self string: aString onFileNumber: fileNumber toFile: theFile]! !


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


!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 3/1/2010 13:17'!
xDoubleQuote
    "Collect a comment."
    "wod 1/10/98: Allow 'empty' comments by testing the first character
for $"" rather than blindly adding it to the comment being collected."
    | aStream stopChar |
    stopChar := 30 asCharacter.
    aStream := WriteStream on: (String new: 200).
    self step.
    [hereChar == $"]
        whileFalse: [
            (hereChar == stopChar and: [source atEnd])
                ifTrue: [^self offEnd: 'Unmatched comment quote'].
            aStream nextPut: self step.].
    self step.
    currentComment
        ifNil: [currentComment := OrderedCollection with: aStream contents]
        ifNotNil: [currentComment add: aStream contents].
    self scanToken! !


!Parser methodsFor: 'error handling' stamp: 'jmv 3/1/2010 11:52'!
offEnd: aString 
	"Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!"

	^self notify: aString at: mark + (requestorOffset ifNil: [0])! !

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

!Parser methodsFor: 'primitives' stamp: 'jmv 3/1/2010 11:51'!
externalType: descriptorClass
	"Parse an return an external type"
	| xType |
	xType := descriptorClass atomicTypeNamed: here.
	xType ifNil: ["Look up from class scope"
		Symbol hasInterned: here ifTrue:[:sym|
			xType := descriptorClass structTypeNamed: sym]].
	xType == nil ifTrue:[
		"Raise an error if user is there"
		self interactive ifTrue:[^nil].
		"otherwise go over it silently"
		xType := descriptorClass forceTypeNamed: here].
	self advance.
	(self matchToken:#*)
		ifTrue:[^xType asPointerType]
		ifFalse:[^xType]! !

!Parser methodsFor: 'expression types' stamp: 'jmv 3/1/2010 11:53'!
pattern: fromDoit inContext: ctxt
	" unarySelector | binarySelector arg | keyword arg {keyword arg} =>
	{selector, arguments, precedence}."
	| args selector |
	doitFlag := fromDoit.
	fromDoit ifTrue:
		[^ctxt
			ifNil: [{#DoIt. {}. 1}]
			ifNotNil: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3}]].

	hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}].

	(hereType == #binary or: [hereType == #verticalBar]) ifTrue: 
		[selector := self advance asSymbol.
		args := Array with: (encoder bindArg: self argumentName).
		^ {selector. args. 2}].

	hereType == #keyword ifTrue: 
		[selector := WriteStream on: (String new: 32).
		args := OrderedCollection new.
		[hereType == #keyword] whileTrue:[
			selector nextPutAll: self advance.
			args addLast: (encoder bindArg: self argumentName).
		].
		^ {selector contents asSymbol. args. 3}].
	hereType == #positionalMessage ifTrue:[
		args := OrderedCollection new.
		selector := self advance.
		hereType == #rightParenthesis ifTrue:[self advance. ^{(selector,'/0') asSymbol. args. 1}].
		[
			args addLast: (encoder bindArg: self argumentName).
			hereType == #rightParenthesis ifTrue:[
				self advance. 
				selector := (selector,'/', args size printString) asSymbol.
				^{selector. args. 1}].
			here == #, ifFalse:[self expected: 'comma'].
			self advance.
		] repeat.
	].
	^self expected: 'Message pattern'! !

!Parser methodsFor: 'public access' stamp: 'jmv 3/1/2010 11:53'!
parseArgsAndTemps: aString notifying: req 
        "Parse the argument, aString, notifying req if an error occurs. Otherwise, 
        answer a two-element Array containing Arrays of strings (the argument 
        names and temporary variable names)."

        aString ifNil: [^#()].
        doitFlag := false.               "Don't really know if a doit or not!!"
        ^self initPattern: aString
                notifying: req
                return: [:pattern | (pattern at: 2) , (self temporariesIn: (pattern at: 1))]! !

!Parser methodsFor: 'public access' stamp: 'jmv 2/28/2010 22:38'!
parseMethodComment: aString setPattern: aBlock
	"Answer the method comment for the argument, aString. Evaluate aBlock 
	with the message pattern in the form #(selector, arguments, precedence)."

	self
		initPattern: aString
		notifying: nil
		return: aBlock.
	^currentComment
		ifNil: [ OrderedCollection new ]! !


!Scanner class methodsFor: 'testing' stamp: 'jmv 3/1/2010 13:17'!
isLiteralSymbol: aSymbol 
	"Test whether a symbol can be stored as # followed by its characters.  
	Symbols created internally with asSymbol may not have this property, 
	e.g. '3' asSymbol."

	| i ascii type next last |
	i := aSymbol size.
	i = 0 ifTrue: [^ false].

	"TypeTable should have been origined at 0 rather than 1 ..."
	ascii := (aSymbol at: 1) asciiValue.
	type := TypeTable at: ascii ifAbsent: [^false].
	type == #xLetter ifTrue: [
		next := last := nil.
		[i > 1]
				whileTrue: 
					[ascii := (aSymbol at: i) asciiValue.
					type := TypeTable at: ascii ifAbsent: [^false].
					(type == #xLetter or: [type == #xDigit or: [type == #xColon
							and: [
								next
									ifNil: [last := #xColon. true] 
									ifNotNil: [last == #xColon and: [next ~~ #xDigit and: [next ~~ #xColon]]]]]])
						ifFalse: [^ false].
					next := type.
					i := i - 1].
			^ true].	
	type == #xBinary ifTrue: [^i = 1]. "Here we could extend to
		^(2 to: i) allSatisfy: [:j |
			ascii := (aSymbol at: j) asciiValue.
			(TypeTable at: ascii ifAbsent: []) == #xBinary]"
	type == #verticalBar ifTrue: [^i = 1].
	^false! !


!ScorePlayer methodsFor: 'sound generation' stamp: 'jmv 3/1/2010 13:18'!
skipNoteEventsThruTick: startTick
	"Skip note events through the given score tick using internal Squeak sound synthesis."

	| j evt |
	1 to: score tracks size do: [:i |
		j _ trackEventIndex at: i.
		[evt _ score eventForTrack: i after: j ticks: startTick.
		 evt == nil] whileFalse: [
			evt isNoteEvent
				ifTrue: [
					(((evt time + evt duration) > startTick) and: [(muted at: i) not]) ifTrue: [
						self startNote: evt forStartTick: startTick trackIndex: i]]
				ifFalse: [
					midiPort ifNotNil: [evt outputOnMidiPort: midiPort]].
			j _ j + 1].
		trackEventIndex at: i put: j].
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jmv 3/1/2010 13:17'!
durationInTicks

	durationInTicks ifNil: [^ 1000].
	^ durationInTicks! !


!ScrollPane methodsFor: 'menu' stamp: 'jmv 3/1/2010 13:18'!
getMenu: shiftKeyState
	"Answer the menu for this text view, 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 aMenu aTitle |
	getMenuSelector ifNil: [^ nil].
	menu _ MenuMorph new defaultTarget: model.
	aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
	getMenuSelector numArgs = 1 ifTrue: [
		aMenu _ model perform: getMenuSelector with: menu.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	getMenuSelector numArgs = 2 ifTrue: [
		aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	^ self error: 'The getMenuSelector has an unsupported number of arguments'! !


!PluggableListMorph methodsFor: 'model access' stamp: 'jmv 3/1/2010 11:56'!
getList
	"Answer the list to be displayed.  Caches the returned list in the 'list' ivar"
	getListSelector
		ifNil: [^ #()].
	list _ model perform: getListSelector.
	list
		ifNil: [^ #()].
	list _ list collect: [ :item | item asStringOrText ].
	^ list! !


!PluggableListMorphByItem methodsFor: 'model access' stamp: 'jmv 3/1/2010 11:57'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector ifNil: [^ 0].
	item _ model perform: getIndexSelector.
	^ list findFirst: [ :x | x = item]
! !


!PluggableMessageCategoryListMorph methodsFor: 'model access' stamp: 'jmv 3/1/2010 11:57'!
getList
	"Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser.  This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method"

	getRawListSelector ifNil: ["should not happen!!" priorRawList _ nil.  ^ #()].
	model classListIndex = 0 ifTrue: [^ priorRawList _ list _ Array new].
	priorRawList _ model perform: getRawListSelector.
	list := (Array with: ClassOrganizer allCategory), priorRawList.
	^list! !


!PluggableTextMorph methodsFor: 'menu' stamp: 'jmv 3/1/2010 11:59'!
getMenu: shiftKeyState
	"Answer the menu for this text view, 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. The third argument, if required, is the editorClass."
	| menu aMenu aTitle |
	getMenuSelector
		ifNil: [^ nil].
	getMenuSelector numArgs = 3 ifFalse: [
		^super getMenu: shiftKeyState ].
	
	menu _ MenuMorph new defaultTarget: model.
	aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
	aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState with: editorClass.
	aTitle ifNotNil:  [aMenu addTitle: aTitle].
	^ aMenu! !


!SelectorNode methodsFor: 'printing' stamp: 'jmv 2/28/2010 22:41'!
printOn: aStream indent: level 
	aStream nextPutAll: (key
							ifNil: ['<key==nil>']
							ifNotNil: [key])! !

!SelectorNode methodsFor: 'printing' stamp: 'jmv 2/28/2010 22:41'!
printWithClosureAnalysisOn: aStream indent: level 
	aStream nextPutAll: (key
							ifNil: ['<key==nil>']
							ifNotNil: [key])! !


!Set methodsFor: 'accessing' stamp: 'jmv 3/1/2010 13:18'!
atRandom: aGenerator
	"Answer a random element of the receiver.  Uses aGenerator which
	should be kept by the user in a variable and used every time. Use
	this instead of #atRandom for better uniformity of random numbers 
	because only you use the generator.  Causes an error if self has no 
	elements."
	| ind |
	self emptyCheck.
	ind _ aGenerator nextInt: array size.
	ind to: array size do:[:i|
		(array at: i) ifNotNil: [ ^array at: i]].
	1 to: ind do:[:i|
		(array at: i) ifNotNil: [ ^array at: i]].
	self errorEmptyCollection.! !

!Set methodsFor: 'private' stamp: 'jmv 3/1/2010 13:19'!
grow
	"Grow the elements array and reinsert the old elements"
	| oldElements |
	oldElements _ array.
	array _ Array new: array size + self growSize.
	tally _ 0.
	oldElements do: [ :each |
		each ifNotNil: [self noCheckAdd: each]]! !

!Set methodsFor: 'removing' stamp: 'jmv 3/1/2010 13:19'!
remove: oldObject ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: oldObject.
	(array at: index) ifNil: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ oldObject! !


!Dictionary methodsFor: 'adding' stamp: 'jmv 3/1/2010 09:57'!
add: anAssociation
	| index element |
	index _ self findElementOrNil: anAssociation key.
	element _ array at: index.
	element
		ifNil: [self atNewIndex: index put: anAssociation]
		ifNotNil: [element value: anAssociation value].
	^ anAssociation! !

!Dictionary methodsFor: 'removing' stamp: 'jmv 3/1/2010 09:57'!
removeKey: key ifAbsent: aBlock 
	"Remove key (and its associated value) from the receiver. If key is not in 
	the receiver, answer the result of evaluating aBlock. Otherwise, answer 
	the value externally named by key."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	assoc
		ifNil: [^ aBlock value].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ assoc value! !

!Dictionary methodsFor: 'private' stamp: 'jmv 3/1/2010 09:57'!
keyAt: index
	"May be overridden by subclasses so that fixCollisions will work"
	| assn |
	assn _ array at: index.
	assn ifNil: [^ nil].
	^ assn key! !


!MethodDictionary methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:41'!
at: key ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: key.
	(self basicAt: index) ifNil: [ ^ aBlock value ].
	^ array at: index! !

!MethodDictionary methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:41'!
at: key put: value
	"Set the value at key to be value."
	| index |
	index _ self findElementOrNil: key.
	(self basicAt: index)
		ifNil: [ 
			tally _ tally + 1.
			self basicAt: index put: key]
		ifNotNil: [
			(array at: index) flushCache].
	array at: index put: value.
	self fullCheck.
	^ value! !

!MethodDictionary methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:44'!
keyAtIdentityValue: value ifAbsent: exceptionBlock
	"Answer the key whose value equals the argument, value. If there is
	none, answer the result of evaluating exceptionBlock."

	1 to: self basicSize do:
		[:index |
		value == (array at: index)
			ifTrue: [
				(self basicAt: index)
					ifNotNil: [ :theKey | ^ theKey]]].
	^ exceptionBlock value! !

!MethodDictionary methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:44'!
keyAtValue: value ifAbsent: exceptionBlock
	"Answer the key whose value equals the argument, value. If there is
	none, answer the result of evaluating exceptionBlock."

	1 to: self basicSize do:
		[:index |
		value = (array at: index)
			ifTrue: [
				(self basicAt: index)
					ifNotNil: [ :theKey | ^ theKey]]].
	^ exceptionBlock value! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'jmv 3/1/2010 11:45'!
associationsDo: aBlock 

	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do: [ :i | 
		(self basicAt: i) ifNotNil: [ :key |
			aBlock value: (
				Association key: key value: (array at: i))]]! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'jmv 3/1/2010 11:43'!
keysAndValuesDo: aBlock 
	"Enumerate the receiver with all the keys and values passed to the block"

	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (self basicAt: i) ifNotNil: [ :key |
			aBlock value: key value: (array at: i)]
		]! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'jmv 3/1/2010 11:43'!
keysDo: aBlock

	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (self basicAt: i) ifNotNil: [ :key |
			aBlock value: key]]! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'jmv 3/1/2010 11:48'!
valuesDo: aBlock

	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do: [ :i |
		(array at: i) ifNotNil: [ :value |
			aBlock value: value]]! !

!MethodDictionary methodsFor: 'private' stamp: 'jmv 3/1/2010 11:45'!
grow 
	| newSelf |
	newSelf _ self species new: self basicSize.  "This will double the size"
	1 to: self basicSize do: [ :i |
		(self basicAt: i)
			ifNotNil: [ :key | newSelf at: key put: (array at: i)]].
	self become: newSelf! !

!MethodDictionary methodsFor: 'private' stamp: 'jmv 3/1/2010 11:46'!
rehash 
	| newSelf |
	newSelf _ self species new: self size.
	1 to: self basicSize do: [ :i |
		(self basicAt: i) ifNotNil: [ :key |
			newSelf at: key put: (array at: i)]].
	self become: newSelf! !

!MethodDictionary methodsFor: 'private' stamp: 'jmv 3/1/2010 11:47'!
rehashWithoutBecome
	| newSelf |
	newSelf _ self species new: self size.
	1 to: self basicSize do: [ :i |
		(self basicAt: i) ifNotNil: [ :key |
			newSelf at: key put: (array at: i)]].
	^newSelf! !

!MethodDictionary methodsFor: 'private' stamp: 'jmv 3/1/2010 11:47'!
removeDangerouslyKey: key ifAbsent: aBlock
	"This is not really dangerous.  But if normal removal
	were done WHILE a MethodDict were being used, the
	system might crash.  So instead we make a copy, then do
	this operation (which is NOT dangerous in a copy that is
	not being used), and then use the copy after the removal."

	| index element |
	index _ self findElementOrNil: key.
	(self basicAt: index) ifNil: [ ^ aBlock value ].
	element _ array at: index.
	array at: index put: nil.
	self basicAt: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ element! !


!PluggableDictionary methodsFor: 'private' stamp: 'jmv 3/1/2010 11:56'!
scanFor: anObject 
"Scan the key array for the first slot containing either a nil(indicating 
 an empty slot) or an element that matches anObject. Answer the index 
of that slot or zero if no slot is found. This  method will be overridden   
in various subclasses that have different interpretations for matching 
elements."

	| element start finish |
	start _ (hashBlock
			ifNil: [anObject hash]
			ifNotNil: [hashBlock value: anObject])
				\\ array size + 1.
	finish _ array size.
	"Search from (hash mod size) to the end."
	start to: finish do: [ :index | 
		((element _ array at: index) == nil or: [
			equalBlock
				ifNil: [element key = anObject]
				ifNotNil: [equalBlock value: element key value: anObject]])
			ifTrue: [^ index]].
	"Search from 1 to where we started."
	1 to: start - 1 do: [: index | 
		((element _ array at: index) == nil or: [
			equalBlock
				ifNil: [element key = anObject]
				ifNotNil: [equalBlock value: element key value: anObject]])
			ifTrue: [^ index]].
	^ 0"No match AND no empty slot"! !


!PluggableSet methodsFor: 'private' stamp: 'jmv 3/1/2010 11:59'!
scanFor: anObject 
"Scan the key array for the first slot containing either a nil (indicating 
 an empty slot) or an element that matches anObject. Answer the index 	  
of that slot or zero if no slot is found. This  method will be overridden   
in various subclasses that have different interpretations for matching 
elements."

	| element start finish |
	start _ (hashBlock
			ifNil: [anObject hash]
			ifNotNil: [hashBlock value: anObject])
				\\ array size + 1.
	finish _ array size.
	"Search from (hash mod size) to the end."
	start to: finish do: [ :index | 
		((element _ array at: index) == nil or: [
			equalBlock 
				ifNil: [element = anObject]
				ifNotNil: [equalBlock value: element value: anObject]])
			ifTrue: [^ index]].
	"Search from 1 to where we started."
	1 to: start - 1 do: [ :index | 
		((element _ array at: index) == nil or: [
			equalBlock 
				ifNil: [element = anObject]
				ifNotNil: [equalBlock value: element value: anObject]])
			ifTrue: [^ index]].
	^ 0"No match AND no empty slot"! !


!SmartRefStream methodsFor: 'read write' stamp: 'jmv 3/1/2010 13:30'!
next
	"Really write three objects: (version, class structure, object). But only when called from the outside.  "

	| version ss object |
	^ topCall
		ifNil: [ 
			topCall _ #marked.
			version _ super next.
			version class == SmallInteger ifFalse: [^ version].	
				"version number, else just a regular object, not in our format, "
			self checkCrLf.
			ss _ super next.
			ss class == Array ifFalse: [^ ss].  "just a regular object"
			(ss at: 1) = 'class structure' ifFalse: [^ ss].
			structures _ ss at: 2.
			superclasses _ (ss size > 3 and: [(ss at: 3) = 'superclasses']) 
				ifTrue: [ss at: 4]		"class name -> superclass name"
				ifFalse: [Dictionary new].
			(self verifyStructure = 'conversion method needed') ifTrue: [^ nil].
			object _ super next.	"all the action here"

			topCall _ nil.	"reset it"
			object]
		ifNotNil: [
			super next]
! !

!SmartRefStream methodsFor: 'read write' stamp: 'jmv 3/1/2010 13:31'!
nextPut: anObject
	"Really write three objects: (version, class structure, object).  But only when called from the outside.  If any instance-specific classes are present, prepend their source code.  byteStream will be in fileOut format.
	You can see an analysis of which objects are written out by doing: 
	(SmartRefStream statsOfSubObjects: anObject)
	(SmartRefStream tallyOfSubObjects: anObject)
	(SmartRefStream subObjects: anObject ofClass: aClass)"

| info |
topCall
	ifNil: [
		topCall _ anObject.
		'Please wait while objects are counted' 
			displayProgressAt: Sensor cursorPoint
			from: 0 to: 10
			during: [:bar | info _ self instVarInfo: anObject].
		byteStream binary.
		'Writing an object file' displayProgressAt: Sensor cursorPoint
			from: 0 to: objCount*4	"estimate"
			during: [:bar |
				objCount _ 0.
				progressBar _ bar.
				self setStream: byteStream reading: false.
					"set basePos, but keep any class renames"
				super nextPut: ReferenceStream versionCode.
				super nextPut: info.
				super nextPut: anObject.		"<- the real writing"
				].
					"Note: the terminator, $!!, is not doubled inside object data"
		"references is an IDict of every object that got written"
		byteStream ascii.
		byteStream nextPutAll: '!!'; cr; cr.
		byteStream padToEndWith: $ .	"really want to truncate file, but can't"
		topCall _ progressBar _ nil]	"reset it"
	ifNotNil: [
		super nextPut: anObject.
		progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].
! !

!SmartRefStream methodsFor: 'read write' stamp: 'jmv 3/1/2010 13:31'!
nextPutObjOnly: anObject
	"Really write three objects: (version, class structure, object).  But only when called from the outside.  Not in fileOut format.  No class definitions will be written for instance-specific classes.  Error if find one.  (Use nextPut: instead)"

	| info |
	topCall
		ifNil: [
			topCall _ anObject.
			super nextPut: ReferenceStream versionCode.
			'Please wait while objects are counted' displayProgressAt: Sensor cursorPoint
				from: 0 to: 10
				during: [:bar |
					info _ self instVarInfo: anObject].
			'Writing an object file' displayProgressAt: Sensor cursorPoint
				from: 0 to: objCount*4	"estimate"
				during: [:bar |
					objCount _ 0.
					progressBar _ bar.
					super nextPut: info.
					super nextPut: anObject.	"<- the real writing"
					"Class inst vars not written here!!"].
			"references is an IDict of every object that got written
			(in case you want to take statistics)"
			"Transcript cr; show: structures keys printString."		"debug"
			topCall _ progressBar _ nil]	"reset it"
		ifNotNil: [
			super nextPut: anObject.
			progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].! !


!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:32'!
dataAvailable
	"Return true if this socket has unread received data."

	socketHandle ifNil: [^ false].
	^ self primSocketReceiveDataAvailable: socketHandle
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:32'!
isConnected
	"Return true if this socket is connected."

	socketHandle ifNil: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Connected
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:32'!
isOtherEndClosed
	"Return true if this socket had the other end closed."

	socketHandle ifNil: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:32'!
isThisEndClosed
	"Return true if this socket had the this end closed."

	socketHandle ifNil: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:32'!
isUnconnected
	"Return true if this socket's state is Unconnected."

	socketHandle ifNil: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Unconnected
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:32'!
isUnconnectedOrInvalid
	"Return true if this socket is completely disconnected or is invalid."

	| status |
	socketHandle ifNil: [^ true].
	status _ self primSocketConnectionStatus: socketHandle.
	^ (status = Unconnected) | (status = InvalidSocket)
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:33'!
isWaitingForConnection
	"Return true if this socket is waiting for a connection."

	socketHandle ifNil: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:33'!
sendDone
	"Return true if the most recent send operation on this socket has completed."

	socketHandle ifNil: [^ false].
	^ self primSocketSendDone: socketHandle
! !

!Socket methodsFor: 'queries' stamp: 'jmv 3/1/2010 13:33'!
statusString
	"Return a string describing the status of this socket."

	| status |
	socketHandle ifNil: [^ 'destroyed'].
	status _ self primSocketConnectionStatus: socketHandle.
	status = InvalidSocket ifTrue: [^ 'invalidSocketHandle'].
	status = Unconnected ifTrue: [^ 'unconnected'].
	status = WaitingForConnection ifTrue: [^ 'waitingForConnection'].
	status = Connected ifTrue: [^ 'connected'].
	status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd'].
	status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd'].
	^ 'unknown socket status'
! !


!SoundPlayer class methodsFor: 'playing' stamp: 'jmv 3/1/2010 13:34'!
resumePlaying: aSound quickStart: quickStart
	"Start playing the given sound without resetting it; it will resume playing from where it last stopped. If quickStart is true, then try to start playing the given sound immediately."

	| doQuickStart |
	Preferences soundsEnabled ifFalse: [^ self].
	doQuickStart _ quickStart.
	Preferences soundQuickStart ifFalse: [doQuickStart _ false].
	PlayerProcess ifNil: [
		self canStartPlayer ifFalse: [^ self].
		^self startUpWithSound: aSound].

	PlayerSemaphore critical: [
		(ActiveSounds includes: aSound)
			ifTrue: [doQuickStart _ false]
			ifFalse: [
				doQuickStart ifFalse: [ActiveSounds add: aSound]]].

	"quick-start the given sound, unless the sound player has just started"
	doQuickStart ifTrue: [self startPlayingImmediately: aSound].
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'jmv 3/1/2010 13:33'!
oldStylePlayLoop
	"This version of the play loop is used if the VM does not yet support sound primitives that signal a semaphore when a sound buffer becomes available."

	| bytesPerSlice count |
	bytesPerSlice _ Stereo ifTrue: [4] ifFalse: [2].
	[true] whileTrue: [
		[(count _ self primSoundAvailableBytes // bytesPerSlice) > 100]
			whileFalse: [(Delay forMilliseconds: 1) wait].

		count _ count min: Buffer stereoSampleCount.
		PlayerSemaphore critical: [
			ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0].
			ActiveSounds do: [:snd |
				snd ~~ SoundJustStarted ifTrue: [
					snd playSampleCount: count into: Buffer startingAt: 1]].
			ReverbState ifNotNil: [
				ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
			self primSoundPlaySamples: count from: Buffer startingAt: 1.
			Buffer primFill: 0.
			SoundJustStarted _ nil]].
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'jmv 3/1/2010 13:34'!
playLoop
	"The sound player process loop."

	| bytesPerSlice count willStop mayStop |
	mayStop _ Preferences soundStopWhenDone.
	bytesPerSlice _ Stereo ifTrue: [4] ifFalse: [2].
	[true] whileTrue: [
		[(count _ self primSoundAvailableBytes // bytesPerSlice) > 100]
			whileFalse: [ReadyForBuffer wait].

		count _ count min: Buffer stereoSampleCount.
		PlayerSemaphore critical: [
			ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0].
			ActiveSounds do: [:snd |
				snd ~~ SoundJustStarted ifTrue: [
					snd playSampleCount: count into: Buffer startingAt: 1]].
			ReverbState ifNotNil: [
				ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
			self primSoundPlaySamples: count from: Buffer startingAt: 1.
			willStop _ mayStop and:[
						(ActiveSounds size = 0) and:[
							self isAllSilence: Buffer size: count]].
			LastBuffer ifNotNil:[
				LastBuffer replaceFrom: 1 to: LastBuffer size with: Buffer startingAt: 1.
			].
			willStop
				ifTrue:[self shutDown. PlayerProcess _ nil]
				ifFalse:[Buffer primFill: 0].
			SoundJustStarted _ nil].
		willStop ifTrue:[^self].
	].
! !

!SoundPlayer class methodsFor: 'private' stamp: 'jmv 3/1/2010 13:34'!
startPlayingImmediately: aSound
	"Private!! Start playing the given sound as soon as possible by mixing it into the sound output buffers of the underlying sound driver."

	| totalSamples buf n leftover src rest |
	"first, fill a double-size buffer with samples"
	"Note: The code below assumes that totalSamples contains two
	 buffers worth of samples, and the insertSamples primitive is
	 expected to consume at least one buffer's worth of these
	 samples. The remaining samples are guaranteed to fit into
	 a single buffer."
	totalSamples _ Buffer stereoSampleCount * 2.  "two buffer's worth"
	buf _ SoundBuffer newStereoSampleCount: totalSamples.
	aSound playSampleCount: totalSamples into: buf startingAt: 1.
	ReverbState ifNotNil: [
		ReverbState applyReverbTo: buf startingAt: 1 count: totalSamples].

	PlayerSemaphore critical: [
		"insert as many samples as possible into the sound driver's buffers"
		n _ self primSoundInsertSamples: totalSamples
			from: buf
			samplesOfLeadTime: 1024.
		n > 0 ifTrue:[
			leftover _ totalSamples - n.

			"copy the remainder of buf into Buffer"
			"Note: the following loop iterates over 16-bit words, not two-word stereo slices"
			"assert: 0 < leftover <= Buffer stereoSampleCount"
			src _ 2 * n.
			1 to: 2 * leftover do:
				[:dst | Buffer at: dst put: (buf at: (src _ src + 1))].

			"generate enough additional samples to finish filling Buffer"
			rest _ Buffer stereoSampleCount - leftover.
			aSound playSampleCount: rest into: Buffer startingAt: leftover + 1.
			ReverbState == nil ifFalse: [
				ReverbState applyReverbTo: Buffer startingAt: leftover + 1 count: rest].

			"record the fact that this sound has already been played into Buffer so that we don't process it again this time around"
			SoundJustStarted _ aSound.
		] ifFalse:[
			"quick start failed; reset the sound so we start over"
			aSound reset.
		].
		ActiveSounds add: aSound].
! !


!SoundRecorder methodsFor: 'trimming' stamp: 'jmv 3/1/2010 13:35'!
segmentsAbove: threshold normalizedVolume: percentOfMaxVolume
	"Break the current recording up into a sequence of sound segments separated by silences."

	| max min sum totalSamples bufSize s dcOffset firstPlace endPlace resultBuf nFactor lastPlace segments gapSize minDur minLull soundSize restSize |
	stereo ifTrue: [self error: 'stereo trimming is not yet supported'].
	paused ifFalse: [self error: 'must stop recording before trimming'].
	(recordedSound == nil or: [recordedSound sounds isEmpty]) ifTrue:[^ self].
	"Reconstruct buffers so old trimming code will work"
	recordedBuffers _ recordedSound sounds collect: [:snd | snd samples].
	soundSize _ restSize _ 0.

	max _ min _ sum _ totalSamples _ 0.
	recordedBuffers do: [:buf |
		bufSize _ buf size.
		totalSamples _ totalSamples + buf size.
		1 to: bufSize do: [:i |
			s _ buf at: i.
			s > max ifTrue: [max _ s].
			s < min ifTrue: [min _ s].
			sum _ sum + s]].
	dcOffset _ sum // totalSamples.

	minDur _ (samplingRate/20.0) asInteger.  " 1/20 second "
	minLull _ (samplingRate/4.0) asInteger.  " 1/2 second "
	segments _ SequentialSound new.
	endPlace _ self endPlace.
	lastPlace _ #(1 1).
	[firstPlace _ self scanForStartThreshold: threshold
						dcOffset: dcOffset
						minDur: minDur
						startingAt: lastPlace.
	firstPlace = endPlace]
		whileFalse:
		[firstPlace = lastPlace ifFalse:
			["Add a silence equal to the gap size"
			"Wasteful but simple way to get gap size..."
			gapSize _ (self copyFrom: lastPlace to: firstPlace
						normalize: 1000 dcOffset: dcOffset) size - 2.
			"... -2 makes up for overlap of one sample on either end"
			segments add: (RestSound dur: gapSize asFloat / samplingRate).
			restSize _ restSize + gapSize.
"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: gapSize; space; show: 'gap'."
			].
		lastPlace _ self scanForEndThreshold: threshold
						dcOffset: dcOffset
						minLull: minLull + minDur
						startingAt: firstPlace.
		"Allow room for lead time of next sound"
		lastPlace _ self place: lastPlace plus: minDur negated.
		nFactor _ self normalizeFactorFor: percentOfMaxVolume
						min: min max: max dcOffset: dcOffset.
		resultBuf _ self copyFrom: firstPlace to: lastPlace
						normalize: nFactor dcOffset: dcOffset.
		soundSize _ soundSize + resultBuf size.
"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: resultBuf size; space; show: 'sound'."
		segments add: (codec
			ifNil: [SampledSound new setSamples: resultBuf samplingRate: samplingRate]
			ifNotNil: [codec compressSound: (SampledSound new setSamples: resultBuf samplingRate: samplingRate)])].

	"Final gap for consistency"
	gapSize _ (self copyFrom: lastPlace to: self endPlace
				normalize: 1000 dcOffset: dcOffset) size - 1.
	segments add: (RestSound dur: gapSize asFloat / samplingRate).
	restSize _ restSize + gapSize.
	self inform: ((soundSize+restSize/samplingRate) roundTo: 0.1) printString , ' secs reduced to ' , ((soundSize/samplingRate) roundTo: 0.1) printString.
	recordedBuffers _ nil.
	^ segments! !

!SoundRecorder methodsFor: 'private' stamp: 'jmv 3/1/2010 13:35'!
samplesPerFrame
	"Can be overridden to quantize buffer size for, eg, fixed-frame codecs"

	^codec
		ifNil: [1]
		ifNotNil: [codec samplesPerFrame]! !


!StandardFileStream methodsFor: 'access' stamp: 'jmv 3/1/2010 13:35'!
peekFor: item 
	"Answer false and do not advance if the next element is not equal to item, or if this stream is at the end.  If the next element is equal to item, then advance over it and return true"
	| next |
	"self atEnd ifTrue: [^ false]. -- SFStream will give nil"
	(next _ self next) ifNil: [^ false].
	item = next ifTrue: [^ true].
	self skip: -1.
	^ false! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'jmv 3/1/2010 13:38'!
post: data target: target url: url ifError: errorBlock
	"Post data to the given URL. The returned file stream contains the reply of the server.
	If Squeak is not running in a browser evaluate errorBlock"
	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema _ Semaphore new.
	index _ Smalltalk registerExternalObject: sema.
	request _ self primURLPost: url target: target data: data semaIndex: index.
	request
		ifNil: [
			Smalltalk unregisterExternalObject: sema.
			^errorBlock value ]
		ifNotNil: [
			[
				sema wait. "until something happens"
				result _ self primURLRequestState: request.
				result == nil] whileTrue.
			result ifTrue:[fileID _ self primURLRequestFileHandle: request].
			self primURLRequestDestroy: request ].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name _ url.
	rwmode _ false.
	buffer1 _ String new: 1.
	self enableReadBuffering! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'jmv 3/1/2010 13:38'!
requestURL: url target: target ifError: errorBlock
	"Request to go to the target for the given URL.
	If Squeak is not running in a browser evaluate errorBlock"

	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema _ Semaphore new.
	index _ Smalltalk registerExternalObject: sema.
	request _ self primURLRequest: url target: target semaIndex: index.
	request
		ifNil: [
			Smalltalk unregisterExternalObject: sema.
			^errorBlock value ]
		ifNotNil: [
			[
				sema wait. "until something happens"
				result _ self primURLRequestState: request.
				result == nil] whileTrue.
			self primURLRequestDestroy: request ].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name _ url.
	rwmode _ false.
	buffer1 _ String new: 1.
	self enableReadBuffering! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'jmv 3/1/2010 13:38'!
requestURLStream: url ifError: errorBlock
	"Request a FileStream for the given URL.
	If Squeak is not running in a browser evaluate errorBlock"
	"FileStream requestURLStream:'http://www.squeak.org'"
	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema _ Semaphore new.
	index _ Smalltalk registerExternalObject: sema.
	request _ self primURLRequest: url semaIndex: index.
	request
		ifNil: [
			Smalltalk unregisterExternalObject: sema.
			^errorBlock value ]
		ifNotNil: [
			[
				sema wait. "until something happens"
				result _ self primURLRequestState: request.
				result == nil] whileTrue.
			result ifTrue:[fileID _ self primURLRequestFileHandle: request].
			self primURLRequestDestroy: request ].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name _ url.
	rwmode _ false.
	buffer1 _ String new: 1.
	self enableReadBuffering! !

!StandardFileStream methodsFor: 'dnd requests' stamp: 'jmv 3/1/2010 13:37'!
requestDropStream: dropIndex
	"Return a read-only stream for some file the user has just dropped onto Squeak."
	name _ self primDropRequestFileName: dropIndex.
	fileID _ self primDropRequestFileHandle: dropIndex.
	fileID ifNil: [^nil].
	self register.
	rwmode _ false.
	buffer1 _ String new: 1.
	self enableReadBuffering! !


!Switch methodsFor: 'action' stamp: 'jmv 3/1/2010 13:39'!
doAction: anAction 
	"Execute anAction if it is non-nil."

	anAction
		ifNotNil: [anAction value]! !


!SystemDictionary methodsFor: 'class names' stamp: 'jmv 3/1/2010 13:40'!
classNames
	"Answer a SortedCollection of all class names."
	| names |
	cachedClassNames ifNil: [
		names _ OrderedCollection new: self size.
		self do: 
			[:cl | (cl isInMemory and: [(cl isKindOf: Class) and: [(cl name beginsWith: 'AnObsolete') not]])
				ifTrue: [names add: cl name]].
		cachedClassNames _ names asSortedCollection].
	^ cachedClassNames! !

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

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

	oldClass removeFromSystem! !

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

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

	oldClass rename: newName! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 3/1/2010 13:42'!
macroBenchmark3   "Smalltalk macroBenchmark3"
	| testBlock tallies prev receiver |
	"Runs the stepping simulator with the messageTally tree (like tallySends)."
	testBlock _
		['Running the context step simulator'
			displayProgressAt: Sensor cursorPoint
			from: 0 to: 200
			during:
				[:bar |
				1 to: 200 do:
				[:x | bar value: x.
				Float pi printString.
				15 factorial printString]]].
	tallies _ MessageTally new class: testBlock receiver class
							method: testBlock method.
	receiver _ nil.
	prev _ testBlock.
	thisContext sender
		runSimulated: testBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: [
				"call or return"
				prev sender ifNotNil: [
					"call only"
					(receiver == nil or: [current receiver == receiver])
						ifTrue: [tallies tally: current by: 1]].
				prev _ current]].
! !

!SystemDictionary methodsFor: 'memory space' stamp: 'jmv 3/1/2010 13:41'!
installLowSpaceWatcher
	"Start a process to watch for low-space conditions."
	"Smalltalk installLowSpaceWatcher"

	self primSignalAtBytesLeft: 0.  "disable low-space interrupts"
	LowSpaceProcess ifNotNil: [LowSpaceProcess terminate].
	LowSpaceProcess _ [self lowSpaceWatcher] newProcess.
	LowSpaceProcess priority: Processor lowIOPriority.
	LowSpaceProcess resume.

! !

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

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

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

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

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

!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 3/1/2010 13:41'!
internalizeChangeLog    
		"Smalltalk internalizeChangeLog"
	"Bring the changes file into a memory-resident filestream, for faster access and freedom from external file system.  1/31/96 sw"

	| reply aName aFile |
	reply _ self confirm:  'CAUTION -- do not undertake this lightly!!
If you have backed up your system and
are prepared to face the consequences of
the requested internalization of sources,
hit Yes.  If you have any doubts, hit No
to back out with no harm done.'.

	(reply ==  true) ifFalse:
		[^ self inform: 'Okay - abandoned'].

	aName _ self localChangesName.
	(aFile _ SourceFiles last) ifNil: [
		(FileDirectory default fileExists: aName)
			ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
		aFile _ FileStream readOnlyFileNamed: aName].
	SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).

	self inform: 'Okay, changes file internalized'! !

!SystemDictionary methodsFor: 'toDeprecate' stamp: 'jmv 3/1/2010 13:43'!
snapshot: save andQuit: quit embedded: embeddedFlag 
	"Mark the changes file and close all files as part of #processShutdownList.
	If save is true, save the current state of this Smalltalk in the image file.
	If quit is true, then exit to the outer OS shell.
	The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up."

	| resuming msg |
	Object flushDependents.
	Object flushEvents.
	(SourceFiles at: 2) ifNotNil: 
			[msg := String streamContents: 
							[:s | 
							s
								nextPutAll: '----';
								nextPutAll: (save 
											ifTrue: [quit ifTrue: ['QUIT'] ifFalse: ['SNAPSHOT']]
											ifFalse: [quit ifTrue: ['QUIT/NOSAVE'] ifFalse: ['NOP']]);
								nextPutAll: '----';
								print: Date dateAndTimeNow;
								space;
								nextPutAll: (FileDirectory default localNameFor: self imageName);
								nextPutAll: ' priorSource: ';
								print: LastQuitLogPosition].
			self assureStartupStampLogged.
			save 
				ifTrue: 
					[LastQuitLogPosition _ ((SourceFiles at: 2)
								setToEnd;
								position)].
			self logChange: msg.
			Transcript
				cr;
				show: msg].
	self processShutDownList: quit.
	Cursor write show.
	save 
		ifTrue: 
			[resuming := embeddedFlag 
						ifTrue: [self snapshotEmbeddedPrimitive]
						ifFalse: [self snapshotPrimitive].	"<-- PC frozen here on image file"
			]
		ifFalse: [resuming := false].
	quit & (resuming == false) ifTrue: [self quitPrimitive].
	Cursor normal show.
	self setGCParameters.
	resuming == true ifTrue: [self clearExternalObjects].
	self processStartUpList: resuming == true.
	resuming == true 
		ifTrue: 
			[self setPlatformPreferences.
			self readDocumentFile].
	SystemWindow wakeUpTopWindowUponStartup.
	"Now it's time to raise an error"
	resuming
		ifNil: [ self error: 'Failed to write image file (disk full?)'].
	^resuming! !


!SystemWindow class methodsFor: 'top window' stamp: 'jmv 3/1/2010 13:43'!
noteTopWindowIn: aWorld
	| newTop |
	"TopWindow must be nil or point to the top window in this project."
	TopWindow _ nil.
	aWorld ifNil: [^ self].
	newTop _ aWorld findA: SystemWindow.
	newTop ifNotNil: [ newTop activate]! !


!TextEditor methodsFor: 'editing keys' stamp: 'jmv 3/1/2010 13:45'!
inOutdent: aKeyboardEvent delta: delta
	"Add/remove a tab at the front of every line occupied by the selection. 
	Derived from work by Larry Tesler back in December 1985.  Now triggered by Cmd-L and Cmd-R.  2/29/96 sw"

	| cr realStart realStop lines startLine stopLine start stop adjustStart indentation size numLines inStream newString outStream |
	cr _ Character cr.

	"Operate on entire lines, but remember the real selection for re-highlighting later"
	realStart _ self startIndex.
	realStop _ self stopIndex - 1.

	"Special case a caret on a line of its own, including weird case at end of paragraph"
	(realStart > realStop and: [
				realStart < 2 or: [(paragraph string at: realStart - 1) == cr]])
		ifTrue:
			[delta < 0
				ifTrue: [
					morph flash]
				ifFalse: [
					self replaceSelectionWith: Character tab asSymbol asText.
					self selectAt: realStart + 1].
			^true].

	lines _ paragraph lines.
	startLine _ paragraph lineIndexOfCharacterIndex: realStart.
	stopLine _ paragraph lineIndexOfCharacterIndex: (realStart max: realStop).
	start _ (lines at: startLine) first.
	stop _ (lines at: stopLine) last.
	
	"Pin the start of highlighting unless the selection starts a line"
	adjustStart _ realStart > start.

	"Find the indentation of the least-indented non-blank line; never outdent more"
	indentation _ (startLine to: stopLine) inject: 1000 into: [ :previousValue :each |
		previousValue min: (paragraph indentationOfLineIndex: each ifBlank: [ :tabs | 1000 ])].			

	size _  stop + 1 - start.
	numLines _ stopLine + 1 - startLine.
	inStream _ ReadStream on: paragraph string from: start to: stop.

	newString _ String new: size + ((numLines * delta) max: 0).
	outStream _ ReadWriteStream on: newString.

	"This subroutine does the actual work"
	self indent: delta fromStream: inStream toStream: outStream.

	"Adjust the range that will be highlighted later"
	adjustStart ifTrue: [realStart _ (realStart + delta) max: start].
	realStop _ realStop + outStream position - size.

	"Prepare for another iteration"
	indentation _ indentation + delta.
	size _ outStream position.
	inStream _ outStream setFrom: 1 to: size.

	outStream
		ifNil: [ 	"tried to outdent but some line(s) were already left flush"
			morph flash]
		ifNotNil: [
			self selectInvisiblyFrom: start to: stop.
			size = newString size ifFalse: [newString _ outStream contents].
			self replaceSelectionWith: newString asText].
	self selectFrom: realStart to: realStop. 	"highlight only the original range"
	^ true! !

!TextEditor methodsFor: 'typing support' stamp: 'jmv 3/1/2010 13:44'!
closeTypeIn
	"See comment in openTypeIn.  It is important to call closeTypeIn before executing
	 any non-typing key, making a new selection, etc.  It is called automatically for
	 menu commands.
	 Undoer & Redoer: undoAndReselect:redoAndReselect:."

	| begin stop |
	beginTypeInBlock ifNotNil: [
		(UndoMessage sends: #noUndoer) ifTrue: [ "should always be true, but just in case..."
			begin _ self startOfTyping.
			stop _ self stopIndex.
			self undoer: #undoAndReselect:redoAndReselect:
				with: (begin + UndoMessage argument to: begin + UndoSelection size - 1)
				with: (stop to: stop - 1).
			UndoInterval _ begin to: stop - 1].
		beginTypeInBlock _ nil]! !

!TextEditor methodsFor: 'typing support' stamp: 'jmv 3/1/2010 13:45'!
startOfTyping
	"Compatibility during change from characterBlock to integer"
	beginTypeInBlock ifNil: [^ nil].
	beginTypeInBlock isNumber ifTrue: [^ beginTypeInBlock].
	"Last line for compatibility during change from CharacterBlock to Integer."
	^ beginTypeInBlock stringIndex! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 3/1/2010 13:44'!
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 usel upara uinterval ind stopIndex |
	startIndex _ self markIndex.
	startIndex > paragraph text size ifTrue: [
		^ false].
	self hasSelection ifTrue: [
		"there was a selection"
		self zapSelectionWith: self nullText.
		^ false].
	"Null selection - do the delete forward"
	beginTypeInBlock ifNil: [	"no previous typing.  openTypeIn"
		self openTypeIn. UndoSelection _ self nullText].
	uinterval _ UndoInterval deepCopy.
	upara _ UndoParagraph deepCopy.
	stopIndex := startIndex.
	(aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ])
		ifTrue: [stopIndex := (self nextWord: stopIndex) - 1].
	self selectFrom: startIndex to: stopIndex.
	self replaceSelectionWith: self nullText.
	self selectFrom: startIndex to: startIndex-1.
	UndoParagraph _ upara.  UndoInterval _ uinterval.
	UndoMessage selector == #noUndoer ifTrue: [
		(UndoSelection is: #Text) ifTrue: [
			usel _ UndoSelection.
			ind _ startIndex. "UndoInterval startIndex"
			usel replaceFrom: usel size + 1 to: usel size with:
				(UndoParagraph text copyFrom: ind to: ind).
			UndoParagraph text replaceFrom: ind to: ind with:
self nullText]].
	^false! !


!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 3/1/2010 13:19'!
browseChangeSetsWithSelector
	"Determine which, if any, change sets have at least one change for the selected selector, independent of class"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector _ self selectedSelector) ifNil: [^ morph flash].
	ChangeSorter browseChangeSetsWithSelector: aSelector! !

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

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

!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 3/1/2010 13:29'!
implementorsOfIt
	"Open an implementors browser on the selected selector"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector _ self selectedSelector) ifNil: [^ morph flash].
	Smalltalk browseAllImplementorsOf: aSelector! !

!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 3/1/2010 13:30'!
sendersOfIt
	"Open a senders browser on the selected selector"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector _ self selectedSelector) ifNil: [^ morph flash].
	Smalltalk browseAllCallsOn: aSelector! !

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

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

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


!TranslucentColor methodsFor: 'private' stamp: 'jmv 3/1/2010 13:45'!
setRgb: rgbValue alpha: alphaValue
	"Set the state of this translucent color. Alpha is represented internally by an integer in the range 0..255."

	rgb ifNotNil: [self attemptToMutateError].
	rgb _ rgbValue.
	alpha _ (255.0 * alphaValue) asInteger min: 255 max: 0.
! !


!UndefinedObject methodsFor: 'as yet unclassified' stamp: 'jmv 3/1/2010 09:59'!
environment
	"Necessary to support disjoint class hierarchies."

	^Smalltalk		"No environments in Cuis..."! !


!Utilities class methodsFor: 'recent method submissions' stamp: 'jmv 3/1/2010 13:46'!
recentMethodSubmissions
	"Answer the list of recent method submissions, in order.  5/16/96 sw"


	self flag: #mref.	"fix for faster references to methods"

	RecentSubmissions ifNil: [RecentSubmissions _ OrderedCollection new].
	^ RecentSubmissions! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'jmv 3/1/2010 13:46'!
spawnHierarchyForClass: aClass selector: aSelector
	"Create and schedule a new class hierarchy browser on the requested class/selector."
	| newBrowser |
	aClass
		ifNil: [^ self].
	(newBrowser _ Browser new) setClass: aClass selector: aSelector.
	newBrowser spawnHierarchy.

"Utilities spawnHierarchyForClass: SmallInteger selector: #hash"! !


!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jmv 3/1/2010 13:46'!
computeSlopeAtMSecs: mSecs
	"Private!! Find the next inflection point of this envelope and compute its target volume and the number of milliseconds until the inflection point is reached."

	| t i |
	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i ifNil: [  "past end"
			targetVol _ points last y * decayScale.
			mSecsForChange _ 0.
			nextRecomputeTime _ mSecs + 1000000.
			^ self].
		targetVol _ (points at: i) y * decayScale.
		mSecsForChange _ (((points at: i) x - t) min: (endMSecs - mSecs)) max: 4.
		nextRecomputeTime _ mSecs + mSecsForChange.
		^ self].

	mSecs < loopStartMSecs ifTrue: [  "attack phase"
		i _ self indexOfPointAfterMSecs: mSecs startingAt: 1.
		targetVol _ (points at: i) y.
		mSecsForChange _ ((points at: i) x - mSecs) max: 4.
		nextRecomputeTime _ mSecs + mSecsForChange.
		((loopEndMSecs ~~ nil) and: [nextRecomputeTime > loopEndMSecs])
			ifTrue: [nextRecomputeTime _ loopEndMSecs].
		^ self].

	"sustain and loop phase"
	noChangesDuringLoop ifTrue: [
		targetVol _ (points at: loopEndIndex) y.
		mSecsForChange _ 10.
		loopEndMSecs
			ifNil: [nextRecomputeTime _ mSecs + 10]  "unknown end time"
			ifNotNil: [nextRecomputeTime _ loopEndMSecs].
		^ self].

	loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y].  "looping on a single point"
	t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
	i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
	targetVol _ (points at: i) y.
	mSecsForChange _ ((points at: i) x - t) max: 4.
	nextRecomputeTime _ (mSecs + mSecsForChange) min: loopEndMSecs.
! !


!WarpBlt methodsFor: 'smoothing' stamp: 'jmv 3/1/2010 13:47'!
mixPix: pix sourceMap: sourceMap destMap: destMap
	"Average the pixels in array pix to produce a destination pixel.
	First average the RGB values either from the pixels directly,
	or as supplied in the sourceMap.  Then return either the resulting
	RGB value directly, or use it to index the destination color map." 
	| r g b rgb nPix bitsPerColor d |
	nPix _ pix size.
	r _ 0. g _ 0. b _ 0.
	1 to: nPix do:
		[:i |   "Sum R, G, B values for each pixel"
		rgb _ sourceForm depth <= 8
				ifTrue: [sourceMap at: (pix at: i) + 1]
				ifFalse: [sourceForm depth = 32
						ifTrue: [pix at: i]
						ifFalse: [self rgbMap: (pix at: i) from: 5 to: 8]].
		r _ r + ((rgb bitShift: -16) bitAnd: 16rFF).
		g _ g + ((rgb bitShift: -8) bitAnd: 16rFF).
		b _ b + ((rgb bitShift: 0) bitAnd: 16rFF)].
	destMap
			ifNil: [
				bitsPerColor _ 3.  "just in case eg depth <= 8 and no map"
				destForm depth = 16 ifTrue: [bitsPerColor _ 5].
				destForm depth = 32 ifTrue: [bitsPerColor _ 8]]
			ifNotNil: [
				destMap size = 512 ifTrue: [bitsPerColor _ 3].
				destMap size = 4096 ifTrue: [bitsPerColor _ 4].
				destMap size = 32768 ifTrue: [bitsPerColor _ 5]].
	d _ bitsPerColor - 8.
	rgb _ ((r // nPix bitShift: d) bitShift: bitsPerColor*2)
		+ ((g // nPix bitShift: d) bitShift: bitsPerColor)
		+ ((b // nPix bitShift: d) bitShift: 0).
	^destMap
		ifNil: [rgb]
		ifNotNil: [destMap at: rgb+1]! !


!WeakKeyDictionary methodsFor: 'accessing' stamp: 'jmv 3/1/2010 13:48'!
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 isNil ifTrue:[^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! !


!WeakValueDictionary methodsFor: 'accessing' stamp: 'jmv 3/1/2010 13:50'!
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 |
	index _ self findElementOrNil: key.
	element _ array at: index.
	element
		ifNil: [self atNewIndex: index put: (WeakValueAssociation key: key value: anObject)]
		ifNotNil: [element value: anObject].
	^ anObject! !


!ZipEncoderNode methodsFor: 'encoding' stamp: 'jmv 3/1/2010 13:50'!
encodeBitLength: blCounts from: aTree
	| index |
	"Note: If bitLength is not nil then the tree must be broken"
	bitLength ifNotNil: [ self error:'Huffman tree is broken'].
	parent = nil 
		ifTrue:[bitLength _ 0]
		ifFalse:[bitLength _ parent bitLength + 1].
	self isLeaf ifTrue:[
		index _ bitLength + 1.
		blCounts at: index put: (blCounts at: index) + 1.
	] ifFalse:[
		left encodeBitLength: blCounts from: aTree.
		right encodeBitLength: blCounts from: aTree.
	].! !


!ZipWriteStream methodsFor: 'encoding' stamp: 'jmv 3/1/2010 13:51'!
flushBlock: lastBlock
	"Send the current block"
	| lastFlag bitsRequired method bitsSent
	storedLength fixedLength dynamicLength 
	blTree lTree dTree blBits blFreq |

	lastFlag _ lastBlock ifTrue:[1] ifFalse:[0].

	"Compute the literal/length and distance tree"
	lTree _ ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits.
	dTree _ ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits.

	"Compute the bit length tree"
	blBits _ lTree bitLengths, dTree bitLengths.
	blFreq _ WordArray new: MaxBitLengthCodes.
	self scanBitLengths: blBits into: blFreq.
	blTree _ ZipEncoderTree buildTreeFrom: blFreq maxDepth: MaxBitLengthBits.

	"Compute the bit length for the current block.
	Note: Most of this could be computed on the fly but it's getting
	really ugly in this case so we do it afterwards."
	storedLength _ self storedBlockSize.
	fixedLength _ self fixedBlockSizeFor: lTree and: dTree.
	dynamicLength _ self dynamicBlockSizeFor: lTree and: dTree 
							using: blTree and: blFreq.
	VerboseLevel > 1 ifTrue:[
		Transcript cr; show:'Block sizes (S/F/D):';
			space; print: storedLength // 8; 
			nextPut:$/; print: fixedLength // 8; 
			nextPut:$/; print: dynamicLength // 8; space; endEntry].

	"Check which method to use"
	method _ self forcedMethod.
	method ifNil: [ 
		method _ (storedLength < fixedLength and:[storedLength < dynamicLength]) 
			ifTrue:[#stored]
			ifFalse:[fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]].
	(method == #stored and:[blockStart < 0]) ifTrue:[
		"Cannot use #stored if the block is not available"
		method _ fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]].

	bitsSent _ encoder bitPosition. "# of bits sent before this block"
	bitsRequired _ nil.

	(method == #stored) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'S'].
		bitsRequired _ storedLength.
		encoder nextBits: 3 put: StoredBlock << 1 + lastFlag.
		self sendStoredBlock].

	(method == #fixed) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'F'].
		bitsRequired _ fixedLength.
		encoder nextBits: 3 put: FixedBlock << 1 + lastFlag.
		self sendFixedBlock].

	(method == #dynamic) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'D'].
		bitsRequired _ dynamicLength.
		encoder nextBits: 3 put: DynamicBlock << 1 + lastFlag.
		self sendDynamicBlock: blTree 
			literalTree: lTree 
			distanceTree: dTree 
			bitLengths: blBits].

	bitsRequired = (encoder bitPosition - bitsSent)
		ifFalse:[self error:'Bits size mismatch'].

	lastBlock 
		ifTrue:[self release]
		ifFalse:[self initializeNewBlock].! !


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

ChangeSorter initialize!
