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@0 corner: 1@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 ! !
On Sun 10 Oct, Lex Spoon wrote:
bogoMethod self foo: [ :x | x + 1 ]. ^x + 2.
[snip]
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?
It certainly isn't a good construct! As you say, it would make life a bit confusing if proper Closures were introduced. The Parser/Encoder ought to complain about it, just as it ought to complain about bogoMethod2 self foo: [ :x | |y| x + y ]. ^y + 2. but doesn't. To be honest, it's probably not worth much effort to fix, since we should have Closures soon. Shouldn't we?
tim
squeak-dev@lists.squeakfoundation.org