'From Squeak3.2gamma[BC] of 15 January 2002 [latest update: #4743] on 13 February 2002 at 7:50:38 pm'! "Change Set: BCImagePostConversion-ajh Date: 12 February 2002 Author: Anthony Hannan (ajh18@cornell.edu) This is part of the New Block Closure Version set of changes. Please refer to http://minnow.cc.gatech.edu/squeak/BlockClosureVersion. This changeset makes all the minor changes to outside classes so they reference the new CompiledMethod2, Process2, etc. instead of the old ones."! !Behavior methodsFor: 'testing method dictionary' stamp: 'ajh 1/15/2002 15:02'! whichSelectorsAccess: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." (self allInstVarNames includes: instVarName) ifFalse: [^ Set new]. ^ self methodDict keys select: [:sel | (self methodDict at: sel) readsOrWritesField: instVarName myClass: self] "Point whichSelectorsAccess: 'x'."! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ajh 1/15/2002 15:03'! whichSelectorsStoreInto: instVarName "Answer a Set of selectors whose methods assign to the argument, instVarName, as a named instance variable." (self allInstVarNames includes: instVarName) ifFalse: [^ Set new]. ^ self methodDict keys select: [:sel | (self methodDict at: sel) writesField: instVarName myClass: self] "Point whichSelectorsStoreInto: 'x'."! ! !ClassDescription methodsFor: 'compiling' stamp: 'ajh 12/31/2001 22:11'! compile: code notifying: requestor ifFail: failBlock elseSetSelectorAndNode: selAndNodeBlock "Intercept this message in order to remember system changes. 5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set. 7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set" | methodNode selector newMethod priorMethodOrNil | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. selector _ methodNode selector. selAndNodeBlock value: selector value: methodNode. requestor ifNotNil: ["Note this change for recent submissions list" Utilities noteMethodSubmission: selector forClass: self]. newMethod _ methodNode generate. priorMethodOrNil _ (self methodDict includesKey: selector) ifTrue: [self compiledMethodAt: selector] ifFalse: [nil]. Smalltalk changes noteNewMethod: newMethod forClass: self selector: selector priorMethod: priorMethodOrNil. self addSelector: selector withMethod: newMethod. ^ newMethod! ! !ClassDescription methodsFor: 'compiling' stamp: 'ajh 12/31/2001 21:58'! compile: code notifying: requestor trailer: bytes ifFail: failBlock elseSetSelectorAndNode: selAndNodeBlock "Intercept this message in order to remember system changes. 5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set. 7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set" | methodNode selector newMethod priorMethodOrNil | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. selector _ methodNode selector. selAndNodeBlock value: selector value: methodNode. requestor ifNotNil: ["Note this change for recent submissions list" Utilities noteMethodSubmission: selector forClass: self]. newMethod _ methodNode generate: bytes. priorMethodOrNil _ (self methodDict includesKey: selector) ifTrue: [self compiledMethodAt: selector] ifFalse: [nil]. Smalltalk changes noteNewMethod: newMethod forClass: self selector: selector priorMethod: priorMethodOrNil. self addSelector: selector withMethod: newMethod. ^ newMethod! ! !CCodeGenerator class methodsFor: 'removing from system' stamp: 'ajh 1/20/2002 16:03'! removeCompilerMethods "Before removing the C code generator classes from the system, use this method to remove the compiler node methods that support it. This avoids leaving dangling references to C code generator classes in the compiler node classes." ParseNode withAllSubclasses do: [ :nodeClass | nodeClass removeCategory: 'C translation'. ]. ParseNode2 withAllSubclasses do: [ :nodeClass | nodeClass removeCategory: 'C translation'. ]. Smalltalk at: #AbstractSound ifPresent: [:abstractSound | abstractSound class removeCategory: 'primitive generation']. ! ! !CodeHolder methodsFor: 'self-updating' stamp: 'ajh 12/31/2001 22:01'! didCodeChangeElsewhere "Determine whether the code for the currently selected method and class has been changed somewhere else." | aClass aSelector aCompiledMethod | currentCompiledMethod ifNil: [^ false]. (aClass _ self selectedClassOrMetaClass) ifNil: [^ false]. (aSelector _ self selectedMessageName) ifNil: [^ false]. ^ ((aCompiledMethod _ aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod) and: [aCompiledMethod trailer notNil "either not yet installed" or: [currentCompiledMethod trailer isNil "or these methods don't have source pointers"]] ! ! !ChangeList methodsFor: 'viewing access' stamp: 'ajh 1/15/2002 02:22'! restoreDeletedMethod "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed. In this case we want to establish a sourceCode link to prior versions. We do this by installing a dummy method with the correct source code pointer prior to installing this version." | dummyMethod class selector | dummyMethod _ CompiledMethod2 toReturnSelf setSourcePointer: lostMethodPointer. class _ (changeList at: listIndex) methodClass. selector _ (changeList at: listIndex) methodSelector. class addSelector: selector withMethod: dummyMethod. (changeList at: listIndex) fileIn. "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails." (class compiledMethodAt: selector) == dummyMethod ifTrue: [class removeSelectorSimply: selector]. ^ true! ! !ChangeSorter methodsFor: 'message list' stamp: 'ajh 1/15/2002 02:23'! browseVersions "Create and schedule a changelist browser on the versions of the selected message." | class selector method category pair sourcePointer | (selector _ self selectedMessageName) ifNil: [^ self]. class _ self selectedClassOrMetaClass. (class includesSelector: selector) ifTrue: [method _ class compiledMethodAt: selector. category _ class whichCategoryIncludesSelector: selector. sourcePointer _ nil] ifFalse: [pair _ myChangeSet methodInfoFromRemoval: {class name. selector}. pair ifNil: [^ nil]. sourcePointer _ pair first. method _ CompiledMethod2 toReturnSelf setSourcePointer: sourcePointer. category _ pair last]. VersionsBrowser browseVersionsOf: method class: self selectedClass meta: class isMeta category: category selector: selector lostMethodPointer: sourcePointer. ! ! !CodeLoader class methodsFor: 'utilities' stamp: 'ajh 12/29/2001 11:18'! exportCodeSegment: exportName classes: aClassList keepSource: keepSources "Code for writing out a specific category of classes as an external image segment. Perhaps this should be a method." | is oldMethods newMethods m oldCodeString argsAndTemps classList symbolHolder fileName | keepSources ifTrue: [ self confirm: 'We are going to abandon sources. Quit without saving after this has run.' orCancel: [^self]]. classList _ aClassList asArray. "Strong pointers to symbols" symbolHolder := Symbol allInstances. oldMethods _ OrderedCollection new: classList size * 150. newMethods _ OrderedCollection new: classList size * 150. keepSources ifTrue: [ classList do: [:cl | cl selectors do: [:selector | m _ cl compiledMethodAt: selector. m fileIndex > 0 ifTrue: [oldCodeString _ cl sourceCodeAt: selector. argsAndTemps _ (cl compilerClass new parse: oldCodeString in: cl notifying: nil) tempNames. oldMethods addLast: m. newMethods addLast: (m trailerTempNames: argsAndTemps)]]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. oldMethods _ newMethods _ m _ oldCodeString _ argsAndTemps _ nil. Smalltalk garbageCollect. is _ ImageSegment new copyFromRootsForExport: classList. "Classes and MetaClasses" fileName _ FileDirectory fileName: exportName extension: ImageSegment fileExtension. is writeForExport: fileName. self compressFileNamed: fileName ! ! !Compiler methodsFor: 'public access' stamp: 'ajh 1/18/2002 12:55'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock "Compiles the sourceStream into a parse tree, then generates code into a method. This method is then installed in the receiver's class so that it can be invoked. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here as DoIt or (in the case of evaluation in aContext) DoItIn:. The method is subsequently removed from the class, but this will not get done if the invocation causes an error which is terminated. Such garbage can be removed by executing: Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: #DoItIn:]." | methodNode method value | "class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class." class _ receiver class. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode _ self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method _ methodNode generate: #(0 0 0 0). self interactive ifTrue: [method trailerTempNames: methodNode tempNames]. context == nil ifTrue: [class addSelector: #DoIt withMethod: method. value _ receiver DoIt. InMidstOfFileinNotification signal ifFalse: [ class removeSelectorSimply: #DoIt. ]. ^value] ifFalse: [class addSelector: #DoItIn: withMethod: method. value _ receiver DoItIn: context. InMidstOfFileinNotification signal ifFalse: [ class removeSelectorSimply: #DoItIn:. ]. ^value]! ! !ControlManager methodsFor: 'accessing' stamp: 'ajh 1/3/2002 19:32'! activeController: aController "Set aController to be the currently active controller. Give the user control in it." "Simulation guard" activeController _ aController. (activeController == screenController) ifFalse: [self promote: activeController]. activeControllerProcess _ [activeController startUp. self searchForActiveController] newUIProcess. activeControllerProcess priority: Processor userSchedulingPriority. activeControllerProcess resume! ! !ControlManager methodsFor: 'scheduling' stamp: 'ajh 1/3/2002 19:28'! uiProcess: aProcess activeController _ screenController. activeControllerProcess _ aProcess. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/5/2002 13:34'! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. externalInterrupt ifFalse: [contextStackTop push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" currentContext _ self selectedContext. self contextStackIndex > 1 ifTrue: [newContext _ currentContext completeCallee: contextStackTop. self resetContext: newContext] ifFalse: [newContext _ currentContext quickStep. newContext == currentContext ifTrue: [ currentContext stepToSendOrReturn. self changed: #contentsSelection. self updateInspectors] ifFalse: [ externalInterrupt ifFalse: [newContext push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" newContext stepToSendOrReturn. self resetContext: newContext]]! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/5/2002 13:39'! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" self okToChange ifFalse: [^ self]. self checkContextSelection. self selectedContext restart. self selectedContext stepToSendOrReturn. self resetContext: self selectedContext. Preferences restartAlsoProceeds ifTrue: [self proceed]! ! !Debugger methodsFor: 'code pane' stamp: 'ajh 1/18/2002 11:19'! doItReceiver "Answer the object that is 'self' when evaluating a text selection." ^ self selectedContext isBlockContext ifTrue: [self receiver "blockClosure" doItReceiver] ifFalse: [self receiver]! ! !Debugger methodsFor: 'code pane' stamp: 'ajh 1/1/2002 20:39'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i methodNode pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap == nil ifTrue: [methodNode _ self selectedClass compilerClass new parse: contents in: self selectedClass notifying: nil dialect: true. self selectedContext isBlockContext ifTrue: [ methodNode _ methodNode blockNodeFor: self selectedContext method]. sourceMap _ methodNode sourceMap. tempNames _ methodNode tempNames. self selectedContext method cacheTempNames: tempNames]. sourceMap size = 0 ifTrue: [^1 to: 0]. pc _ contextStackIndex = 1 ifTrue: [self selectedContext pc] ifFalse: [self selectedContext previousPc]. i _ sourceMap detectIndex: [:pcRange | pc <= pcRange key] ifNone: [ end _ sourceMap inject: 0 into: [:prev :pcRange | prev max: pcRange value last]. ^ end+1 to: end]. ^ (sourceMap at: i) value! ! !Debugger methodsFor: 'private' stamp: 'ajh 1/18/2002 02:51'! contextStackIndex: anInteger oldContextWas: oldContext | newMethod | contextStackIndex _ anInteger. anInteger = 0 ifTrue: [tempNames _ sourceMap _ contents _ nil. self changed: #contextStackIndex. self contentsChanged. contextVariablesInspector object: nil. receiverInspector regular: self receiver. ^self]. (newMethod _ oldContext == nil or: [([oldContext method] onDNU: #errorFrameDead do: [nil]) ~~ self selectedContext method]) ifTrue: [tempNames _ sourceMap _ nil. contents _ self selectedMessage. self contentsChanged. self pcRange "will compute tempNamesunless noFrills"]. self changed: #contextStackIndex. tempNames == nil ifTrue: [tempNames _ self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil]. contextVariablesInspector object: self selectedContext. self selectedContext isBlockContext ifTrue: [ receiverInspector closure: self receiver. ] ifFalse: [ receiverInspector regular: self receiver. ]. newMethod ifFalse: [self changed: #contentsSelection]! ! !Debugger class methodsFor: 'opening' stamp: 'ajh 1/3/2002 17:28'! openInterrupt: aString onProcess: interruptedProcess ^ self openInterrupt: aString onProcess: interruptedProcess context: interruptedProcess topFrame! ! !Debugger class methodsFor: 'opening' stamp: 'ajh 1/3/2002 18:42'! openInterrupt: aString onProcess: interruptedProcess context: frame "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." | debugger debuggerOrController | "Simulation guard" debugger _ self new. debugger process: interruptedProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == interruptedProcess]) ifTrue: [ScheduledControllers activeController]) context: frame. debugger externalInterrupt: true. Preferences logDebuggerStackToFile ifTrue: [(aString includesSubString: 'Space') & (aString includesSubString: 'low') ifTrue: [ Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']]. debuggerOrController _ debugger openNotifierContents: nil label: aString. Process2 uiProcess isRunning ifFalse: [Process2 spawnNewUIProcess]. ^ debuggerOrController! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'ajh 1/15/2002 12:03'! checkClass: aClass | meth | "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." self checkBasicClasses. "Unlikely, but important to catch when it does happen." "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." (aClass includesSelector: #veryDeepInner:) ifTrue: [ ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instVarNames last myClass: aClass) ifFalse: [ aClass instSize > 0 ifTrue: [ self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (aClass includesSelector: #veryDeepCopyWith:) ifTrue: [ meth _ aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instVarNames last myClass: aClass) ifFalse: [ self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'ajh 1/15/2002 12:08'! 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 | aClass instVarNames do: [:instVarName | ((aClass compiledMethodAt: #veryDeepInner:) writesField: instVarName myClass: aClass) ifFalse: [ Transcript cr; show: aClass name; space; show: instVarName]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'ajh 1/15/2002 12:09'! 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 " | meth | 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 instVarNames last myClass: aClass) ifFalse: [ aClass instSize > 0 ifTrue: [ self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (Smalltalk allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | meth _ aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instVarNames last myClass: aClass) ifFalse: [ self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. ! ! !Error methodsFor: 'private' stamp: 'ajh 1/5/2002 12:55'! devDefaultAction (OpenDebugger forException: self) == true ifTrue: [initialContext debug: self description] ifFalse: [initialContext process suspend]! ! !IllegalResumeAttempt methodsFor: 'private' stamp: 'ajh 1/5/2002 12:55'! devDefaultAction (OpenDebugger forException: self) == true ifTrue: [initialContext debug: self description] ifFalse: [initialContext process suspend]! ! !Inspector methodsFor: 'accessing' stamp: 'ajh 1/18/2002 02:55'! closure: obj "Change my inspector class to match my new closure object" self primitiveChangeClassTo: ClosureInspector basicNew. self object: obj. self changed: #fieldList. ! ! !Inspector methodsFor: 'accessing' stamp: 'ajh 1/18/2002 02:49'! regular: obj "Change object but keep regular inspector class" self object: obj. ! ! !InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ajh 1/15/2002 12:11'! trickyPrimitiveList "InterpreterSupportCode trickyPrimitiveList" | primitives internal method ivars | "Instance variables of Interpreter that we might have to setup before running a primitive" ivars _ #(activeContext argumentCount instructionPointer lkupClass messageSelector method newMethod primitiveIndex receiver stackPointer successFlag theHomeContext). Interpreter initialize. primitives _ self internalPrimitives asArray. primitives _ IdentityDictionary withAll: ('scanning for reachable methods...' withCRs displayProgressAt: Sensor cursorPoint from: 1 to: primitives size during: [:bar | primitives withIndexCollect: [:sel :seq | bar value: seq. sel -> (self selectorsReachableFrom: sel)]]). internal _ Dictionary new. ('scanning for inst var refs...' withCRs displayProgressAt: Sensor cursorPoint from: 1 to: ivars size during: [:bar | ivars withIndexCollect: [:ivar :seq | bar value: seq. ivar -> (primitives select: [:sels | nil ~~ (sels detect: [:sel | method _ (Interpreter compiledMethodAt: sel). method readsOrWritesField: ivar myClass: Interpreter] ifNone: [nil])]) keys]]) associationsDo: [:assoc | assoc value do: [:sel | (internal at: sel ifAbsent: [internal at: sel put: Set new]) add: assoc key]]. primitives keysDo: [:sel | (internal includesKey: sel) ifFalse: [internal at: sel put: Set new]]. internal addAll: (self externalPrimitives collect: [:prim | prim -> #(argumentCount stackPointer successFlag)]). (internal at: #primitiveStoreImageSegment) removeAll: #(activeContext lkupClass messageSelector method newMethod receiver). (internal at: #primitiveSnapshotEmbedded) removeAll: #(activeContext instructionPointer method). internal at: #primitiveFlushCache put: #(stackPointer activeFrame). ^(internal associationsDo: [:assoc | assoc value: assoc value asSortedCollection])! ! !MessageSend methodsFor: 'tiles' stamp: 'ajh 1/20/2002 15:10'! asTilesIn: playerClass | code keywords num tree syn block phrase | "Construct SyntaxMorph tiles for me." "This is really cheating!! Make a true parse tree later. -tk" code _ String streamContents: [:strm | strm nextPutAll: 'doIt'; cr; tab. strm nextPutAll: (self stringFor: receiver). keywords _ selector keywords. strm space; nextPutAll: keywords first. (num _ selector numArgs) > 0 ifTrue: [strm space. strm nextPutAll: (self stringFor: arguments first)]. 2 to: num do: [:kk | strm space; nextPutAll: (keywords at: kk). strm space; nextPutAll: (self stringFor: (arguments at: kk))]]. "decompile to tiles" tree _ Compiler new parse: code in: playerClass notifying: nil. syn _ tree asMorphicSyntaxUsing: SyntaxMorph. block _ syn submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == BlockNode2] ifFalse: [false]]. phrase _ block submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == MessageNode2] ifFalse: [false]]. ^ phrase ! ! !MessageSend methodsFor: 'tiles' stamp: 'ajh 1/20/2002 15:11'! asTilesIn: playerClass globalNames: makeSelfGlobal | code keywords num tree syn block phrase | "Construct SyntaxMorph tiles for me. If makeSelfGlobal is true, name the receiver and use that name, else use 'self'. (Note that this smashes 'self' into the receiver, regardless of what it was.)" "This is really cheating!! Make a true parse tree later. -tk" code _ String streamContents: [:strm | strm nextPutAll: 'doIt'; cr; tab. strm nextPutAll: (makeSelfGlobal ifTrue: [self stringFor: receiver] ifFalse: ['self']). keywords _ selector keywords. strm space; nextPutAll: keywords first. (num _ selector numArgs) > 0 ifTrue: [strm space. strm nextPutAll: (self stringFor: arguments first)]. 2 to: num do: [:kk | strm space; nextPutAll: (keywords at: kk). strm space; nextPutAll: (self stringFor: (arguments at: kk))]]. "decompile to tiles" tree _ Compiler new parse: code in: playerClass notifying: nil. syn _ tree asMorphicSyntaxUsing: SyntaxMorph. block _ syn submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == BlockNode2] ifFalse: [false]]. phrase _ block submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == MessageNode2] ifFalse: [false]]. ^ phrase ! ! !MessageTally methodsFor: 'initialize-release' stamp: 'ajh 1/18/2002 17:08'! close (Timer isMemberOf: Process2) ifTrue: [Timer terminate]. Timer _ ObservedProcess _ nil. class _ method _ tally _ receivers _ nil! ! !MessageTally methodsFor: 'initialize-release' stamp: 'ajh 2/11/2002 15:35'! spyEvery: millisecs on: aBlock "Create a spy and spy on the given block at the specified rate." | myDelay value startTime time0 | (aBlock isMemberOf: BlockClosure) ifFalse: [self error: 'spy needs a block here']. self class: aBlock class method: aBlock method. "set up the probe" ObservedProcess _ Processor activeProcess. myDelay := Delay forMilliseconds: millisecs. time0 := Time millisecondClockValue. gcStats _ Smalltalk getVMParameters. Timer := [[true] whileTrue: [startTime := Time millisecondClockValue. myDelay wait. self tally: ObservedProcess suspendedContext "tally can be > 1 if ran a long primitive" by: (Time millisecondClockValue - startTime) // millisecs]. nil] newProcess. Timer priority: Processor userInterruptPriority. "activate the probe and evaluate the block" Timer resume. value := aBlock value. "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. time := Time millisecondClockValue - time0. ^value! ! !MessageTally methodsFor: 'initialize-release' stamp: 'ajh 1/18/2002 17:08'! spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration "Create a spy and spy on the given process at the specified rate." | myDelay time0 endTime sem | (aProcess isKindOf: Process2) ifFalse: [self error: 'spy needs a Process here']. self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method. "set up the probe" ObservedProcess _ aProcess. myDelay _ Delay forMilliseconds: millisecs. time0 _ Time millisecondClockValue. endTime _ time0 + msecDuration. sem _ Semaphore new. gcStats _ Smalltalk getVMParameters. Timer _ [[| startTime | startTime _ Time millisecondClockValue. myDelay wait. self tally: ObservedProcess suspendedContext by: Time millisecondClockValue - startTime // millisecs. startTime < endTime] whileTrue. sem signal] forkAt: (ObservedProcess priority + 1 min: Processor highestPriority). "activate the probe and wait for it to finish" sem wait. "Collect gc statistics" Smalltalk getVMParameters keysAndValuesDo: [:idx :gcVal| gcStats at: idx put: (gcVal - gcStats at: idx)]. time _ Time millisecondClockValue - time0! ! !MessageTally methodsFor: 'tallying' stamp: 'ajh 2/11/2002 15:23'! tally: context by: count "Explicitly tally the specified context and its stack." | root | context method == method ifTrue: [^self bumpBy: count]. (root _ context sender) == nil ifTrue: [^ (self bumpBy: count) tallyPath: context by: count]. ^ (self tally: root by: count) tallyPath: context by: count! ! !MessageTally class methodsFor: 'spying' stamp: 'ajh 1/15/2002 01:21'! tallySendsTo: receiver inBlock: aBlock showTree: treeOption "MessageTally tallySends: [3.14159 printString]" "This method uses the simulator to count the number of calls on each method invoked in evaluating aBlock. If receiver is not nil, then only sends to that receiver are tallied. Results are presented as leaves, sorted by frequency, preceded, optionally, by the whole tree." | proc prev tallies startTime totalTime | startTime _ Time millisecondClockValue. tallies _ MessageTally new class: aBlock receiver class method: aBlock method. proc _ aBlock newProcess. prev _ proc bottomFrame. proc simulateEachStepDo: [:current | current == prev ifFalse: ["call or return" prev sender == nil ifFalse: ["call only" (receiver == nil or: [current receiver == receiver]) ifTrue: [tallies tally: current by: 1]]. prev _ current] ]. totalTime _ Time millisecondClockValue - startTime // 1000.0 roundTo: 0.01. (StringHolder new contents: (String streamContents: [:s | s nextPutAll: 'This simulation took ' , totalTime printString , ' seconds.'; cr. treeOption ifTrue: [tallies fullPrintOn: s tallyExact: true orThreshold: 0] ifFalse: [tallies leavesPrintOn: s tallyExact: true orThreshold: 0]. tallies close])) openLabel: 'Spy Results'! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'ajh 12/29/2001 11:17'! compileSelectionFor: anObject in: evalContext | methodNode method | methodNode _ [Compiler new compileNoPattern: self selectionAsStream in: anObject class context: evalContext notifying: self ifFail: [^nil]] on: OutOfScopeNotification do: [:ex | ex resume: true]. method _ methodNode generate: #(0 0 0 0). ^ method trailerTempNames: methodNode tempNames! ! !Player methodsFor: 'scripts-kernel' stamp: 'ajh 1/20/2002 15:02'! newScriptorAround: aPhrase "Sprout a scriptor around aPhrase, thus making a new script. aPhrase may either be a PhraseTileMorph (classic tiles 1997-2001) or a SyntaxMorph (2001 onward)" | aScriptEditor aUniclassScript tw blk | aUniclassScript _ self class permanentUserScriptFor: self unusedScriptName player: self. aScriptEditor _ aUniclassScript instantiatedScriptEditorForPlayer: self. Preferences universalTiles ifTrue: [ aScriptEditor install. "aScriptEditor hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft; setProperty: #autoFitContents toValue: true." aScriptEditor insertUniversalTiles. "Gets an empty SyntaxMorph for a MethodNode" tw _ aScriptEditor findA: TwoWayScrollPane. aPhrase ifNotNil: [blk _ (tw scroller findA: SyntaxMorph "MethodNode") findA: BlockNode2. blk addMorphFront: aPhrase. aPhrase accept. ]. SyntaxMorph setSize: nil andMakeResizable: aScriptEditor. ] ifFalse: [ aPhrase ifNotNil: [aScriptEditor phrase: aPhrase] "does an install" ifNil: [aScriptEditor install] ]. self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aUniclassScript selector]. "The above assures the presence of a ScriptInstantiation for the new selector in all siblings" self updateAllViewersAndForceToShow: #scripts. ^ aScriptEditor! ! !Player methodsFor: 'misc' stamp: 'ajh 1/20/2002 16:21'! tileReferringToSelf "answer a tile that refers to the receiver" | aTile nn tile | Preferences universalTiles ifTrue: [nn _ self externalName. "name it, if necessary, and put in References" (References includesKey: nn asSymbol) ifFalse: [ References at: nn asSymbol put: self]. tile _ SyntaxMorph new parseNode: (VariableNode2 new name: nn). tile layoutInset: 1; addMorph: (tile addString: nn special: false). tile color: (SyntaxMorph translateColor: #variable). tile extent: tile firstSubmorph extent + (2@2). ^ tile]. aTile _ TileMorph new setToReferTo: self. ^ aTile! ! !CardPlayer methodsFor: 'slots-kernel' stamp: 'ajh 1/20/2002 16:19'! tileReferringToSelf "answer a tile that refers to the receiver. For CardPlayer, want 'self', not the specific name of this card. Script needs to work for any card of the background." | aTile tile | Preferences universalTiles ifTrue: [tile _ SyntaxMorph new parseNode: (SpecialVariableNode selfNode). tile layoutInset: 1; addMorph: (tile addString: 'self' special: false). "translate to wordy variant here..." tile color: (SyntaxMorph translateColor: #variable). tile extent: tile firstSubmorph extent + (2@2). ^ tile]. aTile _ TileMorph new setToReferTo: self. ^ aTile! ! !Player class methodsFor: 'scripts' stamp: 'ajh 1/20/2002 15:11'! tilesFrom: aString | code tree syn block phrase | "Construct SyntaxMorph tiles for the String." "This is really cheating!! Make a true parse tree later. -tk" code _ String streamContents: [:strm | strm nextPutAll: 'doIt'; cr; tab. strm nextPutAll: aString]. "decompile to tiles" tree _ Compiler new parse: code in: self notifying: nil. syn _ tree asMorphicSyntaxUsing: SyntaxMorph. block _ syn submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == BlockNode2] ifFalse: [false]]. phrase _ block submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == MessageNode2] ifFalse: [false]]. ^ phrase ! ! !ProcessBrowser methodsFor: 'process list' stamp: 'ajh 12/31/2001 22:38'! updateProcessList | oldSelectedProcess newIndex now | now _ Time millisecondClockValue. now - lastUpdate < 500 ifTrue: [^ self]. "Don't update too fast" lastUpdate _ now. oldSelectedProcess _ selectedProcess. processList _ selectedProcess _ selectedSelector _ nil. Smalltalk garbageCollectMost. "lose defunct processes" processList _ Process2 allSubInstances reject: [:each | each callStack isNil and: [ each ~~ Processor activeProcess ]]. processList _ processList sortBy: [:a :b | a priority >= b priority]. processList _ WeakArray withAll: processList. newIndex _ processList indexOf: oldSelectedProcess ifAbsent: [0]. self changed: #processNameList. self processListIndex: newIndex! ! !ProcessorScheduler methodsFor: 'private' stamp: 'ajh 12/31/2001 22:38'! anyProcessesAbove: highestPriority "Do any instances of Process exist with higher priorities?" ^(Process2 allInstances "allSubInstances" select: [:aProcess | aProcess priority > highestPriority]) isEmpty "If anyone ever makes a subclass of Process, be sure to use allSubInstances."! ! !Project class methodsFor: 'utilities' stamp: 'ajh 1/3/2002 19:32'! spawnNewProcess UIProcess _ [ [World doOneCycle. Processor yield. false] whileFalse: []. ] newUIProcess priority: Processor userSchedulingPriority. UIProcess resume! ! !Project class methodsFor: 'utilities' stamp: 'ajh 1/3/2002 19:28'! uiProcess: aProcess "Adopt aProcess as the project process -- probably because of proceeding from a debugger" UIProcess _ aProcess. ! ! !PseudoClass methodsFor: 'private' stamp: 'ajh 1/18/2002 17:06'! parserClass ^Parser2! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'ajh 1/20/2002 16:05'! insertUniversalTilesForClass: aClass selector: aSelector "Add a submorph which holds the universal-tiles script for the given class and selector" | source tree syn widget header | source _ aClass sourceCodeAt: aSelector ifAbsent: [ Transcript cr; show: aClass name, 'could not find selector ', aSelector. ^ self delete]. tree _ Compiler new parse: source in: aClass notifying: nil. (syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass. aSelector numArgs = 0 ifTrue: [ "remove method header line" (header _ syn findA: SelectorNode2) ifNotNil: [header delete]]. syn removeReturnNode. "if ^ self at end, remove it" widget _ syn inAScrollPane. widget hResizing: #spaceFill; vResizing: #spaceFill; color: Color transparent; setProperty: #hideUnneededScrollbars toValue: true. self addMorphBack: widget. (self hasProperty: #autoFitContents) ifFalse: [self valueOfProperty: #sizeAtHibernate ifPresentDo: [:oldExtent | self extent: oldExtent]]. syn finalAppearanceTweaks.! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'ajh 1/20/2002 15:15'! methodNodeMorph "Answer the morph that constitutes the receiver's method node" submorphs size < 2 ifTrue: [^ nil]. ^ self findDeepSubmorphThat: [:aMorph | (aMorph isKindOf: SyntaxMorph) and: [aMorph parseNode isKindOf: MethodNode2]] ifAbsent: [nil]! ! !SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 15:11'! quickList "Compute the selectors for the single example of receiver and args, in the very top pane" | data result resultArray newExp dataStrings mf dataObjects aa | data _ contents asString. "delete trailing period. This should be fixed in the Parser!!" [data last isSeparator] whileTrue: [data _ data allButLast]. data last = $. ifTrue: [data _ data allButLast]. "Eval" mf _ MethodFinder new. data _ mf cleanInputs: data. "remove common mistakes" dataObjects _ Compiler evaluate: '{', data, '}'. "#( data1 data2 result )" dataStrings _ (Compiler new parse: 'zort ' , data in: Object notifying: nil) block statements allButLast collect: [:node | String streamContents: [:strm | (node isKindOf: MessageNode2) ifTrue: [strm nextPut: $(]. node printOn: strm indent: 0. (node isKindOf: MessageNode2) ifTrue: [strm nextPut: $)].]]. dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()]. dataObjects _ Array with: dataObjects allButLast with: dataObjects last. "#( (data1 data2) result )" result _ mf load: dataObjects; findMessage. (result first beginsWith: 'no single method') ifFalse: [ aa _ self testObjects: dataObjects strings: dataStrings. dataObjects _ aa second. dataStrings _ aa third]. resultArray _ self listFromResult: result. resultArray isEmpty ifTrue: [self inform: result first]. dataStrings size = (dataObjects first size + 1) ifTrue: [resultArray _ resultArray collect: [:expression | newExp _ expression. dataObjects first withIndexDo: [:lit :i | newExp _ newExp copyReplaceAll: 'data', i printString with: (dataStrings at: i)]. newExp, ' --> ', dataStrings last]]. ^ resultArray! ! !Semaphore methodsFor: 'communication' stamp: 'ajh 1/4/2002 00:38'! primSignal "Primitive. Send a signal through the receiver. If one or more processes have been suspended trying to receive a signal, allow the first one to proceed. If no process is waiting, remember the excess signal. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed "self isEmpty ifTrue: [excessSignals _ excessSignals+1] ifFalse: [Processor resume: self removeFirstLink]" ! ! !Semaphore methodsFor: 'communication' stamp: 'ajh 1/14/2002 23:49'! signal "If any processes are waiting on me then resume the first one on line, otherwise remember excess signal. Run Process>>preResume for special cases" firstLink ifNotNil: [firstLink preResume]. self primSignal. "We are ignoring the race condition in accessing the first waiting process (firstLink). This is not critical since #preResume only eliminates redundant UI processes. UI redundancy is not fatal and easily fixed using the ProcessBrowser." ! ! !SyntaxMorph methodsFor: 'accessing' stamp: 'ajh 1/20/2002 16:21'! actualObject | sub | "Who is self in these tiles? Usually a Player." (self nodeClassIs: GlobalVariableNode) ifTrue: [ (sub _ self findA: StringMorph) ifNil: [^ nil]. "Need to decompile here for odd synonyms of 'self' ?" ^ Compiler evaluate: sub contents for: Player logged: false]. (self nodeClassIs: VariableNode2) ifTrue: [ (sub _ self findA: StringMorph) ifNil: [^ nil]. ^ References at: (self cleanUpString: sub) asSymbol ifAbsent: [nil]]. (self nodeClassIs: LiteralNode2) ifTrue: [ (sub _ self findA: StringMorph) ifNil: [^ nil]. ^ Compiler evaluate: sub contents for: nil logged: false]. (sub _ self findA: SyntaxMorph) ifNil: [^ nil]. ^ sub actualObject "receiver"! ! !SyntaxMorph methodsFor: 'accessing' stamp: 'ajh 1/20/2002 16:09'! argumentNodes "Return a collection of this message's argument nodes. " | cls coll rec | parseNode ifNil: [^ #()]. cls _ parseNode class. cls == SelectorNode2 ifTrue: [^ #()]. cls == KeyWordNode ifTrue: [^ #()]. coll _ OrderedCollection new. rec _ self receiverNode. submorphs do: [:sub | (sub isSyntaxMorph and: [sub ~~ rec]) ifTrue: [ sub isNoun ifTrue: [coll addLast: sub] "complete arg" ifFalse: [coll _ coll, sub argumentNodes]]]. "MessagePartNode, MessageNode with no receiver" ^ coll! ! !SyntaxMorph methodsFor: 'accessing' stamp: 'ajh 1/20/2002 15:13'! receiverNode "If I am (have) a MessageNode, return the node of the receiver. Watch out for foolish noise words." parseNode class == MessageNode2 ifFalse: [^ nil]. parseNode receiver ifNil: [^ nil]. submorphs do: [:ss | ss isSyntaxMorph ifTrue: [ ss parseNode ifNotNil: ["not noise word" ss isNoun ifTrue: [^ ss] ifFalse: [^ nil "found selector"]]]]. ^ nil! ! !SyntaxMorph methodsFor: 'accessing' stamp: 'ajh 1/20/2002 17:35'! rename: newSelector | keywords mainSel list last | "Attempt to change the name as listed in my tiles. Can change the number of argumtents. MethodNode (SelectorNode (SelectorNode (string))) or MethodNode (SelectorNode (SelectorNode (string) TempVarNode() SelectorNode (string) TempVarNode()))" self isMethodNode ifFalse: [ self rootTile == self ifTrue: [^ self]. "not in a script" ^ self rootTile rename: newSelector "always do at the root"]. keywords _ newSelector keywords. mainSel _ self findA: SelectorNode2. list _ mainSel submorphs select: [:mm | mm isSyntaxMorph and: [mm parseNode class == SelectorNode2]]. 1 to: (list size min: keywords size) do: [:ind | ((list at: ind) findA: UpdatingStringMorph) contents: (keywords at: ind)]. keywords size + 1 to: list size do: [:ind | "removing keywords" [last _ mainSel submorphs last. (last isSyntaxMorph and: [last parseNode isKindOf: LocalVariableNode])] whileFalse: [ last delete]. [last _ mainSel submorphs last. (last isSyntaxMorph and: [last parseNode class == SelectorNode2])] whileFalse: [ last delete]. "the TempVariableNode and others" mainSel submorphs last delete. "the SelectorNode" ]. list size + 1 to: keywords size do: [:ind | "adding keywords" "add a SelectorNode, add a spacer, add a TempVarNode" mainSel addToken: (keywords at: ind) type: #keyword1 on: (SelectorNode2 new symbol: (keywords at: ind)). mainSel addMorphBack: (mainSel transparentSpacerOfSize: 4@4). (TempVariableNode2 new name: 'arg', ind printString offset: ind scope: nil) asMorphicSyntaxIn: mainSel].! ! !SyntaxMorph methodsFor: 'accessing' stamp: 'ajh 1/20/2002 16:10'! selector | sel cnt | "Find the selector I represent, or have inside of me. My parseNode is a SelectorNode or a MessageNode." parseNode class == SelectorNode2 ifTrue: [ ^ self decompile asString asSymbol]. parseNode class == KeyWordNode ifTrue: [ ^ self decompile asString asSymbol]. (parseNode class == MessageNode2) | (parseNode class == MessagePartNode) ifFalse: [^ nil]. "Must be one of those to have a selector" "Beware of messageParts. If MessagePartNode, only returns this one keyword." sel _ ''. cnt _ 0. submorphs do: [:mm | mm isSyntaxMorph ifTrue: [ cnt _ cnt + 1. (mm nodeClassIs: SelectorNode2) ifTrue: [^ mm selector]. (mm nodeClassIs: MessagePartNode) ifTrue: [ sel _ sel, mm selector]. (mm nodeClassIs: KeyWordNode) ifTrue: [ sel _ sel, mm decompile asString]. (mm nodeClassIs: ReturnNode2) ifTrue: [cnt _ cnt - 1]. (mm nodeClassIs: MessageNode2) ifTrue: [ parseNode receiver ifNil: [sel _ mm selector]. cnt = 2 & (sel size = 0) ifTrue: ["not the receiver. Selector and arg" sel _ mm selector]]]]. sel ifNil: [^ nil]. sel size > 0 ifTrue: [^ sel asSymbol]. ^ nil! ! !SyntaxMorph methodsFor: 'node types' stamp: 'ajh 1/20/2002 16:25'! isAVariable "There are three kinds of variable nodes" (parseNode class isKindOf: VariableNode2) ifFalse: [^ false]. ^ (ClassBuilder new reservedNames includes: self decompile string withoutTrailingBlanks) not! ! !SyntaxMorph methodsFor: 'node types' stamp: 'ajh 1/20/2002 15:03'! isBlockNode ^ parseNode class == BlockNode2! ! !SyntaxMorph methodsFor: 'node types' stamp: 'ajh 1/20/2002 16:09'! isDeclaration "Return true if I am a TempVarNode inside a declaration of some kind, including a method arg" | opc | owner isSyntaxMorph ifFalse: [^ false]. opc _ owner parseNode class. opc == BlockArgsNode ifTrue: [^ true]. opc == MethodTempsNode ifTrue: [^ true]. opc == SelectorNode2 ifTrue: [^ true]. ^ false! ! !SyntaxMorph methodsFor: 'node types' stamp: 'ajh 1/20/2002 15:15'! isMethodNode ^ parseNode class == MethodNode2! ! !SyntaxMorph methodsFor: 'node types' stamp: 'ajh 1/20/2002 15:12'! isNoun "Consider these to be nouns: MessageNode with receiver, CascadeNode with receiver, AssignmentNode, TempVariableNode, LiteralNode, VariableNode, LiteralVariableNode." (#(TempVariableNode LiteralNode VariableNode LiteralVariableNode) includes: (parseNode class name)) ifTrue: [^ true]. (self nodeClassIs: MessageNode2) ifTrue: [^ parseNode receiver notNil]. (self nodeClassIs: CascadeNode2) ifTrue: [^ parseNode receiver notNil]. (self nodeClassIs: AssignmentNode2) ifTrue: [^ submorphs size >= 3]. ^ false! ! !SyntaxMorph methodsFor: 'node types' stamp: 'ajh 1/20/2002 16:26'! isSelfTile ^ (parseNode class isKindOf: VariableNode2) and: [self decompile asString = 'self '] ! ! !SyntaxMorph methodsFor: 'node types' stamp: 'ajh 1/20/2002 17:34'! nodeClassIsKindOf: aParseNodeClass "Test the class of my parseNode" ^ parseNode isKindOf: aParseNodeClass! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'ajh 1/20/2002 17:34'! acceptDroppingMorph: aMorph event: evt | itNoun old | "Two cases: 1) a phrase being dropped into a block. Add a new line. 2) aMorph is replacing self by dropping on it. For the moment, you have to drop it the right place (the end of a tile if it is complex). We do not look at enclosing morphs" itNoun _ aMorph isNoun. self withAllOwnersDo: [:m | (m isSyntaxMorph and: [m isBlockNode]) ifTrue: [m stopStepping; removeDropZones]]. self isBlockNode & itNoun ifTrue: [(aMorph nodeClassIsKindOf: LocalVariableNode) ifTrue: ["If I am a BlockNode, and it is a TempVariableNode, add it into list" (self addBlockArg: aMorph)]. "If I am a BlockNode and it is a noun add it as a new line" ^ self addToBlock: aMorph event: evt]. self isBlockNode ifTrue: [ (aMorph nodeClassIs: CommentNode) ifTrue: [^ self addToBlock: aMorph event: evt]. (aMorph nodeClassIs: ReturnNode2) ifTrue: [^ self addToBlock: aMorph event: evt]]. "Later add args and keywords. later allow comments to be dropped" "Can't put statement, literal, assignment, or cascade into left side of assignment" (owner isSyntaxMorph) ifTrue: [(owner nodeClassIs: AssignmentNode2) ifTrue: [(owner submorphIndexOf: self) = 1 ifTrue: [aMorph isAVariable ifFalse: [ ^ self]]]]. (aMorph nodeClassIs: AssignmentNode2) ifTrue: [ itNoun ifFalse: ["create a new assignment" self isAVariable ifTrue: [^ self newAssignment] ifFalse: [^ self]]]. "only assign to a variable" aMorph deselect. (old _ owner) replaceSubmorph: self by: aMorph. "do the normal replacement" (old isSyntaxMorph) ifTrue: [old cleanupAfterItDroppedOnMe]. "now owned by no one" ! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'ajh 1/20/2002 16:05'! structureMatchWith: aMorph | meNoun itNoun | "Return true if the node types would allow aMorph to replace me. This tests the gross structure of the method only." meNoun _ self isNoun. itNoun _ aMorph isNoun. "Consider these nouns to be equal: TempVariableNode, LiteralNode, VariableNode, (MessageNode with receiver), CascadeNode, AssignmentNode" meNoun & itNoun ifTrue: [^ true]. meNoun & aMorph isBlockNode ifTrue: [^ true]. "If I am a BlockNode, and it is a TempVariableNode, add it into list" "If I am a BlockNode, and it is a noun, add it as a new line" self isBlockNode ifTrue: [itNoun ifTrue: [^ true]. (aMorph nodeClassIs: ReturnNode2) ifTrue: [^ (self submorphs detect: [:mm | ((mm isSyntaxMorph) and: [mm nodeClassIs: ReturnNode2])] ifNone: [nil]) isNil]. "none already in this block" "If I am a BlockNode, and it is a ReturnNode, add to end" (aMorph nodeClassIs: CommentNode) ifTrue: [^ true]]. (self isMethodNode) ifTrue: [^ false]. "Later add args and keywords" "Later allow comments to be dropped in" "Add MethodTemps by dropping into the main block" (self nodeClassIs: ReturnNode2) & (aMorph parseNode class == MessageNode2) ifTrue: [^ true]. "Command replace Return" (self nodeClassIs: MessageNode2) & (aMorph parseNode class == ReturnNode2) ifTrue: [ (owner submorphs select: [:ss | ss isSyntaxMorph]) last == self ifTrue: [^ true]]. "Return replace last command" (aMorph nodeClassIs: AssignmentNode2) ifTrue: [ itNoun ifFalse: ["create a new assignment" ^ self isAVariable & self isDeclaration not]]. "only assign to a variable" "If nodes are of equal class, replace me with new one." (self nodeClassIs: aMorph parseNode class) ifTrue: [ (self nodeClassIs: MessageNode2) ifFalse: [^ true] "normal match" ifTrue: [^ self receiverNode == aMorph receiverNode]]. "both nil" ^ false "otherwise reject" ! ! !SyntaxMorph methodsFor: 'selection' stamp: 'ajh 1/20/2002 15:15'! select self deselect. "Outer block is not colored and has no popup" (owner isSyntaxMorph and: [owner nodeClassIs: MethodNode2]) ifTrue: [self setDeselectedColor "normal"] ifFalse: [self color: Color lightBrown]. self borderColor: #raised. self offerPopUp.! ! !SyntaxMorph methodsFor: 'layout' stamp: 'ajh 1/20/2002 16:04'! addToBlock: aMorph event: evt "Insert a new line of code. Figure out who it goes before. If evt Y is within an existing line (to the right of a tile), then replace that tile." | whereDropped dropBefore replace | whereDropped _ "self pointFromWorld:" evt cursorPoint. dropBefore _ self submorphs detect: [:each | each isSyntaxMorph ifTrue: [ whereDropped y < each top ifTrue: [true] "before this one" ifFalse: [whereDropped y < each bottom ifTrue: [replace _ true] "replace this one" ifFalse: [false]]]] "try next line" ifNone: [nil]. (aMorph nodeClassIs: ReturnNode2) ifTrue: [dropBefore _ nil]. "Returns are always at the end. (Watch out for comments)" dropBefore ifNil: [self addMorphBack: aMorph] ifNotNil: [ replace ifNotNil: [aMorph deselect. self replaceSubmorph: dropBefore by: aMorph. "replace it!!" ^ dropBefore cleanupAfterItDroppedOnMe]. "now owned by no one" self addMorph: aMorph inFrontOf: dropBefore]. self cleanupAfterItDroppedOnMe. ! ! !SyntaxMorph methodsFor: 'layout' stamp: 'ajh 1/20/2002 15:04'! removeReturnNode | blk | "If last line is ^ self, remove it. I am a methodNode. Keep if no other tiles in the block." blk _ self findA: BlockNode2. blk submorphs last decompile string = '^self ' ifTrue: [ (blk submorphs count: [:ss | ss isSyntaxMorph]) > 1 ifTrue: [ blk submorphs last delete]].! ! !SyntaxMorph methodsFor: 'layout' stamp: 'ajh 1/20/2002 17:36'! tempVarNodesDo: aBlock "Execute the block for any block temporary variables, method temps, or method args we have" | tempHolder argsHolder | ((self parseNode class == MethodNode2) or: [self parseNode class == BlockNode2]) ifTrue: [ self submorphsDoIfSyntax: [:sub | (sub nodeClassIs: MethodTempsNode) ifTrue: [tempHolder _ sub]. ((sub nodeClassIs: UndefinedObject) and: [tempHolder isNil]) ifTrue: [ tempHolder _ sub findA: MethodTempsNode]. (sub nodeClassIs: BlockArgsNode) ifTrue: [tempHolder _ sub]. (sub nodeClassIs: SelectorNode2) ifTrue: [argsHolder _ sub]. ] ifString: [:sub | ]. tempHolder ifNotNil: ["Temp variables" tempHolder submorphsDoIfSyntax: [:sm | (sm nodeClassIsKindOf: LocalVariableNode) ifTrue: [aBlock value: sm]] ifString: [:sm | ]]. argsHolder ifNotNil: ["arguments" argsHolder submorphsDoIfSyntax: [:sm | (sm nodeClassIsKindOf: LocalVariableNode) ifTrue: [aBlock value: sm]] ifString: [:sm | ]]. ]. "otherwise do nothing"! ! !SyntaxMorph methodsFor: 'printing' stamp: 'ajh 1/20/2002 16:10'! printMethodNodeOn: strm indent: level (self findA: SelectorNode2) ifNil: [ (self getHeader: strm) ifFalse: [^ self]. "might fail" strm crtab: level]. self submorphsDoIfSyntax: [ :sub | sub printOn: strm indent: level. strm crtab: level. ] ifString: [ :sub | self printSimpleStringMorph: sub on: strm ]. strm last == $. ifTrue: [strm skip: -1]. "ugh!! erase duplicate final period"! ! !SyntaxMorph methodsFor: 'printing' stamp: 'ajh 1/20/2002 16:28'! printOn: strm indent: level | nodeClass | (self hasProperty: #ignoreNodeWhenPrinting) ifFalse: [ nodeClass _ parseNode class. (parseNode isKindOf: VariableNode) ifTrue: [^self printVariableNodeOn: strm indent: level]. nodeClass == MessageNode2 ifTrue: [^self printMessageNodeOn: strm indent: level]. nodeClass == BlockNode2 ifTrue: [^self printBlockNodeOn: strm indent: level]. nodeClass == BlockArgsNode ifTrue: [^self printBlockArgsNodeOn: strm indent: level]. nodeClass == MethodNode2 ifTrue: [^self printMethodNodeOn: strm indent: level]. nodeClass == MethodTempsNode ifTrue: [^self printMethodTempsNodeOn: strm indent: level]. nodeClass == CascadeNode2 ifTrue: [^self printCascadeNodeOn: strm indent: level]. nodeClass == AssignmentNode2 ifTrue: [^self printAssignmentNodeOn: strm indent: level]. ]. self submorphsDoIfSyntax: [ :sub | sub printOn: strm indent: level. strm ensureASpace. ] ifString: [ :sub | self printSimpleStringMorph: sub on: strm ]. ! ! !SyntaxMorph methodsFor: 'printing' stamp: 'ajh 1/20/2002 15:13'! structure "Print my structure from inner to outer." ^ String streamContents: [:s | self withAllOwnersDo: [:m | m isSyntaxMorph ifTrue: [s cr; print: m parseNode class. ((m nodeClassIs: MessageNode2) or: [m nodeClassIs: TileMessageNode]) ifTrue: [s space; nextPutAll: m parseNode selector key]]]]! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:11'! colorChangedForSubmorph: colorPatch | sel newSel cc ms phrase completeMsg | "reporting a color change" (self nodeClassIs: MessageNode2) ifFalse: [^ nil]. (sel _ self selector) ifNil: [^ nil]. (Color colorNames includes: sel) | (sel == #r:g:b:) ifFalse: [^ nil]. "a standard color name" "replace self with new tiles from the color" (newSel _ (cc _ colorPatch color) name) ifNil: [ms _ MessageSend receiver: Color selector: #r:g:b: arguments: (Array with: cc red with: cc green with: cc blue). phrase _ ms asTilesIn: Color globalNames: true] ifNotNil: [ms _ MessageSend receiver: Color selector: newSel arguments: #(). phrase _ ms asTilesIn: Color globalNames: true]. self deletePopup. completeMsg _ self isNoun ifTrue: [self] ifFalse: [owner]. completeMsg owner replaceSubmorph: completeMsg by: phrase. "rec setSelection: {rec. nil. rec}." phrase acceptIfInScriptor.! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:11'! colorPatch "Return a color patch button that lets the user choose a color and modifies the code" | cc patch sel completeMsg | ((self nodeClassIs: MessageNode2) "or: [self nodeClassIs: SelectorNode]") ifFalse: [^ nil]. (sel _ self selector) ifNil: [^ nil]. (Color colorNames includes: sel) | (sel == #r:g:b:) ifFalse: [^ nil]. "a standard color name" completeMsg _ self isNoun ifTrue: [self] ifFalse: [owner isNoun ifTrue: [owner] ifFalse: [owner owner]]. (cc _ completeMsg try) class == Color ifFalse: [^ nil]. patch _ ColorTileMorph new colorSwatchColor: cc. "sends colorChangedForSubmorph: to the messageNode" patch color: Color transparent; borderWidth: 0. patch submorphs last delete. ^ patch! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:03'! dismisser "Return the icon to delete this line of tiles. I am an entire line in a block." | handle handleSpec colorToUse iconName form | (owner isSyntaxMorph and: [owner nodeClassIs: BlockNode2]) ifFalse: [^ nil]. handleSpec _ Preferences haloSpecifications fourth. "dismiss" handle _ EllipseMorph newBounds: (Rectangle center: 10@10 extent: 16 asPoint) color: (colorToUse _ Color colorFrom: handleSpec color). iconName _ handleSpec iconSymbol. form _ ScriptingSystem formAtKey: iconName. "#'Halo-Dismiss'" handle addMorphCentered: (ImageMorph new image: form; color: colorToUse makeForegroundColor; lock). handle on: #mouseDown send: #deleteLine to: self. ^ handle! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 14:59'! newAssignment "I am a variableNode. Place me inside an assignment statement." | new old | parseNode name: self decompile. "in case user changed name" new _ owner assignmentNode: AssignmentNode2 new variable: parseNode value: parseNode copy. self deselect. (old _ owner) replaceSubmorph: self by: new. "do the normal replacement" (old isSyntaxMorph) ifTrue: [old cleanupAfterItDroppedOnMe]. "now owned by no one" ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:06'! replaceKeyWord: evt menuItem: stringMorph "Replace my entire message (which may be multi-part) with the one specified. Preserve all argument tiles, either in the new message or in the world outside the scriptor. I am a SelectorNode or KeyWordNode." | menu new news newSel mm newTree newRec newArgs top oldArgNodes share ctrY | (menu _ stringMorph owner owner) class == RectangleMorph ifTrue: [ menu delete]. new _ stringMorph contents. new first = $( ifTrue: [^ self]. "Cancel" new first = $ ifTrue: [^ self]. "nothing" news _ String streamContents: [:strm | "remove fake args" (new findBetweenSubStrs: #(' 5' $ )) do: [:part | strm nextPutAll: part]]. newSel _ stringMorph valueOfProperty: #syntacticallyCorrectContents. newSel ifNil: [newSel _ news]. mm _ MessageSend receiver: 5 selector: newSel arguments: ((Array new: newSel numArgs) atAllPut: 5). newTree _ mm asTilesIn: Object globalNames: false. newRec _ newTree receiverNode. newArgs _ newTree argumentNodes. ctrY _ self fullBoundsInWorld center y. top _ self messageNode. newRec owner replaceSubmorph: newRec by: top receiverNode. oldArgNodes _ top argumentNodes. share _ newArgs size min: oldArgNodes size. (newArgs first: share) with: (oldArgNodes first: share) do: [:newNode :oldNode | newNode owner replaceSubmorph: newNode by: oldNode]. "later get nodes for objects of the right type for new extra args" top owner replaceSubmorph: top by: newTree. "Deposit extra args in the World" (oldArgNodes copyFrom: share+1 to: oldArgNodes size) do: [:leftOver | (leftOver parseNode class == LiteralNode2 and: [leftOver decompile asString = '5']) ifFalse: [newTree pasteUpMorph addMorphFront: leftOver. leftOver position: newTree enclosingPane fullBoundsInWorld right - 20 @ ctrY. ctrY _ ctrY + 26] ifTrue: [leftOver delete]]. newTree acceptIfInScriptor.! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:05'! retract "replace this message with its receiver. I am the message node." | rec cascade msg | (self nodeClassIs: CascadeNode2) ifTrue: ["This is a piece of a cascaded message -- just delete it" self deletePopup. cascade _ owner. self delete. cascade setSelection: {cascade. nil. cascade}. ^ cascade acceptIfInScriptor]. self deletePopup. (rec _ self receiverNode) ifNil: [msg _ owner. rec _ owner receiverNode. msg owner replaceSubmorph: msg by: rec] ifNotNil: [owner replaceSubmorph: self by: rec]. rec setSelection: {rec. nil. rec}. rec acceptIfInScriptor.! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:13'! retractArrow "Return the retract arrow button. It replaces the current message with its receiver. I am in a MessageNode whose first subnode is not a MessagePartNode. I did not encounter a block on the way up to it. I am the last subnode in every owner up to it." | patch | (self nodeClassIs: MessageNode2) ifFalse: [^ nil]. (owner isSyntaxMorph and: [owner parseNode == parseNode]) ifTrue: [^ nil]. patch _ (ImageMorph new image: (TileMorph classPool at: #RetractPicture)). patch on: #mouseDown send: #retract to: self. ^ patch! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 16:32'! upDown: delta event: evt arrow: arrowMorph | st | st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self]. (self nodeClassIs: LiteralNode2) ifTrue: [ (#('true' 'false') includes: self decompile string) ifTrue: [ "true/false" st contents: (self decompile string = 'true') not printString. ^ self acceptSilently ifFalse: [self changed]. "maybe set parseNode's key" ] ifFalse: [ "+/- 1" st contents: (self decompile asNumber + delta) printString. ^ self acceptUnlogged ] ]. (self upDownArithOp: delta) ifTrue: [^ self]. "+ - // * < > <= = beep:" (self upDownAssignment: delta) ifTrue: [^ self]. "Handle assignment -- increaseBy: <- multiplyBy:" ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 16:10'! upDownArithOp: delta "Change a + into a -. Also do sounds (change the arg to the beep:)." | aList index st | st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self]. (self nodeClassIs: SelectorNode2) ifTrue: [aList _ #(+ - * / // \\ min: max:). (index _ aList indexOf: self decompile asString) > 0 ifTrue: [self setSelector: (aList atWrap: index + delta) in: st. ^ true]. aList _ #(= ~= > >= isDivisibleBy: < <=). (index _ aList indexOf: self decompile asString) > 0 ifTrue: [self setSelector: (aList atWrap: index + delta) in: st. ^ true]. aList _ #(== ~~). (index _ aList indexOf: self decompile asString) > 0 ifTrue: [self setSelector: (aList atWrap: index + delta) in: st. ^ true]. 'beep:' = self decompile asString ifTrue: ["replace sound arg" self changeSound: delta. self acceptSilently. ^ true]. ]. ^ false! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 16:32'! upDownArrows "Return an array of two up/down arrow buttons. It replaces the selector or arg with a new one. I am a number or boolean or a selector (beep:, +,-,*,//,\\, or setX: incX: decX: for any X." | patch any noMenu | any _ (self nodeClassIs: LiteralNode2) and: [parseNode key isNumber]. any _ any or: [(self nodeClassIs: LiteralNode2) and: [(#('true' 'false') includes: self decompile asString)]]. noMenu _ any. any _ any or: [self nodeClassIs: SelectorNode2]. "arrows and menu of selectors" any _ any or: [self nodeClassIs: KeyWordNode]. any ifFalse: [^ nil]. patch _ {(ImageMorph new image: TileMorph upPicture) on: #mouseDown send: #upDown:event:arrow: to: self withValue: 1; on: #mouseStillDown send: #upDownMore:event:arrow: to: self withValue: 1; on: #mouseUp send: #upDownDone to: self. (ImageMorph new image: TileMorph downPicture) on: #mouseDown send: #upDown:event:arrow: to: self withValue: -1; on: #mouseStillDown send: #upDownMore:event:arrow: to: self withValue: -1; on: #mouseUp send: #upDownDone to: self}. noMenu ifFalse: [patch _ patch, {(RectangleMorph new) extent: 6@10; borderWidth: 1; borderColor: Color gray; on: #mouseUp send: #selectorMenu to: self}. patch last color: ((self nodeClassIs: SelectorNode2) ifTrue: [Color lightGreen] ifFalse: [Color red darker])]. ^ patch! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 16:11'! upDownAssignment: delta "Rotate between increaseBy: decreaseBy: _ multiplyBy:" | st now want instVar | st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self]. (self nodeClassIs: SelectorNode2) ifTrue: ["kinds of assignment" ((now _ self decompile asString) beginsWith: 'set') ifTrue: ["a setX: 3" want _ 1+delta. instVar _ (now allButFirst: 3) allButLast]. (now endsWith: 'IncreaseBy:') ifTrue: ["a xIncreaseBy: 3 a setX: (a getX +3)." want _ 2+delta. instVar _ now allButLast: 11]. (now endsWith: 'DecreaseBy:') ifTrue: ["a xDecreaseBy: 3 a setX: (a getX -3)." want _ 3+delta. instVar _ now allButLast: 11]. (now endsWith: 'MultiplyBy:') ifTrue: ["a xMultiplyBy: 3 a setX: (a getX *3)." want _ 4+delta. instVar _ now allButLast: 11]. want ifNil: [^ false]. instVar _ instVar asLowercase. want _ #(1 2 3 4) atWrap: want. want = 1 ifTrue: ["setter method is present" self setSelector: ('set', instVar capitalized, ':') in: st. ^ true]. want = 2 ifTrue: ["notUnderstood will create the method if needed" self setSelector: instVar, 'IncreaseBy:' in: st. ^ true]. want = 3 ifTrue: ["notUnderstood will create the method if needed" self setSelector: instVar, 'DecreaseBy:' in: st. ^ true]. want = 4 ifTrue: ["notUnderstood will create the method if needed" self setSelector: instVar, 'MultiplyBy:' in: st. ^ true]. ]. ^ false ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:06'! upDownDone (self nodeClassIs: LiteralNode2) ifTrue: [self acceptSilently. "Final compilation logs source" self removeProperty: #timeOfLastTick; removeProperty: #currentDelay]. ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ajh 1/20/2002 15:06'! upDownMore: delta event: evt arrow: arrowMorph | st delay1 delay2 now timeOfLastTick currentDelay | (self nodeClassIs: LiteralNode2) ifFalse: [^ self]. st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self]. delay1 _ 300. "ms" delay2 _ 50. "ms" now _ Time millisecondClockValue. timeOfLastTick _ (self valueOfProperty: #timeOfLastTick) ifNil: [now - delay1]. currentDelay _ (self valueOfProperty: #currentDelay) ifNil: [delay1]. now >= (timeOfLastTick + currentDelay) ifTrue: [self setProperty: #timeOfLastTick toValue: now. "decrease the delay" self setProperty: #currentDelay toValue: (currentDelay*8//10 max: delay2). st contents: (self decompile asNumber + delta) printString. ^ self acceptUnlogged]. ! ! !SyntaxMorph methodsFor: 'new tiles' stamp: 'ajh 1/20/2002 16:22'! attachTileForCode: expression nodeType: nodeClass | nn master tile | "create a new tile for a part of speech, and put it into the hand" "a few special cases" expression = 'self' ifTrue: [ ^ (((self string: expression toTilesIn: Object) findA: ReturnNode2) findA: nodeClass) attachToHand]. expression = '' ifTrue: ["Tile for the variable in References" nn _ nodeClass knownName ifNil: [#+]. (References at: nn asSymbol ifAbsent: [nil]) == nodeClass ifTrue: [ ^ self attachTileForCode: nn nodeType: GlobalVariableNode]. "otherwise just give a tile for self" ^ self attachTileForCode: 'self' nodeType: SpecialVariableNode]. expression = '' ifTrue: ["do something really special" master _ self class new. master addNoiseString: ' _ ' emphasis: 1. tile _ master firstSubmorph. ^ (tile parseNode: AssignmentNode2 new) attachToHand]. "special marker" "When this is dropped on a variable, enclose it in a new assignment statement" "general case -- a tile for a whole line of code is returned" ^ ((self string: expression toTilesIn: Object) findA: nodeClass) attachToHand.! ! !SyntaxMorph methodsFor: 'new tiles' stamp: 'ajh 1/20/2002 16:24'! instVarTile: aName "Make and put into hand a tile for an instance variable" | sm | sm _ ((ReceiverVariableNode new name: aName offset: 1) asMorphicSyntaxIn: SyntaxMorph new). sm roundedCorners. ActiveHand attachMorph: sm. Preferences tileTranslucentDrag ifTrue: [sm lookTranslucent. sm align: sm center with: ActiveHand position "+ self cursorBaseOffset"] ifFalse: [sm align: sm topLeft with: ActiveHand position + self cursorBaseOffset] ! ! !SyntaxMorph methodsFor: 'new tiles' stamp: 'ajh 1/20/2002 15:04'! string: anExpression toTilesIn: playerClass | code tree methodNode | "Construct SyntaxMorph tiles for some code. Returns the main BlockNode of a doIt." "This is really cheating!! Make a true parse tree later. -tk" code _ String streamContents: [:strm | strm nextPutAll: 'doIt'; cr; tab; nextPutAll: anExpression]. "decompile to tiles" tree _ Compiler new parse: code in: playerClass notifying: nil. methodNode _ tree asMorphicSyntaxUsing: SyntaxMorph. anExpression first == $" ifTrue: ["a comment" "(methodNode findA: CommentNode) firstSubmorph color: Color blue." ^ methodNode]. ^ methodNode submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [mm parseNode class == BlockNode2] ifFalse: [false]]. ! ! !SyntaxMorph methodsFor: 'menus' stamp: 'ajh 1/20/2002 16:27'! offerTilesMenuFor: aReceiver in: aLexiconModel "Offer a menu of tiles for assignment and constants" | menu | menu _ MenuMorph new addTitle: 'Hand me a tile for...'. menu addLine. menu add: '(accept method now)' target: aLexiconModel selector: #acceptTiles. menu submorphs last color: Color red darker. menu addLine. menu add: 'me, by name' target: self selector: #attachTileForCode:nodeType: argumentList: {''. aReceiver}. menu add: 'self' target: self selector: #attachTileForCode:nodeType: argumentList: {'self'. SpecialVariableNode}. menu add: '_ (assignment)' target: self selector: #attachTileForCode:nodeType: argumentList: {''. nil}. menu add: '"a Comment"' target: self selector: #attachTileForCode:nodeType: argumentList: {'"a comment"\' withCRs. CommentNode}. menu submorphs last color: Color blue. menu add: 'a Number' target: self selector: #attachTileForCode:nodeType: argumentList: {'5'. LiteralNode2}. menu add: 'a Character' target: self selector: #attachTileForCode:nodeType: argumentList: {'$z'. LiteralNode2}. menu add: '''abc''' target: self selector: #attachTileForCode:nodeType: argumentList: {'''abc'''. LiteralNode2}. menu add: 'a Symbol constant' target: self selector: #attachTileForCode:nodeType: argumentList: {'#next'. LiteralNode2}. menu add: 'true' target: self selector: #attachTileForCode:nodeType: argumentList: {'true'. LiteralNode2}. menu add: 'a Test' target: self selector: #attachTileForCode:nodeType: argumentList: {'true ifTrue: [self] ifFalse: [self]'. MessageNode2}. menu add: 'a Loop' target: self selector: #attachTileForCode:nodeType: argumentList: {'1 to: 10 do: [:index | self]'. MessageNode2}. menu add: 'a Block' target: self selector: #attachTileForCode:nodeType: argumentList: {'[self]'. BlockNode2}. menu add: 'a Class or Global' target: self selector: #attachTileForCode:nodeType: argumentList: {'Character'. GlobalVariableNode}. menu add: 'a Reply' target: self selector: #attachTileForCode:nodeType: argumentList: {'| temp | temp'. ReturnNode2}. menu popUpAt: ActiveHand position forHand: ActiveHand in: World. ! ! !SyntaxMorph methodsFor: 'menus' stamp: 'ajh 1/20/2002 16:13'! offerVarsMenuFor: aReceiver in: aLexiconModel "Offer a menu of tiles for assignment and constants" | menu instVarList cls | menu _ MenuMorph new addTitle: 'Hand me a tile for...'. menu addLine. menu add: '(accept method now)' target: aLexiconModel selector: #acceptTiles. menu submorphs last color: Color red darker. menu addLine. menu add: 'new temp variable' target: self selector: #attachTileForCode:nodeType: argumentList: {'| temp | temp'. TempVariableNode2}. instVarList _ OrderedCollection new. cls _ aReceiver class. [instVarList addAllFirst: cls instVarNames. cls == aLexiconModel limitClass] whileFalse: [cls _ cls superclass]. instVarList do: [:nn | menu add: nn target: self selector: #instVarTile: argument: nn]. menu popUpAt: ActiveHand position forHand: ActiveHand in: World. ! ! !SyntaxMorph methodsFor: 'menus' stamp: 'ajh 1/20/2002 16:17'! showMenu: evt | menu | menu _ MenuMorph new. self rootTile isMethodNode ifTrue: [menu add: 'accept method' target: self selector: #accept. menu addLine. menu add: 'new temp variable' target: self selector: #attachTileForCode:nodeType: argumentList: {'| temp | temp'. TempVariableNode2}. menu addLine. self parsedInClass allInstVarNames do: [:nn | menu add: nn,' tile' target: self selector: #instVarTile: argument: nn]. menu addLine. menu add: 'show code' target: self selector: #showCode. menu add: 'try out' target: self selector: #try. menu popUpAt: evt hand position forHand: evt hand in: World]. ! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'ajh 1/20/2002 16:09'! okToBeReplacedBy: aSyntaxMorph "Return true if it is OK to replace me with aSyntaxMorph. Enforce the type rules in the old EToy green tiles." | itsType myType | (Preferences eToyFriendly or: [Preferences typeCheckingInTileScripting]) ifFalse: [^ true]. "not checking unless one of those prefs is true" (parseNode class == BlockNode2 and: [aSyntaxMorph parseNode class == BlockNode2]) ifTrue: [^ true]. (parseNode class == ReturnNode2 and: [aSyntaxMorph parseNode class == ReturnNode2]) ifTrue: [^ true]. parseNode class == KeyWordNode ifTrue: [^ false]. aSyntaxMorph parseNode class == KeyWordNode ifTrue: [^ false]. parseNode class == SelectorNode2 ifTrue: [^ false]. aSyntaxMorph parseNode class == SelectorNode2 ifTrue: [^ false]. owner isSyntaxMorph ifFalse: [^ true]. "only within a script" "Transcript show: aSyntaxMorph resultType printString, ' dropped on ', self receiverOrArgType printString; cr. " (itsType _ aSyntaxMorph resultType) == #unknown ifTrue: [^ true]. (myType _ self receiverOrArgType) == #unknown ifTrue: [^ true]. "my type in enclosing message" ^ myType = itsType! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'ajh 1/20/2002 15:13'! receiverOrArgTypeAbove | enclosing sub list | "Return the type for me according to the message that encloses me." (self nodeClassIs: BlockNode2) ifTrue: [^ #command]. enclosing _ owner. sub _ self. [enclosing isSyntaxMorph ifFalse: [^ #unknown]. (enclosing nodeClassIs: MessageNode2) ifTrue: [ list _ enclosing submorphs select: [:ss | ss isSyntaxMorph and: [ss parseNode ~~ nil]]. list size = 1 ifFalse: [ ^ (list indexOf: sub) = 1 ifTrue: [enclosing receiverTypeFor: enclosing selector] ifFalse: [enclosing argTypeFor: enclosing selector]]]. (enclosing nodeClassIs: BlockNode2) ifTrue: [^ #command]. sub _ enclosing. enclosing _ enclosing owner. true] whileTrue.! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'ajh 1/20/2002 16:05'! resultType "Look up my result type. If I am a constant, use that class. If I am a message, look up the selector." | list value soundChoices | parseNode class == BlockNode2 ifTrue: [^ #blockContext]. parseNode class == AssignmentNode2 ifTrue: [^ #command]. parseNode class == ReturnNode2 ifTrue: [^ #command]. "Need more restriction than this" list _ submorphs select: [:ss | ss isSyntaxMorph and: [ss parseNode ~~ nil]]. list size > 1 ifTrue: [^ self resultTypeFor: self selector]. list size = 1 ifTrue: ["test for levels that are just for spacing in layout" (list first isSyntaxMorph and: [list first nodeClassIs: MessageNode2]) ifTrue: [ ^ list first resultType]]. "go down one level" value _ self try. value class == Error ifTrue: [^ #unknown]. (value isKindOf: Number) ifTrue: [^ #Number]. (value isKindOf: Boolean) ifTrue: [^ #Boolean]. (value isKindOf: Form) ifTrue: [^ #Graphic]. value class == String ifTrue: [ soundChoices _ #('silence'). "default, if no SampledSound class" Smalltalk at: #SampledSound ifPresent: [:sampledSound | soundChoices _ sampledSound soundNames]. (soundChoices includes: value) ifTrue: [^ #Sound]]. (value isKindOf: Player) ifTrue: [^ #Player]. ^ value class name asLowercase "asSymbol (not needed)"! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:07'! alanBinaryPostRcvr: aNode key: key args: args | nodeWithNilReceiver row | "== Repeat for collection [ collect ( from foo. blah blah foo blah) ] Repeat for 1 to 50Ê [ doÊ ( from i. blah blab i blahÊ )Ê ] ==" nodeWithNilReceiver _ aNode copy receiver: nil. (row _ self addRow: #keyword2 on: nodeWithNilReceiver) borderWidth: 1; parseNode: (nodeWithNilReceiver as: MessageNode2); borderColor: row stdBorderColor. row addToken: key asString type: #binary on: (SelectorNode2 new symbol: key). args first asMorphicSyntaxIn: row. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:07'! alanKeywordMessage: aNode isAConditional: template key: key args: args | nodeWithNilReceiver column keywords row onlyOne | (key == #collect: and: [args first isKindOf: BlockNode2]) ifTrue: [ ^self alanKwdCollect: aNode isAConditional: template key: key args: args ]. key == #repeatFor:doing: ifTrue: [ ^self alanKwdRepeatForDoing: aNode isAConditional: template key: key args: args ]. key == #if:do: ifTrue: [ ^self alanKwdIfDo: aNode isAConditional: template key: key args: args ]. (args size = 1 and: [key endsWith: 'Getz:']) ifTrue: [ ^self alanKwdSetter: aNode isAConditional: 0 key: key args: args ]. (args size = 1 and: [self isStandardSetterKeyword: key]) ifTrue: [ ^self alanKwdSetter2: aNode isAConditional: 0 key: key args: args ]. nodeWithNilReceiver _ aNode copy receiver: nil. template = 1 ifTrue: [ self listDirection: #topToBottom. ]. column _ self addColumn: #keyword1 on: nodeWithNilReceiver. keywords _ key keywords. onlyOne _ args size = 1. onlyOne ifFalse: ["necessary for three keyword messages!!" column setProperty: #deselectedBorderColor toValue: column compoundBorderColor]. keywords with: (args first: keywords size) do: [:kwd :arg | template = 1 ifTrue: [ column addMorphBack: (column transparentSpacerOfSize: 3@3). ]. (row _ column addRow: #keyword2 on: nodeWithNilReceiver) parseNode: (nodeWithNilReceiver as: (onlyOne ifTrue: [MessageNode2] ifFalse: [MessagePartNode])); borderColor: row stdBorderColor. template = 1 ifTrue: [row addMorphBack: (row transparentSpacerOfSize: 20@6)]. row addToken: kwd type: #keyword2 on: (onlyOne ifTrue: [SelectorNode2 new symbol: kwd] ifFalse: [KeyWordNode new]). (arg asMorphicSyntaxIn: row) setConditionalPartStyle. ]. onlyOne ifTrue: [ self replaceSubmorph: column by: row. column _ row. ]. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:08'! alanKwdCollect: aNode isAConditional: template key: key args: args | nodeWithNilReceiver row kwdHolder | nodeWithNilReceiver _ aNode copy receiver: nil. (row _ self addRow: #keyword2 on: nodeWithNilReceiver) borderWidth: 1; parseNode: (nodeWithNilReceiver as: MessageNode2); borderColor: row stdBorderColor. kwdHolder _ row addToken: key type: #keyword2 on: (SelectorNode2 new symbol: key). kwdHolder firstSubmorph setProperty: #syntacticallyCorrectContents toValue: key asString; contents: ''. args first asMorphicCollectSyntaxIn: row. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:08'! alanKwdSetter2: aNode isAConditional: template key: key args: args "translates foo setHeading: 0 to foo's heading _ 0 " | kwdHolder wordy | kwdHolder _ self addToken: key type: #keywordSetter on: (SelectorNode2 new symbol: key). wordy _ self translateToWordySetter: key. kwdHolder firstSubmorph setProperty: #syntacticReformatting toValue: #keywordSetter; contents: wordy; emphasis: 1. wordy = key asString ifFalse: [ kwdHolder firstSubmorph setProperty: #syntacticallyCorrectContents toValue: key asString]. (args first asMorphicSyntaxIn: self) setConditionalPartStyle ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:08'! alanKwdSetter: aNode isAConditional: template key: key args: args | nodeWithNilReceiver row kwdHolder | nodeWithNilReceiver _ aNode copy receiver: nil. (row _ self addRow: #keyword2 on: nodeWithNilReceiver) borderWidth: 1; parseNode: (nodeWithNilReceiver as: MessageNode2); borderColor: row stdBorderColor. row addNoiseString: '''s' emphasis: 1. kwdHolder _ row addToken: key type: #keywordGetz on: (SelectorNode2 new symbol: key). kwdHolder firstSubmorph setProperty: #syntacticReformatting toValue: #keywordGetz; setProperty: #syntacticallyCorrectContents toValue: key asString; contents: (self splitAtCapsAndDownshifted: (key asString allButLast: 5)); emphasis: 1. row addNoiseString: '_' emphasis: 1. (args first asMorphicSyntaxIn: row) setConditionalPartStyle ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:08'! alanUnaryGetter: aNode key: key "I am a MessageNode. Fill me with a SelectorNode {getX} whose string is {'s x}. All on one level." | selSyn usm wordy | selSyn _ self addToken: key type: #unaryGetter on: (SelectorNode2 new symbol: key). usm _ selSyn firstSubmorph. usm setProperty: #syntacticReformatting toValue: #unaryGetter. wordy _ self translateToWordyGetter: key. wordy = key asString ifFalse: [ usm setProperty: #syntacticallyCorrectContents toValue: key asString]. usm contents: wordy; emphasis: 1. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:09'! messageNode: aNode receiver: receiver selector: selector keywords: key arguments: args | keywords column row receiverMorph receiverWidth messageWidth onlyOne nodeWithNilReceiver isAConditional | self alansTest1 ifTrue: [ ^self alansMessageNode: aNode receiver: receiver selector: selector keywords: key arguments: args ]. isAConditional _ #(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes: key. receiver ifNotNil: ["i.e. not a cascade" receiverMorph _ receiver asMorphicSyntaxIn: self. ]. keywords _ key keywords. args size = 0 ifTrue: [ row _ (self addSingleKeywordRow: key) layoutInset: 1. ^ row parseNode: selector ]. receiverWidth _ receiver ifNil: [0] ifNotNil: [receiverMorph fullBounds width]. onlyOne _ args size = 1. (receiverWidth <= 80 and: [onlyOne]) ifTrue: [ self messageOneArg: key receiver: receiver selector: selector args: args. ^self ]. nodeWithNilReceiver _ aNode copy receiver: nil. column _ self addColumn: #keyword1 on: nodeWithNilReceiver. "onlyOne ifTrue: [column parseNode: nil]. is a spacer" messageWidth _ 0. keywords with: (args copyFrom: 1 to: keywords size) do: [:kwd :arg | isAConditional ifTrue: [ column addMorphBack: (column transparentSpacerOfSize: 3@3). ]. (row _ column addRow: #keyword2 on: nodeWithNilReceiver) borderWidth: 1; parseNode: (nodeWithNilReceiver as: (onlyOne ifTrue: [MessageNode2] ifFalse: [MessagePartNode])); borderColor: row stdBorderColor. isAConditional ifTrue: [row addMorphBack: (row transparentSpacerOfSize: 20@6)]. row addToken: kwd type: #keyword2 on: (onlyOne ifTrue: [SelectorNode2 new symbol: kwd] ifFalse: [KeyWordNode new]). arg asMorphicSyntaxIn: row. messageWidth _ messageWidth + row fullBounds width]. onlyOne ifTrue: [self replaceSubmorph: column by: row. column _ row]. receiverMorph ifNil: [^self]. receiverWidth + messageWidth < 350 ifTrue: [ isAConditional ifFalse: [self unfoldMessage]. ^self ]. ((receiverWidth > 200 or: [receiverWidth > 80 and: [column fullBounds height > 20]]) or: [receiverMorph fullBounds width > 30 and: [column fullBounds height > 100 or: [column fullBounds width > 250]]]) ifTrue: [^ self foldMessage]! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 16:55'! methodNodeInner: aNode selectorOrFalse: selectorOrFalse precedence: precedence arguments: arguments temporaries: temporaries primitive: primitive block: block | header selNode | selNode _ selectorOrFalse class == SelectorNode2 ifTrue: [selectorOrFalse] ifFalse: [SelectorNode2 new symbol: selectorOrFalse]. header _ self addRow: Color white on: selNode. precedence = 1 ifTrue: [header addToken: aNode selector type: #methodHeader1 on: selNode] ifFalse: [aNode selector keywords with: arguments do: [:kwd :arg | header addToken: kwd type: #methodHeader2 on: selNode. (arg asMorphicSyntaxIn: header) color: #blockarg2]]. aNode addCommentToMorph: self. self addTemporaries: temporaries. (primitive > 0 and: [(primitive between: 255 and: 519) not]) ifTrue: ["Dont decompile for, eg, ^ self " self addTextRow: (String streamContents: [ :strm | aNode printPrimitiveOn: strm])]. block asMorphicSyntaxWtihoutArgsIn: self. ^ self ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 15:03'! methodNodeOuter: aNode | block | self borderWidth: 0. aNode asMorphicSyntaxIn: self. self alansTest1 ifTrue: [self addTemporaryControls]. self finalAppearanceTweaks. "self setProperty: #deselectedColor toValue: Color transparent." block _ self findA: BlockNode2. "block setProperty: #deselectedColor toValue: Color transparent." block submorphs size = 1 ifTrue: [^ self]. "keep '^ self' if that is the only thing in method" block submorphs last decompile string = '^ self ' ifTrue: [ block submorphs last delete]. ^ self! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'ajh 1/20/2002 15:05'! vanillaMessageNode: aNode receiver: receiver selector: selector arguments: arguments | substitute row sel | sel _ #message. ((self nodeClassIs: CascadeNode2) and: [self parseNode receiver ~~ aNode]) ifTrue: [ sel _ #keyword2. receiver ifNotNil: [self inform: 'receiver should be nil']]. row _ self addRow: sel on: aNode. substitute _ aNode as: TileMessageNode. (aNode macroPrinter == #printCaseOn:indent:) ifTrue: [ aNode asMorphicCaseOn: row indent: nil. ^ self]. aNode macroPrinter ifNotNil: [substitute perform: aNode macroPrinter with: row with: nil] ifNil: [substitute printKeywords: selector key arguments: arguments on: row indent: nil]. ^ row addTransparentSpacerOfSize: 3@0. "horizontal spacing only" ! ! !SyntaxMorph methodsFor: 'alans styles' stamp: 'ajh 1/20/2002 16:22'! constructSelfVariant: receiver and: key | wordy | (receiver isKindOf: VariableNode2) ifFalse: [^nil]. receiver name = 'self' ifFalse: [^nil]. (wordy _ self translateFromWordySelfVariant: key) ifNil: [^nil]. ^wordy ! ! !SyntaxMorph methodsFor: 'alans styles' stamp: 'ajh 1/20/2002 16:58'! noiseWordBeforeVariableNode: aNode string: aString (#('self' 'nil') includes: aString) ifFalse: [ (aNode isKindOf: VariableNode2) ifTrue: [^'my'] ]. ^nil! ! !SyntaxMorph methodsFor: 'alans styles' stamp: 'ajh 1/20/2002 15:04'! standardInset parseNode class == BlockNode2 ifTrue: [^ 5@1]. "allow pointing beside a line so can replace it" ^ self alansTest1 ifTrue: [1] ifFalse: [-1]! ! !SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'ajh 1/20/2002 15:14'! test " SyntaxMorph test " self testClass: MessageNode2 andMethod: #asMorphicSyntaxIn:. "self testClass: MethodNode andMethod: #asMorphicSyntaxIn:." ! ! !SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'ajh 2/11/2002 15:55'! testAllMethodsOver: methodSize "MessageTally spyOn: [SyntaxMorph testAllMethodsOver: 600]" "Add up the total layout area for syntax morphs representing all methods over the given size. This is a stress-test for SyntaxMorph layout. A small value for the total area is also a figure of merit in the presentation of Squeak source code in general." "Results: #(69 600 180820874 103700) 11/4 70% build morphs, 12% get source, 9% layout, 8% parse, 1% roundoff Folded wide receivers, don't center keywords any more. #(68 600 160033784 127727) 11/9 76% build morphs, 8% get source, 8% layout, 8% parse, 0% roundoff Folded more messages, dropped extra vertical spacing in blocks. #(68 600 109141704 137308) 11/10 79% build morphs, 6% get source, 8% layout, 7% parse Folded more messages, dropped extra horizontal spacing. #(68 600 106912968 132171) 11/10 80% build morphs, ??% get source, 11% layout, 7% parse Unfolded keyword messages that will fit on one line. #(68 600 96497372 132153) 11/10 81% build morphs, ??% get source, 8% layout, 8% parse After alignment rewrite... #(74 600 101082316 244799) 11/12 76% build morphs, 4% get source, 15% layout, 5% parse After alignment rewrite... #(74 600 101250620 204972) 11/15 74% build morphs, 6% get source, 13% layout, 7% parse " | tree source biggies morph stats time area | biggies _ Smalltalk allSelect: [:cm | cm bytecodes size > methodSize]. stats _ OrderedCollection new. 'Laying out all ' , biggies size printString , ' methods over ' , methodSize printString , ' bytes...' displayProgressAt: Sensor cursorPoint from: 1 to: biggies size during: [:bar | biggies withIndexDo: [:methodRef :i | bar value: i. Utilities setClassAndSelectorFrom: methodRef in: [:aClass :aSelector | source _ (aClass compiledMethodAt: aSelector) getSourceFromFile. time _ Time millisecondsToRun: [tree _ Compiler new parse: source in: aClass notifying: nil. morph _ tree asMorphicSyntaxUsing: SyntaxMorph. area _ morph fullBounds area]]. stats add: {methodRef. area. time}] ]. ^ {{biggies size. methodSize. stats detectSum: [:a | a second]. stats detectSum: [:a | a third]}. (stats asSortedCollection: [:x :y | x third >= y third]) asArray} ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'ajh 2/11/2002 15:16'! macroBenchmark3 "Smalltalk macroBenchmark3" "Runs the stepping simulator with the messageTally tree (like tallySends)." | testBlock tallies prev | testBlock _ ['Running the context step simulator' displayProgressAt: Sensor cursorPoint from: 0 to: 200 during: [:bar | 1 to: 200 do: [:x | bar value: x. Float pi printString. 15 factorial printString]]]. tallies _ MessageTally new class: testBlock class method: testBlock method. prev _ nil. testBlock newProcess simulateEachStepDo: [:current | current == prev ifFalse: [ "call or return" tallies tally: current by: 1. prev _ current] ]. ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'ajh 2/11/2002 15:41'! macroBenchmarks "Reports an array of times taken to run a number of macro operations indicative of typical Squeak activity, each run after a full garbageCollection, and with exactly 10Mb of free space available. In addition it puts up a window with recent VM statistics local to each test." "PLEASE TAKE NOTE: The goal of these benchmarks is to provide a simple basis for A/B performance comparisons with a given Squeak image. For example JIT vs interpreter, new GC vs old, etc. However, a number of these benchmarks will 'drift' with evolution of the Squeak image, as, for instance, if the number of methods decompiled in macroBenchmark1 were to change. Therefore it is essential *never* to make comarisons between macroBenchmarks run from two different images." "Smalltalk macroBenchmarks #(43215 53122 81336 26927 8993 12607 9024) 400MHz G3" | interp time saveMorphs freeCell report fullReport individualTimes | individualTimes _ OrderedCollection new. fullReport _ String streamContents: [:strm | Smalltalk timeStamp: strm. "1: Decompile, pretty-print, and compile a bunch of methods. Does not install in classes, so does not flush cache." "strm cr; cr; nextPutAll: 'Benchmark #1: '; print: (time _ self standardTime: [Smalltalk macroBenchmark1]); nextPutAll: 'ms'; cr; nextPutAll: '---------------------'; cr; nextPutAll: Utilities vmStatisticsShortString. individualTimes addLast: time." "comment out until Decompiler implemented. -ajh" "2: Build morphic tiles for all methods over 800 bytes (;-). Does no display." strm cr; nextPutAll: 'Benchmark #2: '; print: (time _ self standardTime: [SyntaxMorph testAllMethodsOver: 800]); nextPutAll: 'ms'; cr; nextPutAll: '---------------------'; cr; nextPutAll: Utilities vmStatisticsShortString. individualTimes addLast: time. "3: Translate the interpreter with inlining. Does not include any plugins." strm cr; nextPutAll: 'Benchmark #3: '; print: (time _ self standardTime: [Smalltalk macroBenchmark2]); nextPutAll: 'ms'; cr; nextPutAll: '---------------------'; cr; nextPutAll: Utilities vmStatisticsShortString. individualTimes addLast: time. "4: Run the context step simulator. 200 iterations printing pi and 15 factorial." strm cr; nextPutAll: 'Benchmark #4: '; print: (time _ self standardTime: [Smalltalk macroBenchmark3]); nextPutAll: 'ms'; cr; nextPutAll: '---------------------'; cr; nextPutAll: Utilities vmStatisticsShortString. individualTimes addLast: time. "5: Run the InterpreterSimulator for 150,000 bytecodes. Will only run if you have mini.image in your directory." strm cr; nextPutAll: 'Benchmark #5: '; print: ((FileDirectory default includesKey: 'mini.image') ifTrue: [interp _ InterpreterSimulator new openOn: 'mini.image'. time _ self standardTime: [interp runForNBytes: 150000]. interp close. Display restore. time] ifFalse: [time _ 0]); nextPutAll: 'ms'; cr; nextPutAll: '---------------------'; cr; nextPutAll: Utilities vmStatisticsShortString. individualTimes addLast: time. "6: Open 10 browsers and close them. Includes browsing to a specific method." strm cr; nextPutAll: 'Benchmark #6: '; print: (Smalltalk isMorphic ifTrue: [saveMorphs _ self currentWorld submorphs. self currentWorld removeAllMorphs. "heh, heh" time _ self standardTime: [1 to: 10 do: [:i | Browser fullOnClass: SystemDictionary selector: #macroBenchmarks]. self currentWorld submorphs do: [:m | m delete. self currentWorld doOneCycle]]. self currentWorld addAllMorphs: saveMorphs. time] ifFalse: [time _ 0]); nextPutAll: 'ms'; cr; nextPutAll: '---------------------'; cr; nextPutAll: Utilities vmStatisticsShortString. individualTimes addLast: time. "7: Play a game of FreeCell with display, while running the MessageTally. Thanks to Bob Arning for the clever part of this one." strm cr; nextPutAll: 'Benchmark #7: '; print: (Smalltalk isMorphic ifTrue: ["Play a trivial game of FreeCell with MessageTally and report." (freeCell _ FreeCell new) openInWorld. time _ self standardTime: [freeCell board pickGame: 1]. (((report _ self currentWorld firstSubmorph) isKindOf: SystemWindow) and: [self currentWorld firstSubmorph label = 'Spy Results']) ifTrue: [report delete]. freeCell delete. time] ifFalse: [time _ 0]); nextPutAll: 'ms'; cr; nextPutAll: '---------------------'; cr; nextPutAll: Utilities vmStatisticsShortString. individualTimes addLast: time. strm cr; nextPutAll: '---------------------'; cr; nextPutAll: 'Total time = '; print: individualTimes sum; nextPutAll: ' milliseconds.'; cr]. StringHolder new textContents: fullReport; openLabel: 'Macro Benchmark Results'. ^ individualTimes asArray ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'ajh 1/18/2002 17:00'! abandonSources "Smalltalk abandonSources" "Replaces every method by a copy with the 4-byte source pointer replaced by a string of all arg and temp names, followed by its length. These names can then be used to inform the decompiler. See stats below" "wod 11/3/1998: zap the organization before rather than after condensing changes." | oldCodeString argsAndTemps bTotal bCount oldMethods newMethods m | (self confirm: '-- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning source code files, hit Yes. If you have any doubts, hit No, to back out with no harm done.') == true ifFalse: [^ self inform: 'Okay - no harm done']. Smalltalk forgetDoIts. oldMethods _ OrderedCollection new: CompiledMethod2 instanceCount. newMethods _ OrderedCollection new: oldMethods size. bTotal _ 0. bCount _ 0. Smalltalk allBehaviorsDo: [: b | bTotal _ bTotal + 1]. 'Saving temp names for better decompilation...' displayProgressAt: Sensor cursorPoint from: 0 to: bTotal during: [:bar | Smalltalk allBehaviorsDo: "for test: (Array with: Arc with: Arc class) do: " [:cl | bar value: (bCount _ bCount + 1). cl selectors do: [:selector | m _ cl compiledMethodAt: selector. m fileIndex > 0 ifTrue: [oldCodeString _ cl sourceCodeAt: selector. argsAndTemps _ (cl compilerClass new parse: oldCodeString in: cl notifying: nil) tempNames. oldMethods addLast: m. newMethods addLast: (m trailerTempNames: argsAndTemps)]]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. Smalltalk allBehaviorsDo: [: b | b zapOrganization]. Smalltalk condenseChanges. Preferences disable: #warnIfNoSourcesFile. " In a system with 7780 methods, we got 83k of temp names, or around 100k with spaces between. The order of letter frequency was eatrnoislcmdgpSub, with about 60k falling in the first 11. This suggests that we could encode in 4 bits, with 0-11 beng most common chars, and 12-15 contributing 2 bits to the next nibble for 6 bits, enough to cover all alphaNumeric with upper and lower case. If we get 3/4 in 4 bits and 1/4 in 8, then we get 5 bits per char, or about 38% savings (=38k in this case). Summary: about 13 bytes of temp names per method, or 8 with simple compression, plus 1 for the size. This would be 5 bytes more than the current 4-byte trailer. "! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'ajh 1/18/2002 17:01'! abandonTempNames "Replaces every method by a copy with no source pointer or encoded temp names." "Smalltalk abandonTempNames" | continue oldMethods newMethods n m | continue _ (self confirm: '-- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning all source code, hit Yes. If you have any doubts, hit No, to back out with no harm done.'). continue ifFalse: [^ self inform: 'Okay - no harm done']. Smalltalk forgetDoIts; garbageCollect. oldMethods _ OrderedCollection new. newMethods _ OrderedCollection new. n _ 0. 'Removing temp names to save space...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod2 instanceCount during: [:bar | Smalltalk allBehaviorsDo: [:cl | cl selectors do: [:sel | bar value: (n _ n + 1). m _ cl compiledMethodAt: sel. oldMethods addLast: m. newMethods addLast: (m copyWithTrailerBytes: #(0))]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. Smalltalk closeSourceFiles. Preferences disable: #warnIfNoChangesFile. Preferences disable: #warnIfNoSourcesFile. ! ! !SystemDictionary methodsFor: 'special objects' stamp: 'ajh 1/19/2002 11:35'! hasSpecialSelector: aLiteral ifTrueSetByte: aBlock | start | start _ self isClosureVersion ifTrue: [(CompiledMethodBuilder bytecodesDict at: #sendAdd) - 1] ifFalse: [16rAF]. 1 to: self specialSelectorSize do: [:index | (self specialSelectorAt: index) == aLiteral ifTrue: [ aBlock value: index + start. ^ true]]. ^ false! ! !SystemDictionary methodsFor: 'special objects' stamp: 'ajh 1/18/2002 19:50'! recreateSpecialObjectsArray "Smalltalk recreateSpecialObjectsArray" "The Special Objects Array is an array of object pointers used by the Smalltalk virtual machine. Its contents are critical and unchecked, so don't even think of playing here unless you know what you are doing." | newArray | newArray _ Array new: 51. "Nil false and true get used throughout the interpreter" newArray at: 1 put: nil. newArray at: 2 put: false. newArray at: 3 put: true. "This association holds the active process (a ProcessScheduler)" newArray at: 4 put: (Smalltalk associationAt: #Processor). "Numerous classes below used for type checking and instantiation" newArray at: 5 put: Bitmap. newArray at: 6 put: SmallInteger. newArray at: 7 put: String. newArray at: 8 put: Array. newArray at: 9 put: Smalltalk. newArray at: 10 put: Float. newArray at: 11 put: ActiveFrame. newArray at: 12 put: BlockClosure. newArray at: 13 put: Point. newArray at: 14 put: LargePositiveInteger. newArray at: 15 put: Display. newArray at: 16 put: Message. newArray at: 17 put: CompiledMethod2. newArray at: 18 put: (self specialObjectsArray at: 18) "(low space Semaphore)". newArray at: 19 put: Semaphore. newArray at: 20 put: Character. newArray at: 21 put: #doesNotUnderstand:. newArray at: 22 put: #cannotReturn:. newArray at: 23 put: nil. "*unused*" "An array of the 32 selectors that are compiled as special bytecodes, paired alternately with the number of arguments each takes." newArray at: 24 put: #(+ 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 @ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1 at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0 ). "An array of the 255 Characters in ascii order." newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]). newArray at: 26 put: #mustBeBoolean. newArray at: 27 put: ByteArray. newArray at: 28 put: Process2. "An array of up to 31 classes whose instances will have compact headers" newArray at: 29 put: self compactClassesArray. newArray at: 30 put: (self specialObjectsArray at: 30) "(delay Semaphore)". newArray at: 31 put: (self specialObjectsArray at: 31) "(user input Semaphore)". "Prototype instances that can be copied for fast initialization" newArray at: 32 put: (Float new: 2). newArray at: 33 put: (LargePositiveInteger new: 4). newArray at: 34 put: Point new. newArray at: 35 put: #cannotInterpret:. "Note: This must be fixed once we start using context prototypes" newArray at: 36 put: nil. "was (MethodContext new: CompiledMethod fullFrameSize)." newArray at: 37 put: CallStack. newArray at: 38 put: nil. "was (BlockContext new: CompiledMethod fullFrameSize)." newArray at: 39 put: Array new. "array of objects referred to by external code" newArray at: 40 put: nil. "was PseudoContext" newArray at: 41 put: TranslatedMethod. "finalization Semaphore" newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil:[Semaphore new]). newArray at: 43 put: LargeNegativeInteger. "External objects for callout. Note: Written so that one can actually completely remove the FFI." newArray at: 44 put: (Smalltalk at: #ExternalAddress ifAbsent:[nil]). newArray at: 45 put: (Smalltalk at: #ExternalStructure ifAbsent:[nil]). newArray at: 46 put: (Smalltalk at: #ExternalData ifAbsent:[nil]). newArray at: 47 put: (Smalltalk at: #ExternalFunction ifAbsent:[nil]). newArray at: 48 put: (Smalltalk at: #ExternalLibrary ifAbsent:[nil]). newArray at: 49 put: #executeThenReturn:from:. "was #aboutToReturn:through:" newArray at: 50 put: #executeThenReturn:to:. newArray at: 51 put: Var. "Now replace the interpreter's reference in one atomic operation" self specialObjectsArray become: newArray! ! !Environment methodsFor: 'system conversion' stamp: 'ajh 1/15/2002 11:26'! rewriteSourceForSelector: selector inClass: aClass using: envtForVar "Rewrite the source code for the method in question so that all global references out of the direct access path are converted to indirect global references. This is done by parsing the source with a lenient parser able to find variables in any environment. Then the parse tree is consulted for the source code ranges of each reference that needs to be rewritten and the pattern to which it should be rewritten. Note that assignments, which will take the form envt setValueOf: #GlobalName to: ... may generate spurious message due to agglutination of keywords with the value expression." | code methodNode edits varName eName envt | code _ aClass sourceCodeAt: selector. methodNode _ Compiler new parse: code in: aClass notifying: nil. edits _ OrderedCollection new. methodNode encoder variableSourceRanges do: [:tuple | "{ varNode. srcRange. store }" (aClass scopeHas: (varName _ tuple first name asSymbol) ifTrue: [:ignored]) ifFalse: ["This is a remote global. Add it as reference to be edited." edits addLast: { varName. tuple at: 2. tuple at: 3 }]]. "Sort the edits by source position." edits _ edits asSortedCollection: [:a :b | a second first < b second first]. edits reverseDo: [:edit | varName _ edit first. (eName _ envtForVar at: varName ifAbsent: [nil]) ifNotNil: ["If varName is not already exported, define an export method" envt _ self at: eName. (envt class includesSelector: varName) ifFalse: [envt class compile: (self exportMethodFor: varName) classified: 'exports']. "Replace each access out of scope with a proper remote reference" code _ code copyReplaceFrom: edit second first to: edit second last with: eName , ' ' , varName]]. aClass compile: code classified: (aClass organization categoryOfElement: selector)! ! !TMethod methodsFor: 'initialization' stamp: 'ajh 1/16/2002 00:40'! setSelector: sel block: blockNode primitive: aNumber "Initialize this method using the given information." selector _ sel. returnType _ 'int'. "assume return type is int for now" args _ blockNode argNames asOrderedCollection. locals _ blockNode allVisibleTempNamesExcludingMyArgs asOrderedCollection. declarations _ Dictionary new. primitive _ aNumber. parseTree _ blockNode asTranslatorNode setArguments: #(). labels _ OrderedCollection new. complete _ false. "set to true when all possible inlining has been done" export _ self extractExportDirective. static _ self extractStaticDirective. self removeFinalSelfReturn. self recordDeclarations. ! ! !TestTMethod methodsFor: 'initializing' stamp: 'ajh 1/16/2002 11:03'! setSelector: sel block: blockNode primitive: aNumber "Initialize this method using the given information." selector _ sel. returnType _ 'int'. "assume return type is int for now" args _ blockNode argNames asOrderedCollection. locals _ blockNode allVisibleTempNamesExcludingMyArgs asOrderedCollection. declarations _ Dictionary new. primitive _ aNumber. parseTree _ blockNode asTranslatorNode setArguments: #(). labels _ OrderedCollection new. complete _ false. "set to true when all possible inlining has been done" export _ self extractExportDirective. static _ self extractStaticDirective. isPrimitive _ false. "set to true only if you find a primtive direction." suppressingFailureGuards _ self extractSuppressFailureGuardDirective. self recordDeclarations. self extractPrimitiveDirectives. ! ! !TileMessageNode methodsFor: 'trickery' stamp: 'ajh 1/20/2002 15:00'! printToDoOn: aMorph indent: level | limitNode | limitNode _ (arguments last == nil or: [(arguments last isMemberOf: AssignmentNode2) not]) ifTrue: [arguments first] ifFalse: [arguments last value]. (selector key = #to:by:do: and: [(arguments at: 2) isConstantNumber and: [(arguments at: 2) key = 1]]) ifTrue: [self printKeywords: #to:do: arguments: (Array with: limitNode with: (arguments at: 3)) on: aMorph indent: level] ifFalse: [self printKeywords: selector key arguments: (Array with: limitNode) , arguments allButFirst on: aMorph indent: level]! ! !TileMessageNode methodsFor: 'trickery' stamp: 'ajh 1/20/2002 16:11'! printWhileOn: aMorph indent: level (arguments first isJust: NodeNil) ifTrue: [ selector _ SelectorNode2 new symbol: (selector key == #whileTrue: ifTrue: [#whileTrue] ifFalse: [#whileFalse]). arguments _ Array new ]. self printKeywords: selector key arguments: arguments on: aMorph indent: level! ! !TilePadMorph methodsFor: 'miscellaneous' stamp: 'ajh 1/20/2002 16:33'! isColorConstant: aParseNode "Is this a Color constant, of the form (MessageNode (VariableNode Color->Color) (SelectorNode #r:g:b:) (LiteralNode LiteralNode LiteralNode))" | rec | ((rec _ aParseNode receiver) isKindOf: VariableNode2) ifFalse: [^ false]. rec key isVariableBinding ifFalse: [^ false]. rec key value == Color ifFalse: [^ false]. aParseNode selector key == #r:g:b: ifFalse: [^ false]. aParseNode arguments size = 3 ifFalse: [^ false]. ^ true ! ! !TilePadMorph methodsFor: 'miscellaneous' stamp: 'ajh 1/20/2002 15:14'! isOutsideRef: aParseNode "Is this a reference to an outside Player, of the form (self class refUnscriptedPlayer1)? (MessageNode (VariableNode 'self') (SelectorNode 'class')) (SelectorNode 'refUnscriptedPlayer1')" | rec | ((rec _ aParseNode receiver) isKindOf: MessageNode2) ifFalse: [^ false]. rec receiver isSelfPseudoVariable ifFalse: [^ false]. rec selector key == #class ifFalse: [^ false]. aParseNode selector key numArgs = 0 ifFalse: [^ false]. (aParseNode selector key beginsWith: 'ref') ifFalse: [^ false]. ^ true ! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'ajh 1/14/2002 23:11'! updateListsAndCodeIn: aWindow | aMethod | aMethod _ classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false]. aMethod == currentCompiledMethod ifFalse: ["Do not attempt to formulate if there is no source pointer. It probably means it has been recompiled, but the source hasn't been written (as during a display of the 'save text simply?' confirmation)." aMethod trailer ifNotNil: [self reformulateList]]. ^ true ! ! !WonderlandActor methodsFor: 'eToy-support' stamp: 'ajh 1/20/2002 16:33'! tileReferringToSelf "answer a tile that refers to the receiver" | aTile nn tile | Preferences universalTiles ifTrue: [nn _ self externalName. "name it, if necessary, and put in References" (References includesKey: nn asSymbol) ifFalse: [ References at: nn asSymbol put: self]. tile _ SyntaxMorph new parseNode: (VariableNode2 new name: nn). tile layoutInset: 1; addMorph: (tile addString: nn special: false). tile color: (SyntaxMorph translateColor: #variable). tile extent: tile firstSubmorph extent + (2@2). ^ tile]. aTile _ TileMorph new setToReferTo: self. ^ aTile! ! TestCase subclass: #BlockClosuresTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-BlockClosureTests'! !BlockClosuresTestCase commentStamp: '' prior: 0! This test case collects examples for block uses that require full block closures.! Object subclass: #CollectionCombinator instanceVariableNames: 'resultProcessingBlock collectionOfArrays buffer ' classVariableNames: '' poolDictionaries: '' category: 'SUnit-BlockClosureTests'! !CollectionCombinator commentStamp: '' prior: 0! For a collection of collections, enumerate all elements of the cartesian product. The code shows how recursion is used to implement variable nesting of loops. The cartesian product is usually a huge collection, that should not be kept in memory. Therefore the user of the class has to provide a block with one argument that is called each time a tuple is constructed. When possible, that block should not build a collection of all these tuples, but should immediately drop unsuitable tuples. To get a first impression, try this with 'inspect it': | result | result := OrderedCollection new. CollectionCombinator new forArrays: (OrderedCollection with: #(#a #b #c) with: #(1 2 3 4 5) with: #('v' 'w' 'x' 'y' 'z') with: #('one' 'two' 'three') ) processWith: [:item |result addLast: item]. result ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:22'! testCannotReturn | blk | blk := self constructCannotReturnBlockInDeadFrame. self should: [blk value: 1] raise: Exception ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample1 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample1: array) = array) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample2 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample2: array) = (array collect: [:x | x * x])) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample3 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample3: array) = (array collect: [:x | x * x - 10])) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:05'! testExample1 self assert: ((self example1: 5) = 5 factorial) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 18:28'! testExample2 self assert: ((self example2: 5) = (1 to: 5) asOrderedCollection) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:59'! testGpsExample1 | result array | array := (1 to: 100) asArray. result := array inject: 0 into: [:sum :val | sum + val]. self assert: ((self gpsExample1: array) = result) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/25/2002 09:57'! testGpsExample2 | result array | " integer matrix elements should be used for the purpose of this test. " array := #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25)). result := array inject: 0 into: [:sum :subarray | sum + (subarray inject: 0 into: [:s :elem | s + elem])]. self assert: ((self gpsExample2: array) = result) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:40'! testNestedLoopsExample1 | arrays result | arrays := OrderedCollection new. arrays add: #(#a #b); add: #(1 2 3 4); add: #('w' 'x' 'y' 'z'). result := OrderedCollection new. CollectionCombinator new forArrays: arrays processWith: [:item |result addLast: item]. self assert: ((self nestedLoopsExample: arrays) = result) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:17'! testReentrantBlock | fib | fib := [:val | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. self should: [fib value: 0] raise: TestResult error. self assert: ((fib value: 1) == 1). self assert: ((fib value: 2) == 1). self assert: ((fib value: 3) == 2). self assert: ((fib value: 4) == 3). self assert: ((fib value: 5) == 5). self assert: ((fib value: 6) == 8). ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:17'! testReentrantBlockOldEnvironment | fib | fib := self constructFibonacciBlockInDeadFrame. self should: [fib value: 0] raise: TestResult error. self assert: ((fib value: 1) == 1). self assert: ((fib value: 2) == 1). self assert: ((fib value: 3) == 2). self assert: ((fib value: 4) == 3). self assert: ((fib value: 5) == 5). self assert: ((fib value: 6) == 8). ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:18'! testReentrantBlockOldEnvironmentWithBlockArguement | fib | fib := self constructFibonacciBlockWithBlockArgumentInDeadFrame. self should: [fib value: 0 value: fib] raise: TestResult error. self assert: ((fib value: 1 value: fib) == 1). self assert: ((fib value: 2 value: fib) == 1). self assert: ((fib value: 3 value: fib) == 2). self assert: ((fib value: 4 value: fib) == 3). self assert: ((fib value: 5 value: fib) == 5). self assert: ((fib value: 6 value: fib) == 8). ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:18'! testSharedClosureEnvironment |blockArray| blockArray := self constructSharedClosureEnvironmentInDeadFrame. self assert: ((blockArray at: 2) value == 10). self assert: (((blockArray at: 1) value: 5) == 5). self assert: ((blockArray at: 2) value == 5). ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:20'! constructCannotReturnBlockInDeadFrame ^ [:arg | ^arg]. ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! constructFibonacciBlockInDeadFrame | fib | fib := [:val | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. ^fib ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! constructFibonacciBlockWithBlockArgumentInDeadFrame ^ [:val :blk | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(blk value: (val - 1) value: blk) + (blk value: (val - 2) value: blk)]]. ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:15'! constructSharedClosureEnvironmentInDeadFrame |array result| result := 10. array := Array new: 2. array at: 1 put: [:arg | result := arg]. array at: 2 put: [result]. ^array ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! continuationExample1: aCollection " see comment below. Here we simply collect the values of a value with continuation block " | streamCreator collector | streamCreator := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (streamCreator value: aCollection). "The continuation examples are examples of a 'back to LISP' style. These examples use blocks to process the elements of a collection in a fashion that is similar to streaming. The creator block creates a blocks that act like a stream. In the following, this block is called a 'value with continuation block'. When such a value with continuation block receives the message value, it returns a Array of two elements, the value and the continuation 1. the next collection element 2. a so-called continuation, which is either nil or a block that can return the next value with continuation. To collect all elements of a value with continuation stream, use the collector block. " ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! continuationExample2: aCollection " see comment in method continuationExample1:. The block named 'processor' takes a value with contiuation and a processing block. It creates a new value with continuation. Again we use a collector to collect all values. " | stream processor collector | stream := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. processor := [:valueWithContinuation :activity | | localBlock | localBlock := [ | current | current := valueWithContinuation value. Array with: (activity value: current first) with: (current last notNil ifTrue: [localBlock])]. localBlock ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (processor value: (stream value: aCollection) value: [:x | x * x]).! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:27'! continuationExample3: aCollection " see comment in method continuationExample1:. The block named 'processor' takes a value with contiuation and a processing block. It creates a new value with continuation. Here we set up a chain of three values with continuation: one data source and two value processors. Again we use a collector to collect all values. " | stream processor collector | stream := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. processor := [:valueWithContinuation :activity | | localBlock | localBlock := [ | current | current := valueWithContinuation value. Array with: (activity value: current first) with: (current last notNil ifTrue: [localBlock])]. localBlock ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (processor value: (processor value: (stream value: aCollection) value: [:x | x * x]) value: [:x | x - 10]).! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! example1: anInteger " this example is very simple. A named block recursively computes the factorial. The example tests whether the value of x is still available after the recursive call. Note that the recursive call precedes the multiplication. For the purpose of the test this is essential. (When you commute the factors, the example will work also in some system without block closures, but not in Squeak.) " | factorial | factorial := [:x | x = 1 ifTrue: [1] ifFalse: [(factorial value: x - 1)* x]]. ^ factorial value: anInteger ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 18:35'! example2: anInteger " BlockClosuresTestCase new example2: 6" " to complicate the example1, we set up a dynamic reference chain that is used to dump all calls of facorial when recursion depth is maximal. The return value is an instance of orderedCollection, the trace. " | factorial trace | trace := OrderedCollection new. factorial := [:x :dumper :trace | | localDumper | localDumper := [ :collection | collection add: x. dumper value: collection.]. x = 1 ifTrue: [localDumper value: trace. 1] ifFalse: [(factorial value: x - 1 value: localDumper value: trace)* x. ] ]. factorial value: anInteger value: [ :collection | ] value: trace. ^trace! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 16:30'! nestedLoopsExample: arrays " A while ago, Hans Baveco asked for a way to dynamically nest loops. Better solutions than this one were proposed, but this one is a beautiful test for recursive block usage. " | result sizeOfResult streams block | "arrays := OrderedCollection new. arrays add: #(#a #b); add: #(1 2 3 4); add: #('w' 'x' 'y' 'z')." sizeOfResult := arrays inject: 1 into: [:prod :array | prod * array size]. streams := arrays collect: [:a | ReadStream on: a]. " This is an OrderedCollection of Streams " result := OrderedCollection new: sizeOfResult. block := [:r :tupel :allStreams | | innerBlock | innerBlock := [:myIdx | [myIdx = allStreams size ifTrue: [1 to: allStreams size do: [:i | tupel at: i put: (allStreams at: i) peek]. r addLast: tupel shallowCopy] ifFalse: [innerBlock value: myIdx + 1]. (allStreams at: myIdx) next. (allStreams at: myIdx) atEnd ] whileFalse: []. (allStreams at: myIdx) reset. ]. innerBlock value: 1. r ]. block value: result value: (Array new: streams size) " this is a buffer " value: streams. ^result ! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:01'! comment " The Jensen device was something very sophisticated in the days of Algol 60. Essentially it was tricky use of a parameter passing policy that was called 'call by name'. In modern terminology, a call by name parameter was a pair of blocks (in a system with full block closures, of course.) For the lovers of Algol 60, here is a short example: BEGIN REAL PROCEDURE JensenSum (A, I, N); REAL A; INTEGER I, N; BEGIN REAL S; S := 0.0; FOR I := 1 STEP 1 UNTIL N DO S := S + A; JensenSum := S; END; ARRAY X [1:10], Y[1:10, 1:10]; COMMENT Do array initialization here ; JensenSum (X[I], I, 10); JensenSum (Y[I, I], I, 10); JensenSum(JensenSum(Y[I, J], J, 10), I, 10); END; The first call sums the elements of X, the second sums the diagonal elements of Y and the third call sums up all elements of Y. It is possible to reimplement all this with blocks only and that is what is done in the jensen device examples. Additional remark: The Jensen device was something for clever minds. I remember an artice written by Donald Knuth and published in the Communications of the ACM (I think in 1962, but I may err) about that programming trick. That article showed how a simple procedure (called the general problem solver) could be used to do almost anything. The problem was of course to find out the right parameters. I seached my collection of photocopies for that article, but regrettably I could not find it. Perhaps I can find it later. "! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/24/2002 18:00'! gpsExample1: aCollection " BlockClosuresTestCase new gpsExample1: (1 to: 100) asArray" | gps i s | gps := [:idx :exp :sum | | cnt | cnt := 1. sum first value: 0. [idx first value: cnt. sum first value: (sum last value + exp last value). cnt := cnt + 1. cnt <= aCollection size] whileTrue: [ ]. sum last value ]. ^gps value: (Array with: [:val | i := val] with: [ i]) value: (Array with: [:val | aCollection at: i put: val] with: [ aCollection at: i]) value: (Array with: [:val | s := val] with: [ s]) ! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:03'! gpsExample2: aCollection " BlockClosuresTestCase new gpsExample2: #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25))" | js i j | " js is the translation of the Algol procedure from method comment. " js := [:a :idx :n | | sum | sum := 0. idx first value: 1. [idx last value <= n last value] whileTrue: [sum := sum + a last value. idx first value: idx last value + 1.]. sum ]. " This is the most complicated call that is mentioned in method comment. Note that js is called recursively. " ^ js value: (Array with: [:val | self error: 'can not assign to procedure'] with: [ js value: (Array with: [:val | (aCollection at: i) at: j put: val] with: [ (aCollection at: i) at: j]) value: (Array with:[:val | j := val] with: [ j]) value: (Array with: [:val | self error: 'can not assign to constant'] with: [ aCollection size]) ] ) value: (Array with:[:val | i := val] with: [ i]) value: (Array with: [:val | self error: 'can not assign to constant'] with: [ aCollection size]) ! ! !CollectionCombinator methodsFor: 'as yet unclassified' stamp: 'BG 12/20/2001 21:33'! combineFromIdx: myIdx " this method is recursive. Recursion runs from values 1 to collectionOfArrays size of parameter myIdx. Each time it is called, this method has the responsiblity to provide all possible values for one index position of the result tuples. That index position is given by the value of myIdx." (collectionOfArrays at: myIdx) do: [:item | buffer at: myIdx put: item. myIdx = collectionOfArrays size ifTrue: [resultProcessingBlock value: buffer shallowCopy] ifFalse: [self combineFromIdx: myIdx + 1] ]. " The buffer is a shared object and its contents are later changed. It is therefore necessary to make a copy. "! ! !CollectionCombinator methodsFor: 'as yet unclassified' stamp: 'BG 12/20/2001 21:32'! forArrays: anArray processWith: aBlock " anArray is a kind of a sequenceable collection of arrays. aBlock is a block with one argument, that is used to process a tuple immediately after it is constructed. " collectionOfArrays := anArray. resultProcessingBlock := aBlock. buffer := Array new: anArray size. self combineFromIdx: 1 ! ! "Postscript: Remove obsolete compact classes and install new ones" CompiledMethod becomeUncompact. BlockContext becomeUncompact. MethodContext becomeUncompact. CompiledMethod2 becomeCompact. ByteArray becomeCompact. "Put old classes in 'obsolete' categories" SystemOrganization renameCategory: 'System-Compiler' toBe: 'System-Compiler Obsolete'. SystemOrganization classifyAll: #(CompiledMethod InstructionPrinter InstructionStream Process BlockContext ContextPart MethodContext PseudoContext) under: 'Kernel-Obsolete'. !