[FIX] out of scope access to block args

Lex Spoon lex at cc.gatech.edu
Sun Oct 10 19:08:29 UTC 1999


Squeak allocates block argument the same way it allocates method
temporary variables.  In fact, it allocates them in a similar enough way
that you can do things like this:

	bogoMethod
		self foo: [ :x | x + 1 ].
		^x + 2.


Note that the last access to x corresponds to the argument of the block,
even though that x was defined in an inner scope.


Do people think this construct is a good idea?  And isn't this construct
at odds with the goal of re-entrant blocks which have fresh argument
variables with each call?


Well, if you agree with me that it's a bad thing to do, you can try the
below changeset.  It rewrites each occurrence of the above pattern that
I could find in the Squeak system, in a way that uses only in-scope
variables.  It was easy to find such occurrences--I ran a hand-written
parser that uses regular scoped names, and noted the places where the
parser complains :)


Lex



'From Squeak 2.5 of August 6, 1999 [latest update: #1514] on 10 October
1999 at 2:17:57 pm'!
"Change Set:		BlockArgAccess
Date:			10 October 1999
Author:			Lex Spoon

Remove many instances in the code where a block arg is accessed outside
of its block.  Such access is allowed by the current compiler, but it
probably shoudln't be."!


!Behavior methodsFor: 'testing method dictionary' stamp: 'ls 10/10/1999
13:22'!
whichSelectorsReferTo: literal 
	"Answer a Set of selectors whose methods access the argument as a
literal."

	| special byte |
	special _ Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:b |
byte _ b].
	^self whichSelectorsReferTo: literal special: special byte: byte

	"Rectangle whichSelectorsReferTo: #+."! !

!Behavior methodsFor: 'user interface' stamp: 'ls 10/10/1999 13:22'!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."

	| aSortedCollection special byte |
	aSortedCollection _ SortedCollection new.
	special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:b |
byte _ b ].
	self withAllSubclassesDo:
		[:class | (class whichSelectorsReferTo: aSymbol special: special byte:
byte) do:
			[:sel | sel ~~ #DoIt ifTrue: [aSortedCollection add: class name , ' '
, sel]]].
	^aSortedCollection! !


!BouncingAtomsMorph methodsFor: 'other' stamp: 'ls 10/10/1999 13:59'!
collisionPairs
	"Return a list of pairs of colliding atoms, which are assumed to be
circles of known radius. This version uses the morph's positions--i.e.
the top-left of their bounds rectangles--rather than their centers."

	| count sortedAtoms radius twoRadii radiiSquared collisions p1 continue
j p2 distSquared m1 m2 |
	count _ submorphs size.
	sortedAtoms _ submorphs asSortedCollection:
		[ :mt1 :mt2 | mt1 position x < mt2 position x].
	radius _ 8.
	twoRadii _ 2 * radius.
	radiiSquared _ radius squared * 2.
	collisions _ OrderedCollection new.
	1 to: count - 1 do: [ :i |
		m1 _ sortedAtoms at: i.
		p1 _ m1 position.
		continue _ (j _ i + 1) <= count.
		[continue] whileTrue: [
			m2 _ sortedAtoms at: j.
			p2 _ m2 position.
			(p2 x - p1 x) <= twoRadii  ifTrue: [
				distSquared _ (p1 x - p2 x) squared + (p1 y - p2 y) squared.
				distSquared < radiiSquared ifTrue: [
					collisions add: (Array with: m1 with: m2)].
				continue _ (j _ j + 1) <= count.
			] ifFalse: [
				continue _ false.
			].
		].
	].
	^ collisions! !


!CCodeGenerator methodsFor: 'inlining' stamp: 'ls 10/10/1999 13:56'!
collectInlineList
	"Make a list of methods that should be inlined."
	"Details: The method must not include any inline C, since the
translator cannot currently map variable names in inlined C code.
Methods to be inlined must be small or called from only one place."

	| methodsNotToInline callsOf inlineIt hasCCode nodeCount senderCount
