'From Squeak3.7alpha of ''11 September 2003'' [latest update: #5623] on 28 January 2004 at 2:52:49 pm'! "Change Set: KCP-0170-CompilerProtocolRefactoring Date: 28 January 2004 Author: Nathanael Schaerli v3: fixes a small bug (SystemNavigation default is used instead of Smalltalk) and has the right order for a proper file-in. The compiler protocol in Behavior and ClassDescription was complicated, confusing and partly broken. This changeset refactors this framework using the system change notifier."! Smalltalk renameClassNamed: #CompiledMethodNode as: #CompiledMethodWithNode! Object subclass: #CompiledMethodWithNode instanceVariableNames: 'node method' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:03'! method: aCompiledMethod method _ aCompiledMethod! ! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:04'! node: aMethodNode node _ aMethodNode! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:03'! method ^ method! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! node ^ node! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! selector ^ self node selector! ! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! generateMethodFromNode: aMethodNode trailer: bytes ^ self method: (aMethodNode generate: bytes) node: aMethodNode.! ! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! method: aCompiledMethod node: aMethodNode ^ self new method: aCompiledMethod; node: aMethodNode.! ! !Object methodsFor: 'message handling' stamp: 'NS 1/28/2004 11:19'! withArgs: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and args in argArray" | selector | selector _ Symbol new. self class addSelectorSilently: selector withMethod: compiledMethod. ^ [self perform: selector withArguments: argArray] ensure: [self class basicRemoveSelector: selector]! ! !Behavior methodsFor: 'initialize-release' stamp: 'NS 1/28/2004 11:17'! forgetDoIts "get rid of old DoIt methods" self basicRemoveSelector: #DoIt; basicRemoveSelector: #DoItIn:! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 13:59'! compile: code notifying: requestor "Compile the argument, code, as source code in the context of the receiver and insEtall the result in the receiver's method dictionary. The second argument, requestor, is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream. This method also saves the source code." | methodAndNode | methodAndNode _ self basicCompile: code "a Text" notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. ^ methodAndNode selector! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 11:32'! defaultMethodTrailer ^ #(0 0 0 0)! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 09:22'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ method trailer. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self addSelectorSilently: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:27'! addSelectorSilently: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do this without sending system change notifications" | oldMethodOrNil | oldMethodOrNil _ self lookupSelector: selector. self methodDict at: selector put: compiledMethod. "Now flush Squeak's method cache, either by selector or by method" oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache]. selector flushCache.! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 09:34'! addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 09:34'! addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:17'! removeSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." ^ self basicRemoveSelector: selector! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:28'! removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemChangeNotifier doSilently: [self basicRemoveSelector: selector].! ! !Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 13:59'! basicCompile: code notifying: requestor trailer: bytes ifFail: failBlock "Compile code without logging the source in the changes file" | methodNode | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. methodNode encoder requestor: requestor. ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! !Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 10:29'! basicRemoveSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache.! ! !Behavior methodsFor: 'deprecated' stamp: 'NS 1/28/2004 11:29'! removeSelectorSimply: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | self deprecated: 'Use basicRemoveSelector: instead.'. oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache.! ! !ChangeList methodsFor: 'viewing access' stamp: 'NS 1/28/2004 11:18'! 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 _ CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer. class _ (changeList at: listIndex) methodClass. selector _ (changeList at: listIndex) methodSelector. class addSelectorSilently: 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 basicRemoveSelector: selector]. ^ true! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:12'! addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor | priorMethodOrNil | priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category]. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:10'! addSelector: selector withMethod: compiledMethod notifying: requestor | priorMethodOrNil | priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:26'! removeSelector: selector | priorMethod priorProtocol | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil]. priorProtocol _ self whichCategoryIncludesSelector: selector. super removeSelector: selector. self organization removeElement: selector. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! !ClassDescription methodsFor: 'private' stamp: 'NS 1/28/2004 14:22'! logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor | priorMethodOrNil newText | priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: []. newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not and: [Preferences confirmFirstUseOfStyle]) ifTrue: [aText askIfAddStyle: priorMethodOrNil req: requestor] ifFalse: [aText]. aCompiledMethodWithNode method putSource: newText fromParseNode: aCompiledMethodWithNode node class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethodOrNil.! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:25'! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | methodAndNode | methodAndNode _ self basicCompile: text asString notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. logSource ifTrue: [ self logMethodSource: text forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: requestor. ]. self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode method inProtocol: category notifying: requestor. self theNonMetaClass noteCompilationOf: methodAndNode selector meta: self isMeta. ^ methodAndNode selector! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'! compileSilently: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ self compileSilently: code classified: category notifying: nil.! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'! compileSilently: code classified: category notifying: requestor "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ SystemChangeNotifier uniqueInstance doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:48'! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" ^ true! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:42'! compileInobtrusively: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." | methodNode newMethod | self deprecated: 'Use compileSilently:classified: instead.'. methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil]. self addSelectorSilently: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)). SystemChangeNotifier doSilently: [self organization classify: methodNode selector under: category]. ^ newMethod! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:43'! compileProgrammatically: code classified: cat "compile the given code programmatically. In the current theory, we always do this unlogged as well, and do not accumulate the change in the current change set" self deprecated: 'Use compileSilently:classified: instead.'. ^ self compileSilently: code classified: cat " | oldInitials | oldInitials _ Utilities authorInitialsPerSe. Utilities setAuthorInitials: 'programmatic'. self compile: code classified: cat. Utilities setAuthorInitials: oldInitials. "! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:47'! compileUnlogged: text classified: category notifying: requestor self deprecated: 'Use compileSilently:classified:notifying: instead.'. ^ self compileSilently: text classified: category notifying: requestor. " | selector | self compile: text asString notifying: requestor trailer: #(0 0 0 0) ifFail: [^ nil] elseSetSelectorAndNode: [:sel :node | selector _ sel]. self organization classify: selector under: category. ^ selector "! ! !Class methodsFor: '*packageinfo-base' stamp: 'NS 1/28/2004 14:32'! noteCompilationOf: aSelector meta: isMeta "the cleanest place we can hook into this" InMidstOfFileinNotification signal ifFalse: [SystemChangeNotifier uniqueInstance isBroadcasting ifTrue: [Utilities changed: #recentMethodSubmissions]]. ! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/28/2004 11:19'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag "Compiles the sourceStream into a parse tree, then generates code into a method. This method is then installed in the receiver's class so that it can be invoked. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here as DoIt or (in the case of evaluation in aContext) DoItIn:. The method is subsequently removed from the class, but this will not get done if the invocation causes an error which is terminated. Such garbage can be removed by executing: Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: #DoItIn:]." | methodNode method value selector | class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode _ self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method _ methodNode generate: #(0 0 0 0). self interactive ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. selector _ context isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. class addSelectorSilently: selector withMethod: method. value _ context isNil ifTrue: [receiver DoIt] ifFalse: [receiver DoItIn: context]. InMidstOfFileinNotification signal ifFalse: [class basicRemoveSelector: selector]. logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. ^ value.! ! !MethodFinder methodsFor: 'initialize' stamp: 'NS 1/28/2004 11:19'! noteDangerous "Remember the methods with really bad side effects." Dangerous _ Set new. "Object accessing, testing, copying, dependent access, macpal, flagging" #(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit) do: [:sel | Dangerous add: sel]. "Object error handling" #(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:) do: [:sel | Dangerous add: sel]. "Object user interface" #(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement ) do: [:sel | Dangerous add: sel]. "Object system primitives" #(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:) do: [:sel | Dangerous add: sel]. "Object private" #(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:) do: [:sel | Dangerous add: sel]. "Object, translation support" #(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:) do: [:sel | Dangerous add: sel]. "Object, objects from disk, finalization. And UndefinedObject" #(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until: suspend) do: [:sel | Dangerous add: sel]. "No Restrictions: Boolean, False, True, " "Morph" #() do: [:sel | Dangerous add: sel]. "Behavior" #(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: "creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo: "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables "private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:) do: [:sel | Dangerous add: sel]. "CompiledMethod" #(defaultSelector) do: [:sel | Dangerous add: sel]. "Others " #("no tangible result" do: associationsDo: "private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser) do: [:sel | Dangerous add: sel]. #( fileOutPrototype addSpareFields makeFileOutFile ) do: [:sel | Dangerous add: sel]. #(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: ) do: [:sel | Dangerous add: sel]. ! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'NS 1/28/2004 11:19'! debug: aCompiledMethod receiver: anObject in: evalContext | selector guineaPig debugger context | selector _ evalContext isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. anObject class addSelectorSilently: selector withMethod: aCompiledMethod. guineaPig _ evalContext isNil ifTrue: [[anObject DoIt] newProcess] ifFalse: [[anObject DoItIn: evalContext] newProcess]. context _ guineaPig suspendedContext. debugger _ Debugger new process: guineaPig controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) context: context isolationHead: nil. debugger openFullNoSuspendLabel: 'Debug it'. [debugger interruptedContext method == aCompiledMethod] whileFalse: [debugger send]. anObject class basicRemoveSelector: selector! ! !Player methodsFor: 'scripts-kernel' stamp: 'NS 1/28/2004 14:41'! acceptScript: aScriptEditorMorph for: aSelector "Accept the tile code in the script editor as the code for the given selector. This branch is only for the classic-tile system, 1997-2001" | aUniclassScript | self class compileSilently: aScriptEditorMorph methodString classified: 'scripts'. aUniclassScript _ self class assuredMethodInterfaceFor: aSelector asSymbol. aUniclassScript currentScriptEditor: aScriptEditorMorph! ! !Player methodsFor: 'slots-user' stamp: 'NS 1/28/2004 14:47'! addSpecialSetter: selector | instVar code | "For the special setters, fooIncreaseBy:, fooDecreaseBy:, fooMultiplyBy:, add a method that does them." self assureUniClass. instVar _ (selector allButLast: 11) asLowercase. "all three are 11 long!!" (self respondsTo: ('set', instVar capitalized, ':') asSymbol) ifFalse: [^ false]. code _ String streamContents: [:strm | strm nextPutAll: selector, ' amount'; crtab. strm nextPutAll: 'self set', instVar capitalized, ': (self get', instVar capitalized; space. (selector endsWith: 'IncreaseBy:') ifTrue: [strm nextPut: $+]. (selector endsWith: 'DecreaseBy:') ifTrue: [strm nextPut: $-]. (selector endsWith: 'MultiplyBy:') ifTrue: [strm nextPut: $*]. strm nextPutAll: ' amount)']. self class compileSilently: code classified: 'access' notifying: nil. ^ true ! ! !Player class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41'! compileInstVarAccessorsFor: varName "Compile getters and setteres for the given instance variable name" | nameString | nameString _ varName asString capitalized. self compileSilently: ('get', nameString, ' ^ ', varName) classified: 'access'. self compileSilently: ('set', nameString, ': val ', varName, ' _ val') classified: 'access'! ! !Player class methodsFor: 'namespace' stamp: 'NS 1/28/2004 14:41'! compileReferenceAccessorFor: varName "Compile reference accessors for the given variable. If the #capitalizedReferences preference is true, then nothing is done here" Preferences capitalizedReferences ifTrue: [^ self]. self class compileSilently: ((self referenceAccessorSelectorFor: varName), ' ^ ', varName) classified: 'reference'! ! !CardPlayer class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41'! compileAccessorsFor: varName "Compile instance-variable accessor methods for the given variable name" | nameString | nameString _ varName asString capitalized. self compileSilently: ('get', nameString, ' ^ ', varName) classified: 'access'. self compileSilently: ('set', nameString, ': val ', varName, ' _ val') classified: 'access'! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'NS 1/28/2004 11:22'! fileInAnnouncing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title." | val chunk | announcement displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. self skipSeparators. [val := (self peekFor: $!!) ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self] ifFalse: [chunk := self nextChunk. self checkForPreamble: chunk. Compiler evaluate: chunk logged: true]] on: InMidstOfFileinNotification do: [:ex | ex resume: true]. self skipStyleChunk]. self close]. "Note: The main purpose of this banner is to flush the changes file." SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. self flag: #ThisMethodShouldNotBeThere. "sd" Smalltalk forgetDoIts. ^val! ! !PositionableStream methodsFor: '*Project-SAR-fileIn' stamp: 'NS 1/28/2004 11:21'! fileInFor: client announcing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title. Does NOT handle preambles or postscripts specially." | val chunk | announcement displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. self skipSeparators. [ val _ (self peekFor: $!!) ifTrue: [ (Compiler evaluate: self nextChunk for: client logged: false) scanFrom: self ] ifFalse: [ chunk _ self nextChunk. self checkForPreamble: chunk. Compiler evaluate: chunk for: client logged: true ]. ] on: InMidstOfFileinNotification do: [ :ex | ex resume: true]. self atEnd ifFalse: [ self skipStyleChunk ]]. self close]. "Note: The main purpose of this banner is to flush the changes file." SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. Smalltalk forgetDoIts. ^ val! ! !Preferences class methodsFor: 'initialization' stamp: 'NS 1/28/2004 14:43'! compileAccessMethodForPreference: aPreference "Compile an accessor method for the given preference" self class compileSilently: (aPreference name, ' ^ self valueOfFlag: #', aPreference name, ' ifAbsent: [', aPreference defaultValue storeString, ']') classified: 'standard queries'! ! !Preferences class methodsFor: 'personalization' stamp: 'NS 1/28/2004 14:43'! compileHardCodedPref: prefName enable: aBoolean "Compile a method that returns a simple true or false (depending on the value of aBoolean) when Preferences is sent prefName as a message" self class compileSilently: (prefName asString, ' "compiled programatically -- return hard-coded preference value" ^ ', aBoolean storeString) classified: 'hard-coded prefs'. "Preferences compileHardCodedPref: #testing enable: false"! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'NS 1/28/2004 11:22'! fileOutAndRemove: rootClasses withOtherClasses: otherClasses andOtherMessages: otherMessages "classesAndMethodsPair is {set of class names. set of selectors}." | changeSet cl priorChanges | "First fileOut all classes and methods..." changeSet _ ChangeSorter basicNewChangeSet: rootClasses first, 'EtAl'. rootClasses , otherClasses do: [:n | changeSet addClass: (cl _ Smalltalk at: n). {cl. cl class} do: [:cls | cls selectors do: [:sel | changeSet atSelector: sel class: cls put: #add]]]. Smalltalk classNames do: [:n | cl _ Smalltalk at: n. {cl. cl class} do: [:cls | cls selectors do: [:sel | (otherMessages includes: sel) ifTrue: [changeSet atSelector: sel class: cls put: #add]]]]. Preferences checkForSlips ifTrue: [Preferences disable: #checkForSlips. changeSet fileOut. Preferences enable: #checkForSlips] ifFalse: [changeSet fileOut]. "Now remove all classes and methods..." priorChanges _ ChangeSet current. "Save current changeSet" ChangeSet newChanges: changeSet. "just a place to dump removals" rootClasses do: [:n | cl _ Smalltalk at: n. "Root classes get left, but all methods removed." {cl. cl class} do: [:cls | cls zapOrganization. cls selectors do: [:sel | cls basicRemoveSelector: sel]]]. (ChangeSet superclassOrder: (otherClasses collect: [:n | (Smalltalk at: n)])) reverseDo: [:cls | cls removeFromSystem]. Smalltalk classNames do: [:n | cl _ Smalltalk at: n. {cl. cl class} do: [:cls | cls selectors do: [:sel | (otherMessages includes: sel) ifTrue: [cls basicRemoveSelector: sel]]]]. ChangeSet newChanges: priorChanges. "Restore current changeSet" ChangeSorter removeChangeSet: changeSet. changeSet _ nil. "Try to avoid registering this as a normal changeSet." Smalltalk garbageCollect! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'NS 1/28/2004 11:22'! removeAllUnSentMessages "Smalltalk removeAllUnSentMessages" "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. Smalltalk removeAllUnSentMessages > 0] whileTrue." "Remove all implementations of unsent messages." | sels n | sels _ self systemNavigation allUnSentMessages. "The following should be preserved for doIts, etc" "needed even after #majorShrink is pulled" #(#rehashWithoutBecome #compactSymbolTable #rebuildAllProjects #browseAllSelect: #lastRemoval #scrollBarValue: #scrollBarMenuButtonPressed: #withSelectionFrom: #to: #removeClassNamed: #dragon: #hilberts: #mandala: #web #test3 #factorial #tinyBenchmarks #benchFib #newDepth: #restoreAfter: #forgetDoIts #zapAllMethods #obsoleteClasses #removeAllUnSentMessages #abandonSources #removeUnreferencedKeys #reclaimDependents #zapOrganization #condenseChanges #browseObsoleteReferences #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: #methodsFor:stamp: #methodsFor:stamp:prior: #instanceVariableNames: #startTimerInterruptWatcher #unusedClasses ) do: [:sel | sels remove: sel ifAbsent: []]. "The following may be sent by perform: in dispatchOnChar..." (ParagraphEditor classPool at: #CmdActions) asSet do: [:sel | sels remove: sel ifAbsent: []]. (ParagraphEditor classPool at: #ShiftCmdActions) asSet do: [:sel | sels remove: sel ifAbsent: []]. sels size = 0 ifTrue: [^ 0]. n _ 0. self systemNavigation allBehaviorsDo: [:x | n _ n + 1]. 'Removing ' , sels size printString , ' messages . . .' displayProgressAt: Sensor cursorPoint from: 0 to: n during: [:bar | n _ 0. self systemNavigation allBehaviorsDo: [:class | bar value: (n _ n + 1). sels do: [:sel | class basicRemoveSelector: sel]]]. ^ sels size! ! MethodNode removeSelector: #generateWithNode:! CompiledMethodWithNode class removeSelector: #methodNode:compiledMethod:! CompiledMethodWithNode class removeSelector: #node:method:! CompiledMethodWithNode removeSelector: #compiledMethod! CompiledMethodWithNode removeSelector: #compiledMethod:! CompiledMethodWithNode removeSelector: #methodNode! CompiledMethodWithNode removeSelector: #methodNode:! ClassDescription removeSelector: #addSelector:withMethod:requestor:! ClassDescription removeSelector: #compile:notifying:trailer:ifFail:elseSetSelectorAndNode:! !ClassDescription reorganize! ('initialize-release' doneCompiling obsolete superclass:methodDictionary:format: updateInstances:from:isMeta: updateInstancesFrom:) ('accessing' classVersion comment comment: comment:stamp: theMetaClass theNonMetaClass) ('copying' copy:from: copy:from:classified: copyAll:from: copyAll:from:classified: copyAllCategoriesFrom: copyCategory:from: copyCategory:from:classified: copyMethodDictionaryFrom:) ('printing' classVariablesString instanceVariablesString printOn: printOnStream: sharedPoolsString storeOn:) ('instance variables' addInstVarName: allInstVarNamesEverywhere checkForInstVarsOK: chooseClassVarName chooseInstVarAlphabeticallyThenDo: chooseInstVarThenDo: classThatDefinesClassVariable: classThatDefinesInstanceVariable: forceNewFrom: instVarNames removeInstVarName: renameInstVar:to: renameSilentlyInstVar:to: replaceSilently:to:) ('accessing method dictionary' addAndClassifySelector:withMethod:inProtocol:notifying: addSelector:withMethod:notifying: allMethodCategoriesIntegratedThrough: allMethodsInCategory: induceMDFault isUniClass namedTileScriptSelectors recoverFromMDFault recoverFromMDFaultWithTrace removeCategory: removeSelector: removeSelectorUnlogged: ultimateSourceCodeAt:ifAbsent:) ('organization' category category: categoryFromUserWithPrompt: letUserReclassify: organization organization: whichCategoryIncludesSelector: zapAllMethods zapOrganization) ('compiling' acceptsLoggingOfCompilation compile:classified: compile:classified:notifying: compile:classified:withStamp:notifying: compile:classified:withStamp:notifying:logSource: compile:notifying: compileSilently:classified: compileSilently:classified:notifying: moveInstVarNamed:to:after: noteCompilationOf:meta: wantsChangeSetLogging wantsRecompilationProgressReported) ('fileIn/Out' classComment: classComment:stamp: commentFollows commentStamp: commentStamp:prior: definition definitionST80 definitionST80: fileOutCategory: fileOutCategory:asHtml: fileOutCategory:on:moveSource:toFile: fileOutChangedMessages:on: fileOutChangedMessages:on:moveSource:toFile: fileOutMethod: fileOutMethod:asHtml: fileOutOn: fileOutOn:moveSource:toFile: fileOutOrganizationOn: methods methodsFor: methodsFor:priorSource:inFile: methodsFor:stamp: methodsFor:stamp:prior: moveChangesTo: printCategoryChunk:on: printCategoryChunk:on:priorMethod: printCategoryChunk:on:withStamp:priorMethod: printCategoryChunk:withStamp:on: printMethodChunk:withPreamble:on:moveSource:toFile: putClassCommentToCondensedChangesFile: reformatAll reformatMethodAt: reorganize) ('private' errorCategoryName instVarMappingFrom: linesOfCode logMethodSource:forMethodWithNode:inCategory:withStamp:notifying: newInstanceFrom:variable:size:map: setInstVarNames: spaceUsed) ('accessing class hierarchy' classesThatImplementAllOf: printSubclassesOn:level: removeUninstantiatedSubclassesSilently subclasses subclassesDo:) ('deprecated' compileInobtrusively:classified: compileProgrammatically:classified: compileUnlogged:classified:notifying:) ('*system-support' allUnreferencedClassVariables) ! Behavior removeSelector: #addSelector:withMethod:requestor:! Behavior removeSelector: #basicCompileWithoutLoggingSource:notifying:trailer:ifFail:! Behavior removeSelector: #compileWithoutLoggingSource:notifying:trailer:ifFail:! !Behavior reorganize! ('initialize-release' forgetDoIts nonObsoleteClass obsolete superclass:methodDictionary:format:) ('accessing' classDepth compilerClass decompilerClass environment evaluatorClass format methodDict name parserClass sourceCodeTemplate subclassDefinerClass typeOfClass) ('testing' canZapMethodDictionary fullyImplementsVocabulary: implementsVocabulary: instSize instSpec isBehavior isBits isBytes isFixed isMeta isObsolete isPointers isVariable isWeak isWords shouldNotBeRedefined) ('copying' copy copyOfMethodDictionary deepCopy) ('printing' defaultNameStemForInstances literalScannedAs:notifying: longPrintOn: printHierarchy printOn: printOnStream: storeLiteral:on:) ('compiling' compile: compile:notifying: compileAll compileAllFrom: decompile: defaultMethodTrailer recompile: recompile:from: recompileChanges recompileNonResidentMethod:atSelector:from:) ('instance creation' basicNew basicNew: initializedInstance new new:) ('accessing class hierarchy' allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses superclass superclass: withAllSubclasses withAllSuperclasses) ('accessing method dictionary' >> addSelector:withMethod: addSelector:withMethod:notifying: addSelectorSilently:withMethod: allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: compress compressedSourceCodeAt: firstCommentAt: firstPrecodeCommentFor: formalHeaderPartsFor: formalParametersAt: lookupSelector: methodDictionary methodDictionary: methodHeaderFor: methodsDo: precodeCommentOrInheritedCommentFor: removeSelector: removeSelectorSilently: rootStubInImageSegment: selectorAtMethod:setClass: selectors selectorsAndMethodsDo: selectorsDo: selectorsWithArgs: sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent: standardMethodHeaderFor: supermostPrecodeCommentFor:) ('accessing instances and variables' allClassVarNames allInstVarNames allInstances allSharedPools allSubInstances allowsSubInstVars classVarNames inspectAllInstances inspectSubInstances instVarNames instanceCount sharedPools someInstance subclassInstVarNames) ('testing class hierarchy' includesBehavior: inheritsFrom: kindOfSubclass) ('testing method dictionary' bindingOf: canUnderstand: classBindingOf: hasMethods includesSelector: scopeHas:ifTrue: thoroughWhichSelectorsReferTo:special:byte: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto:) ('enumerating' allInstancesDo: allInstancesEverywhereDo: allSubInstancesDo: allSubclassesDo: allSubclassesDoGently: allSuperclassesDo: selectSubclasses: selectSuperclasses: withAllSubclassesDo: withAllSuperAndSubclassesDoGently: withAllSuperclassesDo:) ('user interface' allLocalCallsOn: allUnreferencedInstanceVariables crossReference unreferencedInstanceVariables withAllSubAndSuperclassesDo:) ('private' basicCompile:notifying:trailer:ifFail: basicRemoveSelector: becomeCompact becomeCompactSimplyAt: becomeUncompact flushCache indexIfCompact) ('system startup' shutDown shutDown: startUp startUp: startUpFrom:) ('obsolete subclasses' addObsoleteSubclass: obsoleteSubclasses removeAllObsoleteSubclasses removeObsoleteSubclass:) ('deprecated' allSelectorsUnderstood removeSelectorSimply:) ('Camp Smalltalk' sunitAllSelectors sunitSelectors) ('*system-support' allCallsOn allCallsOn: allUnsentMessages) !