'From Cuis 1.0 of 28 November 2009 [latest update: #337] on 8 December 2009 at 10:43:13 pm'!

!Object methodsFor: 'comparing' stamp: 'eem 6/11/2008 17:52'!
closeTo: anObject
	"Answer whether the receiver and the argument represent the same
	object. If = is redefined in any subclass, consider also redefining the
	message hash."

	^[self = anObject] ifError: [:aString :aReceiver | ^ false]! !

!Object methodsFor: 'copying' stamp: 'eem 6/11/2008 17:52'!
copySameFrom: otherObject
	"Copy to myself all instance variables named the same in otherObject.
	This ignores otherObject's control over its own inst vars."

	| myInstVars otherInstVars |
	myInstVars := self class allInstVarNames.
	otherInstVars := otherObject class allInstVarNames.
	myInstVars doWithIndex: [:each :index | | match |
		(match := otherInstVars indexOf: each) > 0 ifTrue:
			[self instVarAt: index put: (otherObject instVarAt: match)]].
	1 to: (self basicSize min: otherObject basicSize) do: [:i |
		self basicAt: i put: (otherObject basicAt: i)].
! !


!AbstractSound methodsFor: 'file i/o' stamp: 'jmv 12/8/2009 22:25'!
storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream
	"Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file."

	| bufSize stereoBuffer reverseBytes  |
	self reset.
	bufSize _ (2 * self samplingRate rounded) min: samplesToStore.  "two second buffer"
	stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize.
	reverseBytes _ bigEndianFlag ~= Smalltalk isBigEndian.

	'Storing audio...' displayProgressAt: Sensor cursorPoint
		from: 0 to: samplesToStore during: [:bar | | remaining out |
			remaining _ samplesToStore.
			[remaining > 0] whileTrue: [
				bar value: samplesToStore - remaining.
				stereoBuffer primFill: 0.  "clear the buffer"
				self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1.
				self isStereo
					ifTrue: [out _ stereoBuffer]
					ifFalse: [out _ stereoBuffer extractLeftChannel].
				reverseBytes ifTrue: [out reverseEndianness].
				(aBinaryStream isKindOf: StandardFileStream)
					ifTrue: [  "optimization for files: write sound buffer directly to file"
						aBinaryStream next: (out size // 2) putAll: out startingAt: 1]  "size in words"
					ifFalse: [  "for non-file streams:"
						1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]].
				remaining _ remaining - bufSize]].
! !


!Array methodsFor: 'converting' stamp: 'jmv 12/8/2009 22:26'!
evalStrings
	   "Allows you to construct literal arrays.
    #(true false nil '5@6' 'Set new' '''text string''') evalStrings
    gives an array with true, false, nil, a Point, a Set, and a String
    instead of just a bunch of Symbols"

    ^ self collect: [:each |  | it |
        it _ each.
        each == #true ifTrue: [it _ true].
		      each == #false ifTrue: [it _ false].
        each == #nil ifTrue: [it _ nil].
        each class == String ifTrue: [
			it _ Smalltalk actualCompilerClass evaluate: each].
        each class == Array ifTrue: [it _ it evalStrings].
        it]! !


!Behavior methodsFor: 'accessing method dictionary' stamp: 'eem 6/11/2008 16:05'!
selectorsWithArgs: numberOfArgs
	"Return all selectors defined in this class that take this number of arguments.  Could use String.keywords.  Could see how compiler does this."

	| list |
	list := OrderedCollection new.
	self selectorsDo: [:aSel | | num |
		num := aSel count: [:char | char == $:].
		num = 0 ifTrue: [aSel last isLetter ifFalse: [num := 1]].
		num = numberOfArgs ifTrue: [list add: aSel]].
	^ list! !

!Behavior methodsFor: 'user interface' stamp: 'eem 6/11/2008 16:03'!
allUnreferencedInstanceVariables
	"Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses"

	^ self allInstVarNames copy reject:
		[:ivn | | any definingClass |
		any := false.
		definingClass := self classThatDefinesInstanceVariable: ivn.
		definingClass withAllSubclasses do:
			[:class |  any ifFalse:
				[(class whichSelectorsAccess: ivn asSymbol) do: 
					[:sel | sel ~~ #DoIt ifTrue: [any := true]]]].
			any]! !

!Behavior methodsFor: 'user interface' stamp: 'eem 6/11/2008 16:07'!
unreferencedInstanceVariables
	"Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses.  2/26/96 sw"

	^ self instVarNames copy reject:
		[:ivn | | any |
		any := false.
		self withAllSubclasses do:
			[:class |  (class whichSelectorsAccess: ivn) do: 
					[:sel | sel ~~ #DoIt ifTrue: [any := true]]].
		any]

"Object unreferencedInstanceVariables"! !

!Behavior methodsFor: 'private' stamp: 'jmv 12/8/2009 22:26'!
spaceUsed
	"Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."

	| space |
	space _ 0.
	self selectorsDo: [:sel | | method |
		space _ space + 16.  "dict and org'n space"
		method _ self compiledMethodAt: sel.
		space _ space + (method size + 6 "hdr + avg pad").
		method literals do: [:lit |
			(lit isMemberOf: Array) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: Float) ifTrue: [space _ space + 12].
			(lit isMemberOf: String) ifTrue: [space _ space + (lit size + 6)].
			(lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]].
		^ space! !


!ChangeList methodsFor: 'menu actions' stamp: 'jmv 12/8/2009 22:28'!
browseCurrentVersionsOfSelections
	"Opens a message-list browser on the current in-memory versions of all methods that are currently seleted"
	| aList |

	aList _ OrderedCollection new.
	Cursor read showWhile: [
		1 to: changeList size do: [ :i |
			(listSelections at: i) ifTrue: [
				| aClass aChange |
				aChange _ changeList at: i.
				(aChange type = #method
					and: [(aClass _ aChange methodClass) notNil
					and: [aClass includesSelector: aChange methodSelector]])
						ifTrue: [
							aList add: (
								MethodReference new
									setStandardClass: aClass  
									methodSymbol: aChange methodSelector
							)
						]]]].

	aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts'].
	MessageSet 
		openMessageList: aList 
		name: 'Current versions of selected methods in ', file localName! !


!ClassBuilder methodsFor: 'class mutation' stamp: 'eem 6/11/2008 16:47'!
mutate: oldClass to: newClass
	"Mutate the old class and subclasses into newClass and subclasses.
	Note: This method is slightly different from: #mutate:toSuper: since
	here we are at the root of reshaping and have two distinct roots."

	self showProgressFor: oldClass.
	"Convert the subclasses"
	oldClass subclasses do:[:oldSubclass| | newSubclass |
		newSubclass := self reshapeClass: oldSubclass toSuper: newClass.
		self mutate: oldSubclass to: newSubclass.
	].
	"And any obsolete ones"
	oldClass obsoleteSubclasses do:[:oldSubclass| | newSubclass |
		oldSubclass ifNotNil:[
			newSubclass := self reshapeClass: oldSubclass toSuper: newClass.
			self mutate: oldSubclass to: newSubclass.
		].
	].
	self update: oldClass to: newClass.
	^newClass! !


!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'eem 6/11/2008 16:51'!
invokePhase1

	| elements |
	revertable ifFalse: [^ self].
	inForce ifTrue: [self error: 'Can invoke only when not in force.'].

	"Do the first part of the invoke operation -- no particular hurry."
	"Save the outer method dictionary for quick revert of method changes."
	priorMD := self realClass methodDict.

	"Prepare a methodDictionary for switcheroo."
	thisMD := self realClass methodDict copy.
	methodChanges associationsDo:
		[:assn | | selector changeRecord type |
		selector := assn key.
		changeRecord := assn value.
		type := changeRecord changeType.
		type = #remove ifTrue: [thisMD removeKey: selector].
		type = #add ifTrue: [thisMD at: selector put: changeRecord currentMethod].
		type = #change ifTrue: [thisMD at: selector put: changeRecord currentMethod].
		].

	"Replace the original organization (and comment)."
	priorOrganization := self realClass organization.
	thisOrganization elementArray copy do:
		[:sel | (thisMD includesKey: sel) ifFalse: [thisOrganization removeElement: sel]].
	#(DoIt DoItIn:) do: [:sel | thisMD removeKey: sel ifAbsent: []].
	thisOrganization elementArray size = thisMD size ifFalse:
		[elements := thisOrganization elementArray asSet.
		thisMD keysDo:
			[:sel | (elements includes: sel) ifFalse:
				[thisOrganization classify: sel
					under: (priorOrganization categoryOfElement: sel)]]].
	self realClass organization: thisOrganization.


! !

!ClassChangeRecord methodsFor: 'removal' stamp: 'eem 6/11/2008 16:50'!
forgetChangesIn: otherRecord
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	| cls otherMethodChanges |
	(cls := self realClass) == nil ifTrue: [^ 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: 'eem 6/11/2008 16:50'!
compileAll: newClass from: oldClass
	"Something about this class has changed.  Locally retained methods must be recompiled.
	NOTE:  You might think that if this changeSet is in force, then we can just note
	the new methods but a lower change set may override and be in force which
	would mean that only the overriding copies go recompiled.  Just do it."

	methodChanges associationsDo:
		[:assn | | sel changeType changeRecord newMethod |
		sel := assn key.
		changeRecord := assn value.
		changeType := changeRecord changeType.
		(changeType == #add or: [changeType == #change]) ifTrue:
			[newMethod := newClass
				recompileNonResidentMethod: changeRecord currentMethod
				atSelector: sel from: oldClass.
			changeRecord noteNewMethod: newMethod]]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'eem 6/11/2008 16:53'!
methodChangeTypes
	"Return an old-style dictionary of method change types."

	| dict |
	dict := IdentityDictionary new.
	methodChanges associationsDo:
		[:assn | | selector record |
		selector := assn key.
		record := assn value.
		dict at: selector put: record changeType].
	^ dict! !


!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 12/8/2009 22:29'!
chooseClassVarName 
	"Present the user with a list of class variable names and answer the one selected, or nil if none"

	| lines labelStream  allVars index |
	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	self withAllSuperclasses reverseDo: [ :class | | vars |
		vars _ class classVarNames asSortedCollection.
		vars do: [ :var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ nil].
	^ allVars at: index! !

!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 12/8/2009 22:31'!
chooseInstVarThenDo: aBlock
	"Put up a menu of all the instance variables in the receiver, and when
the user chooses one, evaluate aBlock with the chosen variable as its
parameter.  If the list is 6 or larger, then offer an alphabetical
formulation as an alternative. triggered by a 'show alphabetically' item
at the top of the list."

	| lines labelStream allVars index count offerAlpha |
	(count _ self allInstVarNames size) = 0 ifTrue: 
		[ ^ self inform: 'There are no\instance variables.' withCRs ].

	allVars _ OrderedCollection new.
	lines _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).

	(offerAlpha _ count > 5)
		ifTrue:
			[lines add: 1.
			allVars add: 'show alphabetically'.
			labelStream nextPutAll: allVars first; cr].
	self withAllSuperclasses reverseDo: [ :class | | vars |
		vars _ class instVarNames.
		vars do: [ :var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream skip: -1 "cut last CR".
	(lines size > 0 and: [ lines last = allVars size ]) ifTrue:
		[ lines removeLast ].  "dispense with inelegant line beneath last item"
	index _ (PopUpMenu labels: labelStream contents lines: lines)
startUpWithCaption: 'Instance variables in
', self name.
	index = 0 ifTrue: [^ self].
	(index = 1 and: [offerAlpha]) ifTrue: [^ self
chooseInstVarAlphabeticallyThenDo: aBlock].
	aBlock value: (allVars at: index)! !


!AbstractSound class methodsFor: 'instance creation' stamp: 'eem 6/11/2008 12:41'!
noteSequenceOn: aSound from: anArray
	"Build a note sequence (i.e., a SequentialSound) from the given array using the given sound as the instrument. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs.  Pitches can be given as names or as numbers."
	| score |
	score := SequentialSound new.
	anArray do: [:el | | pitch |
		el size = 3
			ifTrue: [
				pitch := el at: 1.
				pitch isNumber ifFalse: [pitch := self pitchForName: pitch].
				score add: (
					aSound
						soundForPitch: pitch
						dur: (el at: 2)
						loudness: (el at: 3) / 1000.0)]
			ifFalse: [
				score add: (RestSound dur: (el at: 2))]].
	^ score
! !

!AbstractSound class methodsFor: 'utilities' stamp: 'eem 6/11/2008 12:40'!
dial: aString
	| s |
	"AbstractSound dial: '867-5309'" "ask for Jenny"

	s := SequentialSound new.
	aString do: [ :c | | index lo hi m |
		c = $,
			ifTrue: [ s add: (FMSound new setPitch: 1 dur: 1 loudness: 0) ]
			ifFalse: [
				(index := ('123A456B789C*0#D' indexOf: c)) > 0
					ifTrue: [
						lo := #(697 770 852 941) at: (index - 1 // 4 + 1).
						hi := #(1209 1336 1477 1633) at: (index - 1 \\ 4 + 1).
						m := MixedSound new.
						m add: (FMSound new setPitch: lo dur: 0.15 loudness: 0.5).
						m add: (FMSound new setPitch: hi dur: 0.15 loudness: 0.5).
						s add: m.
						s add: (FMSound new setPitch: 1 dur: 0.05 loudness: 0)]]].
	^ s play.

! !

!AbstractSound class methodsFor: 'utilities' stamp: 'eem 6/11/2008 12:43'!
pitchTable
	"AbstractSound pitchTable"

	| out i |
	out := WriteStream on: (String new: 1000).
	i := 12.
	0 to: 8 do: [:octave |
		#(c 'c#' d eb e f fs g 'g#' a bf b) do: [:noteName | | note |
			note := noteName, octave printString.
			out nextPutAll: note; tab.
			out nextPutAll: i printString; tab.
			out nextPutAll: (AbstractSound pitchForName: note) printString; cr.
			i := i + 1]].
	^ out contents
! !

!AbstractSound class methodsFor: 'examples' stamp: 'eem 6/11/2008 12:41'!
majorChordOn: aSound from: aPitch
	"FMSound majorChord play"

	| score majorScale leadingRest pan |
	majorScale := self majorPitchesFrom: aPitch.
	score := MixedSound new.
	leadingRest := pan := 0.
	#(1 3 5 8) do: [:noteIndex | | note |
		note := aSound
					soundForPitch: (majorScale at: noteIndex)
					dur: 2.0 - leadingRest
					loudness: 0.3.
		score add: (RestSound dur: leadingRest), note pan: pan.
		leadingRest := leadingRest + 0.2.
		pan := pan + 0.3].
	^ score
! !


!ClassOrganizer methodsFor: 'private' stamp: 'eem 6/11/2008 17:00'!
notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil
	(oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil])
		ifTrue: [^ self].
		
	oldDictionaryOrNil isNil ifTrue: [
	newDictionaryOrNil keysAndValuesDo: [:el :cat |
		self notifyOfChangedSelector: el from: nil to: cat].
		^ self.
	].

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


!CompiledMethod methodsFor: 'printing' stamp: 'eem 6/11/2008 17:08'!
who
	"Answer an Array of the class in which the receiver is defined and the 
	selector to which it corresponds."

"	self hasNewPropertyFormat ifTrue:[^{self methodClass. self selector}]."
	Smalltalk allBehaviorsDo: 
		[:class | 
		(class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil:
			[:sel| ^Array with: class with: sel]].
	^Array with: #unknown with: #unknown! !

!CompiledMethod methodsFor: 'scanning' stamp: 'eem 6/11/2008 17:07'!
scanVeryLongStore: extension offset: offset
	"Answer whether the receiver contains a long load with the given offset.
	Note that the constant +32 is the known difference between a
	store and a storePop for instVars, and it will always fail on literal variables,
	but these only use store (followed by pop) anyway."
	| scanner |
	scanner := InstructionStream on: self.
	^scanner scanFor:
		[:instr | | ext |
		(instr = 132 and: [(ext := scanner followingByte) = extension
											or: ["might be a store/pop into rcvr"
												ext = (extension+32)]])
		and: [scanner thirdByte = offset]]! !


!ContextPart methodsFor: 'system simulation' stamp: 'eem 6/16/2008 15:39'!
runSimulated: aBlock contextAtEachStep: block2
	"Simulate the execution of the argument, aBlock, until it ends. aBlock 
	MUST NOT contain an '^'. Evaluate block2 with the current context 
	prior to each instruction executed. Answer the simulated value of aBlock."
	| current |
	aBlock hasMethodReturn
		ifTrue: [self error: 'simulation of blocks with ^ can run loose'].
	current := aBlock asContext.
	current pushArgs: Array new from: self.
	[current == self]
		whileFalse:
			[block2 value: current.
			current := current step].
	^self pop! !


!BlockContext methodsFor: 'scheduling' stamp: 'jmv 12/8/2009 22:20'!
asContext
	^self! !


!DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:21'!
checkDeep
	"Write exceptions in the Transcript.  Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  This check is only run by hand once in a while to make sure nothing was forgotten.  
(Please do not remove this method.)
	DeepCopier new checkDeep 	"

	Transcript
		cr;
		show: 'Instance variables shared with the original object when it is copied'.
	(Smalltalk allClassesImplementing: #veryDeepInner:) do: 
		[:aClass | | mm |
		(mm := aClass instVarNames size) > 0 ifTrue:
			[aClass instSize - mm + 1 to: aClass instSize do: 
				[:index | 
				((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: 
					[Transcript
						cr;
						show: aClass name;
						space;
						show: (aClass allInstVarNames at: index)]]]]! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:21'!
checkVariables
	"Check that no indexes of instance vars have changed in certain classes.  If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated.  The idea is to catch a change while it is still in the system of the programmer who made it.  
	DeepCopier new checkVariables	"

	self checkBasicClasses.

	"Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  So check that the last one is mentioned in the copy method."
	(Smalltalk allClassesImplementing: #veryDeepInner:) do: 
			[:aClass | 
			((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) 
				ifFalse: 
					[aClass instSize > 0 
						ifTrue: [self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]].
	(Smalltalk allClassesImplementing: #veryDeepCopyWith:) do: 
			[:aClass | | meth |
			meth := aClass compiledMethodAt: #veryDeepCopyWith:.
			meth size > 20 & (meth literals includes: #veryDeepCopyWith:) not 
				ifTrue: 
					[(meth writesField: aClass instSize) 
						ifFalse: [self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:22'!
fixDependents
	"They are not used much, but need to be right"

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


!Dictionary methodsFor: 'removing' stamp: 'eem 10/28/2008 11:14'!
unreferencedKeys
	"| uk | (Time millisecondsToRun: [uk := TextConstants unreferencedKeys]) -> uk"

	^'Scanning for references . . .' 
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: Smalltalk classNames size * 2
		during: 
			[:bar | | currentClass n associations referencedAssociations |
			currentClass := nil.
			n := 0.
			associations := self associations asIdentitySet.
			referencedAssociations := IdentitySet new: associations size.
			Smalltalk allSelect:
				[:m|
				m methodClass ~~ currentClass ifTrue:
					[currentClass := m methodClass.
					 bar value: (n := n + 1)].
				m literalsDo:
					[:l|
					(l isVariableBinding and: [associations includes: l]) ifTrue:
						[referencedAssociations add: l]].
				false].
			((associations reject: [:assoc | referencedAssociations includes: assoc]) collect: [:assoc| assoc key]) asSet]! !


!Heap class methodsFor: 'examples' stamp: 'eem 6/11/2008 17:39'!
heapExample	"Heap heapExample"
	"Create a sorted collection of numbers, remove the elements
	sequentially and add new objects randomly.
	Note: This is the kind of benchmark a heap is designed for."
	| n rnd array time |
	n := 5000. "# of elements to sort"
	rnd := Random new.
	array := (1 to: n) collect:[:i| rnd next].
	"First, the heap version"
	time := Time millisecondsToRun:[| sorted |
		sorted := Heap withAll: array.
		1 to: n do:[:i| 
			sorted removeFirst.
			sorted add: rnd next].
	].
	Transcript cr; show:'Time for Heap: ', time printString,' msecs'.
	"The quicksort version"
	time := Time millisecondsToRun:[| sorted |
		sorted := SortedCollection withAll: array.
		1 to: n do:[:i| 
			sorted removeFirst.
			sorted add: rnd next].
	].
	Transcript cr; show:'Time for SortedCollection: ', time printString,' msecs'.
! !

!Heap class methodsFor: 'examples' stamp: 'eem 6/11/2008 17:40'!
heapSortExample	"Heap heapSortExample"
	"Sort a random collection of Floats and compare the results with
	SortedCollection (using the quick-sort algorithm) and 
	ArrayedCollection>>mergeSortFrom:to:by: (using the merge-sort algorithm)."
	| n rnd array time |
	n := 10000. "# of elements to sort"
	rnd := Random new.
	array := (1 to: n) collect:[:i| rnd next].
	"First, the heap version"
	time := Time millisecondsToRun:[| sorted |
		sorted := Heap withAll: array.
		1 to: n do:[:i| sorted removeFirst].
	].
	Transcript cr; show:'Time for heap-sort: ', time printString,' msecs'.
	"The quicksort version"
	time := Time millisecondsToRun:[| sorted |
		sorted := SortedCollection withAll: array.
	].
	Transcript cr; show:'Time for quick-sort: ', time printString,' msecs'.
	"The merge-sort version"
	time := Time millisecondsToRun:[
		array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2].
	].
	Transcript cr; show:'Time for merge-sort: ', time printString,' msecs'.
! !


!ImageSegment methodsFor: 'read/write segment' stamp: 'eem 7/21/2008 12:10'!
copyFromRootsForExport: rootArray 
	"When possible, use copySmartRootsExport:.  This way may not copy a complete tree of objects.  Add to roots: all of the methods pointed to from the outside by blocks."
	| newRoots list segSize symbolHolder |
	arrayOfRoots := rootArray.
	Smalltalk forgetDoIts.
	"self halt."
	symbolHolder := Symbol allSymbols.	"Hold onto Symbols with strong pointers, 
		so they will be in outPointers"
	(newRoots := self rootsIncludingPlayers) ifNotNil: [
		arrayOfRoots := newRoots].		"world, presenter, and all Player classes"
	"Creation of the segment happens here"
	self copyFromRoots: arrayOfRoots sizeHint: 0.
	segSize := segment size.
	[(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [
		arrayOfRoots := newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods pointed at from outside"
	[(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [
		arrayOfRoots := newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods, blocks from outPointers"
	"classes of receivers of blocks"
	list := self compactClassesArray.
	outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
	"Zap sender of a homeContext. Can't send live stacks out."
	1 to: outPointers size do: [:ii | 
		(outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil].
		(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]].
	symbolHolder.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'eem 7/21/2008 12:11'!
rootsIncludingBlocks
	"For export segments only.  Return a new roots array with more objects.  (Caller should store into rootArray.)  Collect Blocks and external methods pointed to by them.  Put them into the roots list.  Then ask for the segment again."

	| extras have |
	userRootCnt ifNil: [userRootCnt := arrayOfRoots size].
	extras := OrderedCollection new.
	outPointers do: [:anOut | 
		anOut class == CompiledMethod ifTrue: [extras add: anOut].
		(anOut isBlock) ifTrue: [extras add: anOut].
		(anOut class == MethodContext) ifTrue: [extras add: anOut].
		anOut := nil].	"don't hang onto it"

	[have := extras size.
	 extras copy do: [:anOut |
		anOut isBlock ifTrue: [
			anOut home ifNotNil: [
				(extras includes: anOut home) ifFalse: [extras add: anOut home]]].
		(anOut class == MethodContext) ifTrue: [
			anOut method ifNotNil: [
				(extras includes: anOut method) ifFalse: [extras add: anOut method]]]].
	 have = extras size] whileFalse.
	extras := extras select: [:ea | (arrayOfRoots includes: ea) not].
	extras isEmpty ifTrue: [^ nil].	"no change"

	^ arrayOfRoots, extras! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 7/21/2008 12:10'!
rehashSets
	"I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
	Also, collect all classes of receivers of blocks.  Return them.  Caller will check if they have been reshaped."

	| object sets receiverClasses inSeg |
	object := segment.
	sets := OrderedCollection new.
		"have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
	receiverClasses := IdentitySet new.
	inSeg := true.
	[object := object nextObject.  
		object == endMarker ifTrue: [inSeg := false].	"off end"
		object isInMemory ifTrue: [
			(object isKindOf: Set) ifTrue: [sets add: object].
			object isBlock ifTrue: [inSeg ifTrue: [
					receiverClasses add: object receiver class]].	
			object class == MethodContext ifTrue: [inSeg ifTrue: [
					receiverClasses add: object receiver class]].	
			]. 
		object == 0] whileFalse.
	sets do: [:each | each rehash].	"our purpose"
	^ receiverClasses	"our secondary job"
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 7/21/2008 12:09'!
storeDataOn: aDataStream
	"Don't wrote the array of Roots.  Also remember the structures of the classes of objects inside the segment."

	| tempRoots tempOutP list |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
		"real state is activeCopy, but we changed it will be right when coming in"
	tempRoots := arrayOfRoots.
	tempOutP := outPointers.
	outPointers := outPointers clone.
	self prepareToBeSaved.
	arrayOfRoots := nil.
	state := #imported.
	super storeDataOn: aDataStream.		"record my inst vars"
	arrayOfRoots := tempRoots.
	outPointers := tempOutP.
	state := #activeCopy.
	aDataStream references at: #AnImageSegment put: false.	"the false is meaningless"
		"This key in refs is the flag that there is an ImageSegment in this file."

	"Find the receivers of blocks in the segment.  Need to get the structure of their classes into structures.  Put the receivers into references."
	(aDataStream byteStream isKindOf: DummyStream) ifTrue: [
		list := Set new.
		arrayOfRoots do: [:ea | 
			ea isBlock | (ea class == MethodContext) ifTrue: [ 
				list add: ea receiver class ]].
		aDataStream references at: #BlockReceiverClasses put: list].
! !


!MessageTally methodsFor: 'initialize-release' stamp: 'jmv 12/8/2009 22:36'!
spyAllEvery: millisecs on: aBlock
	"Create a spy and spy on the given block at the specified rate."
	"Spy all the system processes"

	| myDelay startTime time0 observedProcess |
	aBlock isBlock
		ifFalse: [ self error: 'spy needs a block here' ].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	gcStats _ Smalltalk getVMParameters.
	Timer ifNotNil: [ Timer terminate ].
	Timer _ [
		[true] whileTrue: [
			startTime := Time millisecondClockValue.
			myDelay wait.
			observedProcess := Processor preemptedProcess.
			self
				tally: observedProcess suspendedContext
				in: observedProcess
				"tally can be > 1 if ran a long primitive"
				by: (Time millisecondClockValue - startTime) // millisecs].
		nil] newProcess.
	Timer priority: Processor timingPriority-1.
		"activate the probe and evaluate the block"
	Timer resume.
	^ aBlock ensure: [
		"Collect gc statistics"
		Smalltalk getVMParameters keysAndValuesDo: [ :idx :gcVal | 
			gcStats at: idx put: (gcVal - (gcStats at: idx))].
		"cancel the probe and return the value"
		Timer terminate.
		Timer _ nil.
		time := Time millisecondClockValue - time0]! !

!MessageTally methodsFor: 'initialize-release' stamp: 'jmv 12/8/2009 22:34'!
spyEvery: millisecs on: aBlock
	"Create a spy and spy on the given block at the specified rate."
	"Spy only on the active process (in which aBlock is run)"

	| myDelay startTime time0 observedProcess |
	aBlock isBlock
		ifFalse: [ self error: 'spy needs a block here' ].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	observedProcess _ Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	gcStats _ Smalltalk getVMParameters.
	Timer ifNotNil: [ Timer terminate ].
	Timer _ [
		[true] whileTrue: [
			startTime := Time millisecondClockValue.
			myDelay wait.
			self
				tally: Processor preemptedProcess suspendedContext
				in: (observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil])
				"tally can be > 1 if ran a long primitive"
				by: (Time millisecondClockValue - startTime) // millisecs].
		nil] newProcess.
	Timer priority: Processor timingPriority-1.
		"activate the probe and evaluate the block"
	Timer resume.
	^ aBlock ensure: [
		"Collect gc statistics"
		Smalltalk getVMParameters keysAndValuesDo: [ :idx :gcVal | 
			gcStats at: idx put: (gcVal - (gcStats at: idx))].
		"cancel the probe and return the value"
		Timer terminate.
		Timer _ nil.
		time := Time millisecondClockValue - time0]! !


!MethodFinder methodsFor: 'search' stamp: 'eem 7/21/2008 12:08'!
testPerfect: aSelector
	"Try this selector!! Return true if it answers every example perfectly.  Take the args in the order they are.  Do not permute them.  Survive errors.  later cache arg lists."

| sz argList val rec activeSel perform |
	"Transcript cr; show: aSelector.		debug"
perform := aSelector beginsWith: 'perform:'.
sz := argMap size.
1 to: thisData size do: [:ii | "each example set of args"
	argList := (thisData at: ii) copyFrom: 2 to: sz.
	perform
		ifFalse: [activeSel := aSelector]
		ifTrue: [activeSel := argList first.	"what will be performed"
			((Approved includes: activeSel) or: [AddAndRemove includes: activeSel])
				ifFalse: [^ false].	"not approved"
			aSelector == #perform:withArguments: 
				ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error" 
							ifFalse: [^ false]]
				ifFalse: [activeSel numArgs = (aSelector numArgs - 1) 
							ifFalse: [^ false]]].
	1 to: sz do: [:num | 
		(Blocks includes: (Array with: activeSel with: num)) ifTrue: [
			(argList at: num) isBlock ifFalse: [^ false]]].
	rec := (AddAndRemove includes: activeSel) 
			ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false].
						"vulnerable to modification"
				(thisData at: ii) first copyTwoLevel] 	"protect from damage"
			ifFalse: [(thisData at: ii) first].
	val := [rec perform: aSelector withArguments: argList] 
				ifError: [:aString :aReceiver | 
							"self test3."
							"self test2: (thisData at: ii)."
							^ false].
	"self test3."
	"self test2: (thisData at: ii)."
	((answers at: ii) closeTo: val) ifFalse: [^ false].
	].
^ true! !


!Number methodsFor: 'comparing' stamp: 'eem 6/11/2008 17:51'!
closeTo: num
	"are these two numbers close?"

	num isFloat ifTrue: [^ num closeTo: self asFloat].
	^[self = num] ifError: [:aString :aReceiver | ^ false]! !


!Float methodsFor: 'comparing' stamp: 'eem 6/11/2008 17:37'!
closeTo: num
	"are these two numbers close?"
	| fuzz |
	num isNumber ifFalse:
		[^[self = num] ifError: [:aString :aReceiver | ^ false]].
	self = 0.0 ifTrue: [^ num abs < 0.0001].
	num = 0.0 ifTrue: [^ self abs < 0.0001].
	self isNaN == num isNaN ifFalse: [^ false].
	self isInfinite == num isInfinite ifFalse: [^ false].
	fuzz := (self abs max: num abs) * 0.0001.
	^ (self - num) abs <= fuzz! !

!Float methodsFor: 'printing' stamp: 'eem 6/11/2008 17:38'!
hex  "If ya really want to know..."

	^ String streamContents:
		[:strm | | word nibble |
		1 to: 2 do:
			[:i | word := self at: i.
			1 to: 8 do: 
				[:s | nibble := (word bitShift: -8+s*4) bitAnd: 16rF.
				strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]]
"
(-2.0 to: 2.0) collect: [:f | f hex]
"! !


!SystemChangeNotifier methodsFor: 'public' stamp: 'eem 6/11/2008 18:17'!
doSilently: aBlock
	"Perform the block, and ensure that no system notification are broadcasted while doing so."

	silenceLevel := silenceLevel + 1.
	^aBlock ensure: [silenceLevel > 0 ifTrue: [silenceLevel := silenceLevel - 1]]! !


!WeakArray class methodsFor: 'accessing' stamp: 'jmv 12/8/2009 22:33'!
addWeakDependent: anObject
	self isFinalizationSupported ifFalse: [ ^self ].
	FinalizationLock critical: [
		| finished index weakDependent |
		finished := false.
		index := 0.
		[index := index + 1.
		finished not and:[index <= FinalizationDependents size]] whileTrue:[
			weakDependent := FinalizationDependents at: index.
			weakDependent isNil ifTrue:[
				FinalizationDependents at: index put: anObject.
				finished := true.
			].
		].
		finished ifFalse:[
			"Grow linearly"
			FinalizationDependents := FinalizationDependents, (WeakArray new: 10).
			FinalizationDependents at: index put: anObject.
		].
	] ifError:[:msg :rcvr| rcvr error: msg].! !

