'From Squeak3.3alpha of 30 January 2002 [latest update: #4889] on 3 July 2002 at 3:39:51 pm'! Exception subclass: #CompilerException instanceVariableNames: '' classVariableNames: '' module: #(Squeak Technology Compiler)! CompilerException subclass: #UndefinedVariableReference instanceVariableNames: '' classVariableNames: '' module: #(Squeak Technology Compiler)! !UndefinedVariableReference commentStamp: '' prior: 0! UndefinedVariableReference signal: 'foo'! !DeltaClass methodsFor: 'as yet unclassified' stamp: 'ar 6/14/2002 00:16'! changeSelector: selector withMethod: methodOrNil previousVersion: oldMethodOrNil "For incremental development. Don't dump any old stuff we've assembled but only update to the current state of affairs." | assoc | assoc := self methodDict associationAt: selector ifAbsent:[nil]. assoc ifNotNil:[^assoc value: methodOrNil]. ^self redefineSelector: selector withMethod: methodOrNil previousVersion: oldMethodOrNil! ! !Module methodsFor: 'delta support' stamp: 'ar 6/14/2002 16:43'! changeSelector: aSelector inClass: aClass from: priorMethod to: newMethod | aClassModule deltaModule deltaClass | aClassModule := aClass module. aClassModule == self ifTrue:[ "Both are in the same module. NOTE: This needs to check if any delta is installed for this selector and update IT rather than returning - it's probably the delta we want to modify." ^self]. deltaModule := self deltaModuleForBase: aClassModule forceCreate: true asActive: true. deltaClass := deltaModule deltaClassFor: aClass forceCreate: true. deltaClass changeSelector: aSelector withMethod: (newMethod ifNil:[DeltaModule valueForUndefined]) previousVersion: (priorMethod ifNil:[DeltaModule valueForUndefined]) ! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'ar 6/15/2002 16:50'! 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. ]] on: UndefinedVariableReference do:[:ex| ex resume: (Module default importName: ex varName interactive: false). ]. self close ]. "Note: The main purpose of this banner is to flush the changes file." Smalltalk logChange: '----End fileIn of ' , self name , '----'. Smalltalk allBehaviorsDo: [ :cl | cl removeSelectorSimply: #DoIt; removeSelectorSimply: #DoItIn: ]. ^ val! ! !Object methodsFor: 'testing' stamp: 'ar 6/14/2002 16:30'! isModule ^false! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'ar 6/15/2002 17:02'! removeSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." ^self removeSelector: selector module: Module default. ! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'ar 6/15/2002 16:54'! removeSelector: selector module: aModule "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | prior | prior := self methodDict at: selector ifAbsent:[nil]. self removeSelectorSimply: selector. aModule ifNotNil:[aModule changeSelector: selector inClass: self from: prior to: nil].! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 6/13/2002 22:32'! name: className inModule: moduleOrPath subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given module. If module is nil then this is an old-style creation message with no module supplied, and if category is nil then it is a new-style message. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass newClass instVars classVars force | module _ moduleOrPath ifNil: [Module moduleForCategory: category forceCreate: true] ifNotNil:[ (moduleOrPath isKindOf: Module) ifTrue: [moduleOrPath] ifFalse: [Module fromPath: moduleOrPath forceCreate: true]]. instVars _ Scanner new scanFieldNames: instVarString. classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. "Validate the proposed name" (unsafe or: [self validateClassName: className]) ifFalse:[^nil]. oldClass _ module localValueFor: className ifAbsent:[nil]. oldClass isBehavior ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. "Create a template for the new class (will return oldClass when there is no change)" newClass _ self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass unsafe: unsafe. newClass == nil ifTrue:[^nil]. "Some error" newClass == oldClass ifFalse:[newClass setName: className]. "Install the class variables and pool dictionaries... " force _ (newClass declare: classVarString) | (newClass sharing: poolString). "support old-style classification somewhat ..." module organization classify: newClass name under: (category ifNil: [module simulatedCategory]) asSymbol. newClass module: module. "... recompile ..." newClass _ self recompile: force from: oldClass to: newClass mutate: false. [module redefineName: newClass name as: newClass export: true] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. Smalltalk flushClassNameCache. self doneCompiling: newClass. ^newClass ! ! !ClassDescription methodsFor: 'method dictionary' stamp: 'ar 6/15/2002 16:56'! removeSelector: selector module: aModule | priorMethod | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." (self methodDict includesKey: selector) ifFalse: [^ nil]. priorMethod _ self compiledMethodAt: selector. Smalltalk changes removeSelector: selector class: self priorMethod: priorMethod lastMethodInfo: {priorMethod sourcePointer. (self whichCategoryIncludesSelector: selector)}. super removeSelector: selector module: aModule. self organization removeElement: selector. self acceptsLoggingOfCompilation ifTrue: [Smalltalk logChange: self name , ' removeSelector: #' , selector]! ! !ClassDescription methodsFor: 'compiling' stamp: 'ar 6/13/2002 23:54'! compile: text module: aModule classified: category notifying: requestor | stamp | stamp _ self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil]. ^ self compile: text module: aModule classified: category withStamp: stamp notifying: requestor ! ! !ClassDescription methodsFor: 'compiling' stamp: 'ar 6/13/2002 23:54'! compile: text module: aModule classified: category withStamp: changeStamp notifying: requestor ^ self compile: text module: aModule classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! !ClassDescription methodsFor: 'compiling' stamp: 'ar 6/13/2002 23:55'! compile: text module: aModule classified: category withStamp: changeStamp notifying: requestor logSource: logSource | selector priorMethod method methodNode newText | method _ self compile: text asString module: aModule notifying: requestor trailer: #(0 0 0 0) ifFail: [^nil] elseSetSelectorAndNode: [:sel :node | selector _ sel. priorMethod _ self methodDict at: selector ifAbsent: [nil]. methodNode _ node]. logSource ifTrue: [newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not and: [Preferences confirmFirstUseOfStyle]) ifTrue: [text askIfAddStyle: priorMethod req: requestor] ifFalse: [text]. method putSource: newText fromParseNode: methodNode class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethod]. self organization classify: selector under: category. self theNonMetaClass noteCompilationOf: selector meta: self isMeta. ^ selector! ! !ClassDescription methodsFor: 'compiling' stamp: 'ar 6/13/2002 23:51'! compile: code module: aModule 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]. methodNode encoder requestor: requestor. "Why was this not preserved?" 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. aModule ifNotNil:[aModule changeSelector: selector inClass: self from: priorMethodOrNil to: newMethod]. ^ newMethod! ! !ClassDescription methodsFor: 'compiling' stamp: 'ar 6/15/2002 17:02'! compile: code notifying: requestor trailer: bytes ifFail: failBlock elseSetSelectorAndNode: selAndNodeBlock ^self compile: code module: Module default notifying: requestor trailer: bytes ifFail: failBlock elseSetSelectorAndNode: selAndNodeBlock ! ! !CompiledMethod methodsFor: 'literals' stamp: 'ar 6/14/2002 17:27'! variableBindingsDo: aBlock | lit | 1 to: self numLiterals do:[:i| lit := self literalAt: i. lit isVariableBinding ifTrue:[aBlock value: lit]. ].! ! !Encoder methodsFor: 'encoding' stamp: 'ar 6/14/2002 16:34'! encodeVariable: name sourceRange: range ifUnknown: action | varNode | varNode _ scopeTable at: name ifAbsent:[nil]. varNode ifNil:[ self lookupInPools: name ifFound: [:assoc | varNode _ self global: assoc name: name]]. varNode ifNil:[ (UndefinedVariableReference signal: name) ifNotNilDo:[:assoc|varNode := self global: assoc name: name]]. varNode ifNil:[varNode := action value]. range ifNotNil: [ name first isUppercase ifTrue: [globalSourceRanges addLast: { name. range. false }]. ]. (varNode isTemp and: [varNode scope < 0]) ifTrue: [ OutOfScopeNotification signal ifFalse: [ ^self notify: 'out of scope']. ]. ^ varNode! ! !Module methodsFor: 'accessing' stamp: 'ar 6/14/2002 20:03'! firstEmptyParentModule self allClasses isEmpty ifTrue:[^self]. ^parentModule firstEmptyParentModule! ! !Module methodsFor: 'testing' stamp: 'ar 6/14/2002 20:10'! hasParent: aModule self == aModule ifTrue:[^true]. parentModule ifNotNil:[^parentModule hasParent: aModule]. ^false! ! !Module methodsFor: 'testing' stamp: 'ar 6/14/2002 16:32'! isModule ^true! ! !Module methodsFor: 'strong name lookup' stamp: 'ar 6/14/2002 17:16'! allClassesAndMetaClassesDo: aBlock "Evaluate the argument, aBlock, for each class in this module." self definedNames valuesDo: [:value | (value isBehavior) ifTrue: [ aBlock value: value. (value isKindOf: DeltaClass) ifTrue:[aBlock value: value deltaForMetaclass] ifFalse:[aBlock value: value class]. ]] ! ! !Module methodsFor: 'strong name lookup' stamp: 'ar 6/13/2002 22:32'! localValueFor: aString ifAbsent: aBlock "look up assoc for the given name. only look locally in this module" ^self definedNames at: aString asSymbol ifAbsent: aBlock ! ! !Module methodsFor: 'code analysis' stamp: 'ar 6/14/2002 21:01'! fullDependencies "Answer all the dependencies of my code from other modules. The returned dictionary contains the literals and the places they are referenced from. NOTE: Later we should include selectors here as well." | dependencies deltas excluded dc | deltas := DeltaModule allInstances select:[:d| d baseModuleRef module == self]. dependencies := IdentityDictionary new. self allClassesAndMetaClassesDo:[:cls| excluded := IdentitySet new. deltas do:[:dm| dc := dm deltaClassFor: cls forceCreate: false. dc ifNotNil:[excluded addAll: dc selectors]. ]. cls methodDict keysAndValuesDo:[:sel :cm| (excluded includes: sel) ifFalse:[ cm variableBindingsDo:[:lit| (dependencies at: lit ifAbsentPut: [OrderedCollection new]) add: (MethodReference new setStandardClass: cls methodSymbol: sel). ]. ]. ]. ]. ^dependencies! ! !Module methodsFor: 'the basic stuff' stamp: 'ar 6/16/2002 00:34'! importModule: aModule "Take the given module and make it a prerequsite of mine" (self == aModule or:[self hasNeighborModule: aModule]) ifFalse:[ self externalModule: aModule alias: nil version: aModule version importNames: true ].! ! !Module methodsFor: 'the basic stuff' stamp: 'ar 6/16/2002 01:22'! importName: varName interactive: aBool "Import the given symbol." | definers choice import varAssoc | self definesName: varName usingScheme: #lenient ifTrue:[:a| varAssoc := a]. varAssoc ifNil:[^nil]. definers := Module root modulesDefining: varAssoc key. definers := definers reject:[:x| x isModule]. definers := definers keys asArray. definers := definers reject:[:x| x isDeltaModule]. definers := definers sort:[:m1 :m2| m1 asString <= m2 asString]. definers size > 1 ifTrue:[ aBool ifFalse:[^nil]. "Ambigous choice" choice := PopUpMenu withCaption: varAssoc key, 'is defined in multiple modules. Please choose the one you wish to use' chooseFrom: (definers collect:[:m| m asString]). choice = 0 ifTrue:[^nil]. import := definers at: choice. ] ifFalse:[import := definers first]. self importModule: import. ^import localAssocFor: varAssoc key ifAbsent:[nil]! ! !Module methodsFor: 'delta support' stamp: 'ar 6/14/2002 20:18'! selectorsAtClass: aClass "Return all the selectors redefined for the given class" | aClassModule deltaModule deltaClass | aClassModule := aClass module. aClassModule == self ifTrue:[ "Both are in the same module. NOTE: This needs to check if any delta is installed for this selector and update IT rather than returning - it's probably the delta we want to modify." ^aClass selectors]. deltaModule := self deltaModuleForBase: aClassModule forceCreate: false asActive: true. deltaModule ifNil:[^#()]. deltaClass := deltaModule deltaClassFor: aClass forceCreate: false. deltaClass ifNil:[^#()]. ^deltaClass selectors! ! !Project methodsFor: 'accessing' stamp: 'ar 6/13/2002 22:50'! module "this is the 'home' module of this project, which should be used as default for name lookups, e.g. in doIts in workspaces and so on" | path i | ^ module ifNil: [ path := #(Project) copyWith: self name. i := 0. [module := Module fromPath: path forceCreate: false. module == nil] whileFalse:[path last: (path last withoutTrailingDigits, (i := i+1) printString)]. module := Module fromPath: path forceCreate: true. ].! ! !UndefinedVariableReference methodsFor: 'as yet unclassified' stamp: 'ar 6/14/2002 14:45'! defaultAction ^nil! ! !UndefinedVariableReference methodsFor: 'as yet unclassified' stamp: 'ar 6/14/2002 15:00'! isResumable ^true! ! !UndefinedVariableReference methodsFor: 'as yet unclassified' stamp: 'ar 6/14/2002 14:47'! varName ^self messageText! !