sel |
	methodsNotToInline _ Set new: methods size.

	"build dictionary to record the number of calls to each method"
	callsOf _ Dictionary new: methods size * 2.
	methods keys do: [ :s | callsOf at: s put: 0 ].

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"
	inlineList _ Set new: methods size * 2.
	methods do: [ :m |
		inlineIt _ #dontCare.
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode _ true.
		] ifFalse: [
			hasCCode _ m declarations size > 0.
			nodeCount _ 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					sel _ node selector.
					(sel = #cCode: or: [sel = #cCode:inSmalltalk:])
						ifTrue: [ hasCCode _ true ].
					senderCount _ callsOf at: sel ifAbsent: [ nil ].
					nil = senderCount ifFalse: [
						callsOf at: sel put: senderCount + 1.
					].
				].
				nodeCount _ nodeCount + 1.
			].
			inlineIt _ m extractInlineDirective.  "may be true, false, or
#dontCare"
		].
		(hasCCode or: [inlineIt = false]) ifTrue: [
			"don't inline if method has C code and is contains negative inline
directive"
			methodsNotToInline add: m selector.
		] ifFalse: [
			((nodeCount < 40) or: [inlineIt = true]) ifTrue: [
				"inline if method has no C code and is either small or contains
inline directive"
				inlineList add: m selector.
			].
		].
	].

	callsOf associationsDo: [ :assoc |
		((assoc value = 1) and: [(methodsNotToInline includes: assoc key)
not]) ifTrue: [
			inlineList add: assoc key.
		].
	].! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ls 10/10/1999 13:55'!
methodStatsString
	"Return a string describing the size, # of locals, and # of senders of
each method. Note methods that have inline C code or C declarations."

	| methodsWithCCode sizesOf callsOf hasCCode nodeCount senderCount s
calls registers selr m |
	methodsWithCCode _ Set new: methods size.
	sizesOf _ Dictionary new: methods size * 2.  "selector -> nodeCount"
	callsOf _ Dictionary new: methods size * 2.  "selector -> senderCount"

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"

	methods do: [ :m0 |  m _ m0.
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode _ true.
		] ifFalse: [
			hasCCode _ m declarations size > 0.
			nodeCount _ 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					selr _ node selector.
					selr = #cCode: ifTrue: [ hasCCode _ true ].
					senderCount _ callsOf at: selr ifAbsent: [ 0 ].
					callsOf at: selr put: senderCount + 1.
				].
				nodeCount _ nodeCount + 1.
			].
		].
		hasCCode ifTrue: [ methodsWithCCode add: m selector ].
		sizesOf at: m selector put: nodeCount.
	].

	s _ WriteStream on: (String new: 5000).
	methods keys asSortedCollection do: [ :sel |
		m _ methods at: sel.
		registers _ m locals size + m args size.
		calls _ callsOf at: sel ifAbsent: [0].
		registers > 11 ifTrue: [
			s nextPutAll: sel; tab.
			s nextPutAll: (sizesOf at: sel) printString; tab.
			s nextPutAll: calls printString; tab.
			s nextPutAll: registers printString; tab.
			(methodsWithCCode includes: sel) ifTrue: [ s nextPutAll: 'CCode' ].
		s cr.
		].
	].
	^ s contents! !


!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ls 10/10/1999 11:37'!
checkForConversionMethods
	"See if any conversion methods are needed"

	| needConversion oldList newList tell choice list need oldVer newVer
sel smart restore |
	"Check preference"
	Preferences conversionMethodsAtFileOut ifFalse: [^ self].
	structures ifNil: [^ self].

	needConversion _ false.
	list _ OrderedCollection new.
	smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345').
	self changedClasses do: [:class |
		need _ (self atClass: class includes: #new) not.
		need ifTrue: [
			"Also consider renamed classes."
			(self atClass: class includes: #rename) ifTrue: [
				needConversion _ true.  list add: class].
			need _ (self atClass: class includes: #change)].
		need ifTrue: [oldList _ structures at: class name 
								ifAbsent: [need _ false.  #()]].
		need ifTrue: [
			newList _ (Array with: class classVersion), (class allInstVarNames).
			need _ (oldList ~= newList)].
		need ifTrue: [
			oldVer _ smart versionSymbol: oldList.
			newVer _ smart versionSymbol: newList.
			sel _ 'convert',oldVer,':',newVer, ':'.	
			(Symbol hasInterned: sel ifTrue: [:ignored |]) ifFalse: [
				need _ false.
				needConversion _ true.
				list add: class]].
		need ifTrue: [sel _ sel asSymbol.
			(#(add change) includes: (self atSelector: sel class: class))
ifFalse: [
				needConversion _ true.
				list add: class]].
		].

	needConversion ifTrue: ["Ask user if want to do this"
		tell _ 'If there might be instances of ', list asArray printString,
		'\in a file full of objects on someone''s disk, please fill in
conversion methods.\'
			withCRs,
		'After you edit the methods, you''ll have to fileOut again.\' withCRs,
		'The preference conversionMethodsAtFileOut controls this feature.'.
		choice _ (PopUpMenu labels: 
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.') startUpWithCaption:
tell. 
		choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
		choice = 2 ifTrue: [
				list do: [:cls | cls withAllSubclassesDo: [:ccc | 
						structures removeKey: ccc name ifAbsent: []]]].
		choice ~= 1 ifTrue: [^ self]].

	list isEmpty ifTrue: [^ self].
	smart structures: structures.	"we will test all classes in structures."
	smart superclasses: superclasses.
	(restore _ Smalltalk changes) == self ifFalse: [
		Smalltalk newChanges: self].
	[smart verifyStructure = 'conversion method needed'] whileTrue.
		"new method is added to changeSet.  Then filed out with the rest."
	restore == self ifFalse: [Smalltalk newChanges: restore].
	"tell 'em to fileout again after modifying methods."
	self inform: 'Remember to fileOut again after modifying these
methods.'.! !


!ClassBuilder methodsFor: 'private' stamp: 'ls 10/10/1999 14:11'!
fixGlobalReferences
	"Fix all the references to globals which are now outdated.
	Care must be taken that we do not accidentally 'fix' dangerous stuff."
	| oldClasses newClasses |
	classMap == nil ifTrue:[^self].
	(self retryWithGC:[classMap contains:[:any| any notNil and:[any
isObsolete]] copy]
"the copy in the above line is to aid in GC of the 'any' tempvar"
		until:[:obsRef| 
				obsRef = false]) ifFalse:[^self]. "GC cleaned up the remaining refs"
	"Collect the old and the new refs"
	oldClasses _ OrderedCollection new.
	newClasses _ OrderedCollection new.
	classMap keysAndValuesDo:[:new :old|
		old == nil ifFalse:[
			newClasses add: new.
			oldClasses add: old]].
	oldClasses isEmpty ifTrue:[^self]. "GC cleaned up the rest"

	"Now fix all the known dangerous pointers to old classes by creating
	copies of those still needed. Dangerous pointers should come only
	from obsolete subclasses (where the superclass must be preserved)."
	self fixObsoleteReferencesTo: oldClasses.

	"After this has been done fix the remaining references"
	progress == nil ifFalse:[progress value: 'Fixing references to
globals'].
	"Forward all old refs to the new ones"
	(oldClasses asArray) elementsForwardIdentityTo: (newClasses asArray).
	"Done"! !


!ClassDescription methodsFor: 'instance variables' stamp: 'ls 10/10/1999
13: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 vars allVars index count offerAlpha |
	(count _ self allInstVarNames size) = 0 ifTrue: 
		[^ self inform: 'There are no
instance variables.'].

	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 _ 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)! !


!AliceWorld class methodsFor: 'instance creation' stamp: 'ls 10/10/1999
12:31'!
fixAliceConstants
	AliceConstants keysAndValuesDo: [ :cname :cvalue | 
		AliceConstants removeKey: cname.
		AliceConstants at: cname asSymbol put: cvalue ].
! !


!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ls 10/10/1999
13:52'!
bounds
	| min max width |
	points isEmpty ifTrue:[^0 at 0 corner: 1 at 1].
	min _ max _ points first.
	points do:[:pt|
		min _ min min: pt.
		max _ max max: pt
	].
	width _ 0.
	lineWidths valuesDo:[:w| width _ width max: w].
	^(min corner: max) insetBy: (width negated asPoint)! !


!ContextPart methodsFor: 'debugger access' stamp: 'ls 10/10/1999 11:57'!
mclass 
	"Answer the class in which the receiver's method was found."

	self receiver class selectorAtMethod: self method setClass: [:mclass |
^mclass ].
	^nil! !

!ContextPart methodsFor: 'debugger access' stamp: 'ls 10/10/1999 13:53'!
tempNames
	"Answer an OrderedCollection of the names of the receiver's temporary 
	variables, which are strings."
	| names |
	self method setTempNamesIfCached: [:n | ^n].
	names _ (self mclass compilerClass new
			parse: self sourceCode
			in: self mclass
			notifying: nil) tempNames.
	self method cacheTempNames: names.
	^names! !

!ContextPart methodsFor: 'printing' stamp: 'ls 10/10/1999 11:57'!
printOn: aStream 
	| selector class mclass |
	self method == nil ifTrue: [^ super printOn: aStream].
	selector _ 
		(class _ self receiver class) 
			selectorAtMethod: self method 
			setClass: [:c | mclass _ c].
	selector == #?
		ifTrue: 
			[aStream nextPut: $?; print: self method who.
			^self].
	aStream nextPutAll: class name.
	mclass == class 
		ifFalse: 
			[aStream nextPut: $(.
			aStream nextPutAll: mclass name.
			aStream nextPut: $)].
	aStream nextPutAll: '>>'.
	aStream nextPutAll: selector! !


!FWT methodsFor: 'computation' stamp: 'ls 10/10/1999 13:13'!
convolveAndInt: inData dataLen: inLen filter: filter sumOutput:
sumOutput into: outData
	"insert zeros between each element of the input sequence and
	   convolve with the filter to interpolate the data"
	| outi filtLen oddTerm evenTerm j |
	outi _ 1.
	filtLen _ filter size.

	"every other dot product interpolates the data"
	filtLen // 2 to: inLen + filtLen - 2 do:
		[:i |
		oddTerm _ self dotpData: inData endIndex: i filter: filter
									start: 2 stop: filter size inc: 2.
		evenTerm _ self dotpData: inData endIndex: i+1 filter: filter
									start: 1 stop: filter size inc: 2.
		sumOutput
			ifTrue:
				["summation with previous convolution if true"
				outData at: outi put: (outData at: outi) + oddTerm.
				outData at: outi+1 put: (outData at: outi+1) + evenTerm]
			ifFalse:
				["first convolution of pair if false"
				outData at: outi put: oddTerm.
				outData at: outi+1 put: evenTerm].
		outi _ outi + 2].

	"Ought to be able to fit this last term into the above loop."
	j _ inLen + filtLen - 1.
	oddTerm _ self dotpData: inData endIndex: j filter: filter
									start: 2 stop: filter size inc: 2.
	sumOutput
		ifTrue: [outData at: outi put: (outData at: outi) + oddTerm]
		ifFalse: [outData at: outi put: oddTerm].
! !


!Float methodsFor: 'private' stamp: 'ls 10/10/1999 11:55'!
absPrintOn: aStream base: base digitCount: digitCount 
	"Print me in the given base, using digitCount significant figures."

	| fuzz x exp q fBase scale logScale xi |
	self isInf ifTrue: [^ aStream nextPutAll: 'Inf'].
	fBase _ base asFloat.
	"x is myself normalized to [1.0, fBase), exp is my exponent"
	exp _ 
		self < 1.0
			ifTrue: [self reciprocalFloorLog: fBase]
			ifFalse: [self floorLog: fBase].
	scale _ 1.0.
	logScale _ 0.
	[(x _ fBase raisedTo: (exp + logScale)) = 0]
		whileTrue:
			[scale _ scale * fBase.
			logScale _ logScale + 1].
	x _ self * scale / x.
	fuzz _ fBase raisedTo: 1 - digitCount.
	"round the last digit to be printed"
	x _ 0.5 * fuzz + x.
	x >= fBase
		ifTrue: 
			["check if rounding has unnormalized x"
			x _ x / fBase.
			exp _ exp + 1].
	(exp < 6 and: [exp > -4])
		ifTrue: 
			["decimal notation"
			q _ 0.
			exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000'
at: i)]]]
		ifFalse: 
			["scientific notation"
			q _ exp.
			exp _ 0].
	[x >= fuzz]
		whileTrue: 
			["use fuzz to track significance"
			xi _ x asInteger.
			aStream nextPut: (Character digitValue: xi).
			x _ x - xi asFloat * fBase.
			fuzz _ fuzz * fBase.
			exp _ exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	[exp >= -1]
		whileTrue: 
			[aStream nextPut: $0.
			exp _ exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	q ~= 0
		ifTrue: 
			[aStream nextPut: $e.
			q printOn: aStream]! !


!LucidParser class methodsFor: 'parsing' stamp: 'ls 10/10/1999 13:49'!
parseMethod: specification
	| classSymTable method |
	"parse the method given by this specification.  If the method has
already been parsed since the last send of #clearMethodCache, then
return the previously parsed message instead of doing it again"
	ParsedMethods at: specification ifPresent: [ :m | ^m ].

	method _ self parseMethodSource: specification methodSource.
	method class: specification methodClass.
	classSymTable _ LucidClassSymbolTable
forClassAndSuperclassesAndGlobals: specification methodClass.
	method bindVariablesWith: classSymTable.

	ParsedMethods at: specification put: method.
	^method! !

!LucidParser class methodsFor: 'tests' stamp: 'ls 10/10/1999 12:35'!
parseAndBindEverything
	"try to parse every method in the system"
	"
		MessageTally spyOn: [ LucidParser parseAndBindEverything ]
	"
	| spec |
	LucidSymbolTable clearGlobalTables.
	LucidParser clearMethodCache.
	Smalltalk allBehaviorsDo: [ :class |
		class selectors do: [ :sel |
			spec _ LucidMethodSpecification class: class selector: sel.
			Utilities informUser: spec printString during: [
				LucidParser parseMethod: spec ] ] ]! !


!MessageSet methodsFor: 'private' stamp: 'ls 10/10/1999 12:08'!
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 |
	messageListIndex = 0 ifTrue: [^ false].
	self setClassAndSelectorIn: [:c :os | class_c. oldSelector_os].
	category _ class organization categoryOfElement: oldSelector.
	selector _ class compile: aString
				classified: category
				notifying: aController.
	selector == nil ifTrue: [^false].
	selector == oldSelector ifFalse: [self messageListIndex: 0].
	contents _ aString copy.
	self changed: #annotation.
	^ true! !


!MessageTally methodsFor: 'printing' stamp: 'ls 10/10/1999 11:56'!
printOn: aStream
	| aSelector className aClass |
	aSelector _ class selectorAtMethod: method setClass: [:c | aClass _ c].
	className _ aClass name contractTo: 30.
	aStream nextPutAll: className; nextPutAll: ' >> ';
			nextPutAll: (aSelector contractTo: 60-className size)! !

!MessageTally methodsFor: 'printing' stamp: 'ls 10/10/1999 11:57'!
printOn: aStream total: total tallyExact: isExact
	| aSelector className myTally aClass |
	isExact ifTrue:
		[myTally _ tally.
		receivers == nil
			ifFalse: [receivers do: [:r | myTally _ myTally - r tally]].
		aStream print: myTally; space]
		ifFalse:
		[aStream print: (tally asFloat / total * 100.0 roundTo: 0.1); space].
	receivers == nil
		ifTrue: [aStream nextPutAll: 'primitives'; cr]
		ifFalse: 
			[aSelector _ class selectorAtMethod: method setClass: [:c | aClass _
c].
			className _ aClass name contractTo: 30.
			aStream nextPutAll: class name;
				nextPutAll: (aClass = class ifTrue: ['>>']
								ifFalse: ['(' , aClass name , ')>>']);
				nextPutAll: (aSelector contractTo: 60-className size); cr]! !


!ParagraphEditor methodsFor: 'menu messages' stamp: 'ls 10/10/1999
11:36'!
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 , (view 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.
							tiVars == nil ifTrue: [tiVars _ self explainInst: string]].
					(tiVars == nil and: [model respondsTo: #explainSpecial:])
						ifTrue: [tiVars _ model explainSpecial: string].
					tiVars == nil
						ifTrue: [tiVars _ '']
						ifFalse: [tiVars _ 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.
							cgVars == nil
								ifTrue: [cgVars _ self explainClass: symbol.
									cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]].
							"See if it is a Selector (sent here or not)"
							selectors _ self explainMySel: symbol.
							selectors == nil
								ifTrue: 
									[selectors _ self explainPartSel: string.
									selectors == nil ifTrue: [
										selectors _ self explainAnySel: symbol]]]
						ifFalse: [selectors _ self explainPartSel: string].
					cgVars == nil
						ifTrue: [cgVars _ '']
						ifFalse: [cgVars _ cgVars , '\' withCRs].
					selectors == nil
						ifTrue: [selectors _ '']
						ifFalse: [selectors _ selectors , '\' withCRs].
					string size = 1
						ifTrue: ["single special characters"
							delimitors _ self explainChar: string]
						ifFalse: ["matched delimitors"
							delimitors _ self explainDelimitor: string].
					numbers _ self explainNumber: string.
					numbers == nil ifTrue: [numbers _ ''].
					delimitors == nil ifTrue: [delimitors _ ''].
					reply _ tiVars , cgVars , selectors , delimitors , numbers].
			reply size = 0 ifTrue: [reply _ sorry].
			self afterSelectionInsertAndSelect: reply]! !


!ParseNode methodsFor: 'private' stamp: 'ls 10/10/1999 11:29'!
printSingleComment: aString on: aStream indent: indent 
	"Print the comment string, assuming it has been indented indent tabs.  

	Break the string at word breaks, given the widths in the default font,
at 
	450 points."

	| readStream word position lineBreak font wordWidth tabWidth spaceWidth
lastChar |
	readStream _ ReadStream on: aString.
	font _ TextStyle default defaultFont.
	tabWidth _ TextConstants at: #DefaultTab.
	spaceWidth _ font widthOf: Character space.
	position _ indent * tabWidth.
	lineBreak _ 450.
	[readStream atEnd]
		whileFalse: 
			[word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _
lc].
			wordWidth _ 0.
			word do: [:char | wordWidth _ wordWidth + (font widthOf: char)].
			position _ position + wordWidth.
			position > lineBreak
				ifTrue: 
					[aStream crtab: indent.
					position _ indent * tabWidth + wordWidth + spaceWidth.
					lastChar = Character cr
						ifTrue: [[readStream peekFor: Character tab] whileTrue].
					aStream nextPutAll: word; space]
				ifFalse: 
					[aStream nextPutAll: word.
					readStream atEnd
						ifFalse: 
							[position _ position + spaceWidth.
							aStream space].
					lastChar = Character cr
						ifTrue: 
							[aStream crtab: indent.
							position _ indent * tabWidth.
							[readStream peekFor: Character tab] whileTrue]]]! !


!MethodNode methodsFor: 'code generation' stamp: 'ls 10/10/1999 11:32'!
generate: trailer 
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The

	argument, trailer, is the references to the source code that is stored
with 
	every CompiledMethod."
	| blkSize nLits stack strm nArgs method |
	self generateIfQuick: 
		[:m | 
		method _ m.
		1 to: trailer size do: [:i | method at: method size - trailer size + i
put: (trailer at: i)].
		method cacheTempNames: self tempNames.
		^method].
	nArgs _ arguments size.
	blkSize _ block sizeForEvaluatedValue: encoder.
	encoder maxTemp > 31
		ifTrue: [^self error: 'Too many temporary variables'].	
	literals _ encoder allLiterals.
	(nLits _ literals size) > 255
		ifTrue: [^self error: 'Too many literals referenced'].
	method _ CompiledMethod	"Dummy to allocate right size"
				newBytes: blkSize
				nArgs: nArgs
				nTemps: encoder maxTemp
				nStack: 0
				nLits: nLits
				primitive: primitive.
	strm _ ReadWriteStream with: method.
	strm position: method initialPC - 1.
	stack _ ParseStack new init.
	block emitForEvaluatedValue: stack on: strm.
	stack position ~= 1 ifTrue: [^self error: 'Compiler stack
discrepancy'].
	strm position ~= (method size - trailer size) 
		ifTrue: [^self error: 'Compiler code size discrepancy'].
	method needsFrameSize: stack size.
	1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
	1 to: trailer size do: [:i | method at: method size - trailer size + i
put: (trailer at: i)].
	method cacheTempNames: self tempNames.
	^ method! !


!PasteUpMorph methodsFor: 'flaps' stamp: 'ls 10/10/1999 14:06'!
deleteGlobalFlapArtifacts
	"self currentWorld deleteGlobalFlapArtifacts"

	| localFlaps |
	localFlaps _ self localFlapTabs collect: [:m | m referent].
	self submorphs do:
		[:m | 
			((m isKindOf: FlapTab) and: [m isGlobal]) ifTrue: [m delete].
			((m isKindOf: PasteUpMorph) and: [m hasProperty: #flap])
				ifTrue:
					[(localFlaps includes: m) ifFalse: [m delete]]]! !


!Player class methodsFor: 'housekeeping' stamp: 'ls 10/10/1999 13:42'!
abandonUnnecessaryUniclasses
	"Player abandonUnnecessaryUniclasses"
	| oldCount oldFree newFree newCount report |
	oldCount _ self subclasses size - 1.
	oldFree _ Smalltalk garbageCollect.
	self allSubInstances do:
		[:aPlayer | aPlayer revertToUnscriptedPlayerIfAppropriate.  
		"encourage last one to get garbage-collected"
		aPlayer _ nil ].

	ScriptingSystem spaceReclaimed.
	newFree _ Smalltalk garbageCollect.
	newCount _ self subclasses size - 1.
	report _ 'Before: ', oldCount printString, ' uniclasses, ', oldFree
printString, ' bytes free
After:  ', newCount printString, ' uniclasses, ', newFree printString, '
bytes free'.
	Transcript cr; show: 'abandonUnnecessaryUniclasses:'; cr; show: report.
	^ report
	! !

!Player class methodsFor: 'housekeeping' stamp: 'ls 10/10/1999 13:41'!
freeUnreferencedSubclasses
	"Player classes may hold in their class instance variables references
to instances of themselves that are housekeepingwise unreachable. This
method allows such loops to be garbage collected. This is done in three
steps:
	1. Remove user-created subclasses from the 'subclasses' set and from
Smalltalk. Only remove classes whose name begins with 'Player' and which
have no references.
	2. Do a full garbage collection.
	3. Enumerate all Metaclasses and find those whose soleInstance's
superclass is this class. Reset the subclasses set to this set of
classes, and add back to Smalltalk."
	"Player freeUnreferencedSubclasses"

	| oldFree candidatesForRemoval class |
	oldFree _ Smalltalk garbageCollect.
	candidatesForRemoval _ self subclasses asOrderedCollection select:
		[:aClass | (aClass name beginsWith: 'Player') and: [aClass name
endsWithDigit]].

	"Break all system links and then perform garbage collection."
	candidatesForRemoval do:
		[:c | self removeSubclass: c.  "Break downward subclass pointers."
		Smalltalk removeKey: c name ifAbsent: [].  "Break binding of global
name"].
	candidatesForRemoval _ nil.
	Smalltalk garbageCollect.  "Now this should reclaim all unused
subclasses"

	"Now reconstruct system links to subclasses with valid references."
	"First restore any global references via associations"
	(Association allSubInstances select:
			[:assn | (assn key isMemberOf: Symbol)
					and: [(assn key beginsWith: 'Player')
					and: [assn key endsWithDigit]]])
		do: [:assn | class _ assn value.
			(class isKindOf: self class) ifTrue:
				[self addSubclass: class.
				Smalltalk add: assn]].
	"Then restore any further direct references, creating new
associations."
	(Metaclass allInstances select:
			[:m | (m soleInstance name beginsWith: 'Player')
					and: [m soleInstance name endsWithDigit]])
		do: [:m | class _ m soleInstance.
			((class isKindOf: self class) and: [(Smalltalk includesKey: class
name) not]) ifTrue:
				[self addSubclass: class.
				Smalltalk at: class name put: class]].
	SystemOrganization removeMissingClasses.
	^ Smalltalk garbageCollect - oldFree
! !


!ReferenceStream methodsFor: 'statistics' stamp: 'ls 10/10/1999 13:27'!
statisticsOfRefs
	"Analyze the information in references, the objects being written out"

	| parents n kids nm ownerBags tallies owners objParent |
	parents _ IdentityDictionary new: references size * 2.
	n _ 0.
	'Finding Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:
		[:parent | bar value: (n _ n+1).
		kids _ parent class isFixed
			ifTrue: [(1 to: parent class instSize) collect: [:i | parent
instVarAt: i]]
			ifFalse: [parent class isBits ifTrue: [Array new]
					 ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt:
i]]].
		(kids select: [:x | references includesKey: x])
			do: [:child | parents at: child put: parent]]].
	ownerBags _ Dictionary new.
	tallies _ Bag new.
	n _ 0.
	'Tallying Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:  "For each class of obj, tally a bag of owner
classes"
		[:obj | bar value: (n _ n+1).
		nm _ obj class name.
		tallies add: nm.
		owners _ ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new].
		(objParent _ parents at: obj ifAbsent: [nil]) == nil
			ifFalse: [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]]]! !


!RunArray methodsFor: 'copying' stamp: 'ls 10/10/1999 13:15'!
copyFrom: start to: stop
	| newRuns run1 run2 offset1 offset2 | 
	stop < start ifTrue: [^RunArray new].
	self at: start setRunOffsetAndValue: [:r :o :value1 | run1 _ r. offset1
_ o.  value1].
	self at: stop setRunOffsetAndValue: [:r :o :value2 | run2 _ r. offset2
_ o. value2].
	run1 = run2
		ifTrue: 
			[newRuns _ Array with: offset2 - offset1 + 1]
		ifFalse: 
			[newRuns _ runs copyFrom: run1 to: run2.
			newRuns at: 1 put: (newRuns at: 1) - offset1.
			newRuns at: newRuns size put: offset2 + 1].
	^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)! !


!SystemDictionary methodsFor: 'retrieving' stamp: 'ls 10/10/1999 13:22'!
allCallsOn: aLiteral   "Smalltalk browseAllCallsOn: #open:label:."
	"Answer a Collection of all the methods that call on aLiteral."
	| aCollection special thorough aList byte |

	#(23 48 'fred' (new open:label:)) size.
		"Example above should find #open:label:, though it is deeply embedded
here."
	aCollection _ OrderedCollection new.
	special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _
b ].
	thorough _ (aLiteral isMemberOf: Symbol)
				and: ["Possibly search for symbols imbedded in literal arrays"
					Preferences thoroughSenders].
	Cursor wait showWhile: 
		[self allBehaviorsDo: 
			[:class |
				aList _ thorough
					ifTrue:
			 			[(class thoroughWhichSelectorsReferTo: aLiteral special: special
byte: byte)]
					ifFalse:
						[class whichSelectorsReferTo: aLiteral special: special byte:
byte].
				aList do: 
					[:sel | sel ~~ #DoIt
						ifTrue: [aCollection add: class name , ' ' , sel]]]].
	^ aCollection! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'ls 10/10/1999 13:22'!
allCallsOn: firstLiteral and: secondLiteral
	"Answer a SortedCollection of all the methods that call on both
aLiteral 
	and secondLiteral."

	| aCollection secondArray firstSpecial secondSpecial firstByte
secondByte |
	aCollection _ SortedCollection new.
	firstSpecial _ self hasSpecialSelector: firstLiteral ifTrueSetByte: [:b
| firstByte _ b].
	secondSpecial _ self hasSpecialSelector: secondLiteral ifTrueSetByte:
[:b | secondByte _ b].
	Cursor wait showWhile:
		[self allBehaviorsDo:
			[:class |
			secondArray _ class whichSelectorsReferTo: secondLiteral special:
secondSpecial byte: secondByte.
			((class whichSelectorsReferTo: firstLiteral special: firstSpecial
byte: firstByte) select:
				[:aSel | (secondArray includes: aSel)]) do:
						[:sel | aCollection add: class name , ' ' , sel]]].
	^aCollection! !


!Utilities class methodsFor: 'fetching updates' stamp: 'ls 10/10/1999
13:48'!
broadcastUpdatesFrom: n1 to: n2 except: skipList
"
	ChangeSorter removeChangeSetsNamedSuchThat:
		[:name | name first isDigit and: [name initialIntegerOrNil > 412]].
	Utilities readServerUpdatesSaveLocally: true updateImage: true.
	Utilities broadcastUpdatesFrom: 413 to: 999 except: #().

	Utilities readServerUpdatesSaveLocally: true updateImage: false
       The expression above ftps all updates not in the current image
over to the local
       hard disk, but does NOT absorb them into the current image
"
	| fileNames fileNamesInOrder fileNamesUnnumbered names choice file
csname |
	fileNames _ FileDirectory default fileNames select:
		[:n | n first isDigit
			and: [(n initialIntegerOrNil between: n1 and: n2)
			and: [(skipList includes: n initialIntegerOrNil) not]]].
	fileNamesInOrder _ fileNames asSortedCollection: [:a :b | a
initialIntegerOrNil < b initialIntegerOrNil].
	fileNamesUnnumbered _ fileNamesInOrder collect:
		[:n | n copyFrom: (n findFirst: [:c | c isDigit not]) to: n size].
	(csname _ fileNamesUnnumbered asBag sortedCounts first) key > 1
		ifTrue: [self halt: 'Repeated name: ' , csname value].
	(file _ fileNamesUnnumbered select: [:n | (n occurrencesOf: $.) > 1])
size > 0
		ifTrue: [self halt: file first , ' has multiple periods'].
	fileNamesInOrder with: fileNamesUnnumbered do:
		[:n :nu | FileDirectory default rename: n toBe: nu].

	names _ ServerDirectory groupNames asSortedArray.
	choice _ (SelectionMenu labelList: names selections: names) startUp.
	choice == nil ifTrue: [^ self].
	(ServerDirectory groupNamed: choice) putUpdateMulti:
fileNamesUnnumbered
! !





More information about the Squeak-dev mailing list