'From Squeak3.2alpha of 8 October 2001 [latest update: #4418] on 16 October 2001 at 4:22:06 pm'! "Change Set: Modules-Compatibility Date: 6 September 2001 Author: Henrik Gedenryd Make system compatible with modules, including weak/strong modules. Preamble has a dirty hack to change instvar name without recompiling 1000+ classes" Class setInstVarNames: (Class instVarNames copyReplaceAll: #('environment') with: #('module')).! Object subclass: #ClassBuilder instanceVariableNames: 'environ classMap instVarMap progress maxClassIndex currentClassIndex module ' classVariableNames: 'QuietMode ' poolDictionaries: '' category: 'Kernel-Classes'! SystemOrganizer subclass: #ModularSystemOrganizer instanceVariableNames: 'cachedCategoryList ' classVariableNames: '' poolDictionaries: '' category: 'System-Modules'! !ModularSystemOrganizer commentStamp: '' prior: 0! In a modular system, the entire system categories mechanism is subsumed by module paths. This class is a substitute for SystemOrganization that simulates system categories by computing them from module paths. Inquiring messages to this class are answered, but exceptions are raised for all messages that are sent to manipulate the system categories. The class SystemOrganization, the SystemOrganizer global and this class should eventually be removed, when the remaining code that uses them has been converted.! !Array methodsFor: 'file in/out' stamp: 'hg 9/10/2001 11:58'! literalPrintOn: aStream "print array without #'s before symbols" aStream nextPutAll: '#('. self do: [:element | (element respondsTo: #basicPrintOn:) ifTrue: [element basicPrintOn: aStream] ifFalse: [aStream print: element]. aStream space]. self isEmpty ifFalse: [aStream skip: -1]. aStream nextPut: $)! ! !Array methodsFor: 'file in/out' stamp: 'hg 9/10/2001 12:00'! literalPrintString | s | s _ WriteStream on: ''. self literalPrintOn: s. ^s contents! ! !ClassBuilder methodsFor: 'initialize' stamp: 'hg 9/19/2001 19:32'! initialize instVarMap _ IdentityDictionary new.! ! !ClassBuilder methodsFor: 'class definition' stamp: 'hg 9/19/2001 19:31'! class: oldClass instanceVariableNames: instVarString unsafe: unsafe "This is the basic initialization message to change the definition of an existing Metaclass" | instVars newClass | module _ oldClass module. instVars _ Scanner new scanFieldNames: instVarString. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. "Create a template for the new class (will return oldClass when there is no change)" newClass _ self newSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass unsafe: unsafe. newClass == nil ifTrue:[^nil]. "Some error" newClass _ self recompile: false from: oldClass to: newClass mutate: false. self doneCompiling: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'hg 9/7/2001 15:36'! name: className inModule: mod subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category "Define a new class in the given module" ^self name: className inModule: mod subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: false! ! !ClassBuilder methodsFor: 'class definition' stamp: 'hg 9/21/2001 14:15'! 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 assoc | 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]. assoc _ module localAssocFor: className ifAbsent:[nil]. oldClass _ assoc ifNotNil: [assoc value]. 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 ! ! !ClassBuilder methodsFor: 'class definition' stamp: 'hg 8/22/2001 18:57'! recompile: force from: oldClass to: aClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." | newClass | newClass _ aClass. oldClass == nil ifTrue:[ "newClass has an empty method dictionary so we don't need to recompile" newClass module changes addClass: newClass. newClass superclass addSubclass: newClass. ^newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ "No recompilation necessary but we might have added class vars or class pools so record the change" oldClass module changes changeClass: newClass from: oldClass. ^newClass]. currentClassIndex _ 0. maxClassIndex _ oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ oldClass module changes changeClass: newClass from: oldClass. "Recompile from newClass without mutating" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. self showProgressFor: oldClass. newClass _ self reshapeClass: oldClass to: newClass super: newClass superclass. oldClass module changes changeClass: newClass from: oldClass. self mutate: oldClass to: newClass. "And do the magic become" self update: oldClass to: newClass. ]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'hg 9/19/2001 19:32'! reshapeClass: aClass to: templateClass super: newSuper "Reshape the given class to the new super class. If templateClass is not nil then it defines the shape of the new class" | fmt newClass newMeta newSuperMeta oldMeta instVars oldClass | templateClass == nil ifTrue:[oldClass _ aClass] ifFalse:[oldClass _ templateClass]. aClass becomeUncompact. "Compute the new format of the class" instVars _ instVarMap at: aClass name ifAbsent:[oldClass instVarNames]. fmt _ self computeFormat: oldClass typeOfClass instSize: instVars size forSuper: newSuper ccIndex: 0."Known to be 0 since we uncompacted aClass first" fmt == nil ifTrue:[^nil]. aClass isMeta ifFalse:["Create a new meta class" oldMeta _ aClass class. newMeta _ oldMeta clone. newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class]. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: (self computeFormat: oldMeta typeOfClass instSize: oldMeta instVarNames size forSuper: newSuperMeta ccIndex: 0); setInstVarNames: oldMeta instVarNames; organization: oldMeta organization. "Recompile the meta class" oldMeta hasMethods ifTrue:[newMeta compileAllFrom: oldMeta]. "Fix up meta class structure" oldMeta superclass addObsoleteSubclass: oldMeta. (oldMeta superclass subclasses includes: oldMeta) ifTrue:[ oldMeta superclass removeSubclass: oldMeta. newMeta superclass addSubclass: newMeta]. "And record the change so we can fix global refs later" self recordClass: oldMeta replacedBy: newMeta. ]. newClass _ newMeta == nil ifTrue:[oldClass clone] ifFalse:[newMeta adoptInstance: oldClass from: oldMeta]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: fmt; setInstVarNames: instVars; organization: aClass organization. "Recompile the new class" aClass hasMethods ifTrue:[newClass compileAllFrom: aClass]. "Export the new class into the environment" aClass isMeta ifFalse:[ "Derefence super sends in the old class" self fixSuperSendsFrom: aClass. "Export the class" [module redefineName: newClass name as: newClass export: true ] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. "And use the ST association in the new class" self fixSuperSendsTo: newClass]. "Fix up the class hierarchy" (aClass superclass subclasses includes: aClass) ifTrue:[ aClass superclass removeSubclass: aClass. newClass superclass addSubclass: newClass. ]. "And record the change" self recordClass: aClass replacedBy: newClass. ^newClass ! ! !ClassBuilder methodsFor: 'validation' stamp: 'hg 9/21/2001 13:13'! validateClassName: aString "Validate the new class name" ^module validateName: aString forValue: Class new "fake the new class object"! ! !ClassBuilder methodsFor: 'private' stamp: 'hg 8/22/2001 18:58'! recordClass: oldClass replacedBy: newClass "Keep the changes up to date when we're moving instVars around" (instVarMap includesKey: oldClass name) ifTrue:[ newClass module changes changeClass: newClass from: oldClass. ].! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:32'! superclass: newSuper subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class." ^self name: t inModule: nil subclassOf: newSuper type: newSuper typeOfClass instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:52'! superclass: newSuper subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class." ^self name: t inModule: mod subclassOf: newSuper type: newSuper typeOfClass instanceVariableNames: f classVariableNames: d poolDictionaries: s category: nil! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:51'! superclass: aClass variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable byte-sized nonpointer variables." (aClass instSize > 0) ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. (aClass isVariable and: [aClass isWords]) ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. ^self name: t inModule: nil subclassOf: aClass type: #bytes instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:53'! superclass: aClass variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable byte-sized nonpointer variables." (aClass instSize > 0) ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. (aClass isVariable and: [aClass isWords]) ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. ^self name: t inModule: mod subclassOf: aClass type: #bytes instanceVariableNames: f classVariableNames: d poolDictionaries: s category: nil! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:51'! superclass: aClass variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inModule: nil subclassOf: aClass type: #variable instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:53'! superclass: aClass variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inModule: mod subclassOf: aClass type: #variable instanceVariableNames: f classVariableNames: d poolDictionaries: s category: nil! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:51'! superclass: aClass variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable word-sized nonpointer variables." (aClass instSize > 0) ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. (aClass isVariable and: [aClass isBytes]) ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. ^self name: t inModule: nil subclassOf: aClass type: #words instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:54'! superclass: aClass variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable word-sized nonpointer variables." (aClass instSize > 0) ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. (aClass isVariable and: [aClass isBytes]) ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. ^self name: t inModule: mod subclassOf: aClass type: #words instanceVariableNames: f classVariableNames: d poolDictionaries: s category: nil! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:51'! superclass: aClass weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inModule: nil subclassOf: aClass type: #weak instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'hg 9/7/2001 15:54'! superclass: aClass weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inModule: mod subclassOf: aClass type: #weak instanceVariableNames: f classVariableNames: d poolDictionaries: s category: nil! ! !ClassCategoryReader methodsFor: 'private' stamp: 'hg 10/9/2001 21:51'! setClass: aClass class _ aClass! ! !ClassCategoryReader methodsFor: 'private' stamp: 'hg 10/9/2001 22:13'! targetClass ^class! ! !ClassDescription methodsFor: 'accessing' stamp: 'hg 8/21/2001 21:31'! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText. self module changes commentClass: self! ! !ClassDescription methodsFor: 'accessing' stamp: 'hg 8/21/2001 21:31'! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText stamp: aStamp. self module changes commentClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'printing' stamp: 'hg 9/25/2001 13:18'! sharedPoolsString "Answer a string of my shared pool names separated by spaces." | aStream | aStream _ WriteStream on: (String new: 100). self sharedPools do: [:x | aStream nextPutAll: (Module smalltalk definedNames keyAtIdentityValue: x ifAbsent: ['private']); space]. ^ aStream contents! ! !ClassDescription methodsFor: 'method dictionary' stamp: 'hg 8/21/2001 21:31'! removeSelector: selector | 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. self module changes removeSelector: selector class: self priorMethod: priorMethod lastMethodInfo: {priorMethod sourcePointer. (self whichCategoryIncludesSelector: selector)}. super removeSelector: selector. self organization removeElement: selector. self acceptsLoggingOfCompilation ifTrue: [Smalltalk logChange: self name , ' removeSelector: #' , selector]! ! !ClassDescription methodsFor: 'organization' stamp: 'hg 9/19/2001 13:15'! category "Answer the simulated system organization category for the receiver." ^self module simulatedCategory! ! !ClassDescription methodsFor: 'compiling' stamp: 'hg 9/7/2001 21:59'! changes ^self module changes! ! !ClassDescription methodsFor: 'compiling' stamp: 'hg 8/21/2001 21:30'! 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]. methodNode encoder requestor: requestor. "Why was this not preserved?" newMethod _ methodNode generate: bytes. priorMethodOrNil _ (self methodDict includesKey: selector) ifTrue: [self compiledMethodAt: selector] ifFalse: [nil]. self module changes noteNewMethod: newMethod forClass: self selector: selector priorMethod: priorMethodOrNil. self addSelector: selector withMethod: newMethod. ^ newMethod! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 21:32'! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [^ self organization classComment: aString]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [ file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. self module changes commentClass: self. aStamp size > 0 ifTrue: [self commentStamp: aStamp]. organization classComment: (RemoteString newString: aString onFileNumber: 2). ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 10/1/2001 17:35'! definitionST80 "Answer a String that defines the receiver." | aStream path | aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'nil'] ifFalse: [ path _ Preferences strongModules ifTrue: [self module qualifiedPrefixForName: superclass name andValue: superclass, ' '] ifFalse: ['']. aStream nextPutAll: path, superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. Preferences modularClassDefinitions ifFalse: [ aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '; store: self module simulatedCategory asString]. ^ aStream contents! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 10/1/2001 17:35'! definitionST80: isST80 "Answer a String that defines the receiver." | aStream path | isST80 ifTrue: [^ self definitionST80]. aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'nil'] ifFalse: [ path _ Preferences strongModules ifTrue: [self module qualifiedPrefixForName: superclass name andValue: superclass, ' '] ifFalse: ['']. aStream nextPutAll: path , superclass name]. aStream nextPutKeyword: self kindOfSubclass withArg: self name. aStream cr; tab; nextPutKeyword: 'instanceVariableNames: ' withArg: self instanceVariablesString. aStream cr; tab; nextPutKeyword: 'classVariableNames: 'withArg: self classVariablesString. Preferences modularClassDefinitions ifFalse: [ aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '; store: self module simulatedCategory asString]. ^ aStream contents! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 9/21/2001 12:38'! fileOutContentsOn: aFileStream moveSource: moveSource toFile: fileIndex "File class comment and all methods of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." self organization putCommentOnFile: aFileStream numbered: fileIndex moveSource: moveSource forClass: self. self organization categories do: [:heading | self fileOutCategory: heading on: aFileStream moveSource: moveSource toFile: fileIndex]! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 9/21/2001 12:39'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." aFileStream command: 'H3'. aFileStream nextChunkPut: self definition. aFileStream command: '/H3'. self fileOutContentsOn: aFileStream moveSource: moveSource toFile: fileIndex ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 10/1/2001 17:36'! modularDefinition: includeModule "Answer a String that defines the receiver." | aStream path | aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'nil'] ifFalse: [ path _ Preferences strongModules ifTrue: [self module qualifiedPrefixForName: superclass name andValue: superclass, ' '] ifFalse: ['']. aStream nextPutAll: path , superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. aStream cr; tab; nextPutAll: 'module: '. includeModule ifTrue: [aStream store: self module]. ^ aStream contents! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 21:31'! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" self module changes reorganizeClass: self. ^self organization! ! !Class methodsFor: 'initialize-release' stamp: 'hg 8/21/2001 13:34'! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." self superclass ifNotNil:[ "If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self module removeClassFromSystem: self logged: logged. self obsolete! ! !Class methodsFor: 'testing' stamp: 'hg 9/7/2001 15:11'! isObsolete "Return true if the receiver is obsolete." ^(self module localAssocFor: name ifAbsent:[nil]) ~~ self ! ! !Class methodsFor: 'class name' stamp: 'hg 9/25/2001 12:20'! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifTrue: [(self module validateName: newName forValue: self) ifFalse: [^self]. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. self module changeName: self name to: newName forValue: self. name _ newName]! ! !Class methodsFor: 'instance variables' stamp: 'hg 9/7/2001 20:54'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." ^(ClassBuilder new) name: self name inModule: self module subclassOf: superclass type: self typeOfClass instanceVariableNames: self instanceVariablesString , aString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: nil ! ! !Class methodsFor: 'instance variables' stamp: 'hg 9/7/2001 20:54'! removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables." | newInstVarString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newInstVarString _ ''. (self instVarNames copyWithout: aString) do: [:varName | newInstVarString _ newInstVarString , ' ' , varName]. ^(ClassBuilder new) name: self name inModule: self module subclassOf: superclass type: self typeOfClass instanceVariableNames: newInstVarString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: nil! ! !Class methodsFor: 'class variables' stamp: 'hg 8/21/2001 21:41'! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol | aString first isLowercase ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | subclass scopeHas: symbol ifTrue: [:temp | ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" self module changes changeClass: self from: self. classPool declare: symbol from: Undeclared]! ! !Class methodsFor: 'pool variables' stamp: 'hg 9/19/2001 20:34'! privateRemoveSharedPool: aDictionary "Remove the pool dictionary, aDictionary, as one of the receiver's pool dictionaries. : Note that it removes the wrong one if there are two empty Dictionaries in the list." sharedPools remove: aDictionary. sharedPools isEmpty ifTrue: [sharedPools _ nil]. ! ! !Class methodsFor: 'pool variables' stamp: 'hg 9/19/2001 20:35'! removeSharedPool: aDictionary "Remove the pool dictionary, aDictionary, as one of the receiver's pool dictionaries. Create an error notification if the dictionary is not one of the pools. : Note that it removes the wrong one if there are two empty Dictionaries in the list." | satisfiedSet workingSet aSubclass | (self sharedPools includes: aDictionary) ifFalse: [^self error: 'the dictionary is not in my pool']. "first see if it is declared in a superclass in which case we can remove it." (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty ifFalse: [^self privateRemoveSharedPool: aDictionary]. "second get all the subclasses that reference aDictionary through me rather than a superclass that is one of my subclasses." workingSet _ self subclasses asOrderedCollection. satisfiedSet _ Set new. [workingSet isEmpty] whileFalse: [aSubclass _ workingSet removeFirst. (aSubclass sharedPools includes: aDictionary) ifFalse: [satisfiedSet add: aSubclass. workingSet addAll: aSubclass subclasses]]. "for each of these, see if they refer to any of the variables in aDictionary because if they do, we can not remove the dictionary." satisfiedSet add: self. satisfiedSet do: [:sub | aDictionary associationsDo: [:aGlobal | (sub whichSelectorsReferTo: aGlobal) isEmpty ifFalse: [^self error: aGlobal key , ' is still used in code of class ' , sub name]]]. self privateRemoveSharedPool: aDictionary! ! !Class methodsFor: 'compiling' stamp: 'hg 10/1/2001 20:39'! lenientScopeHas: varName ifTrue: assocBlock "the standard mode when working with code for now" (self strongScopeHas: varName ifTrue: assocBlock) ifTrue: [^true]. "Look it up in smalltalk. This is a compatibility patch for now." Module smalltalk associationFor: varName ifPresent: [:a :mod | assocBlock value: a. ^ true]. ^false ! ! !Class methodsFor: 'compiling' stamp: 'hg 9/8/2001 21:38'! strongScopeHas: varName ifTrue: assocBlock "Like the regular scopeHas but this one always uses the lookup rules for strong modularity. Use this to e.g. check code from modularity point of view when under weak modules scheme. " self definesName: varName lookInSuper: true ifTrue: [:a | assocBlock value: a. ^ true]. "Next ask home module to look up name." self module associationFor: varName ifPresent: [:a :mod | assocBlock value: a. ^ true]. ^false! ! !Class methodsFor: 'compiling' stamp: 'hg 10/3/2001 19:10'! weakScopeHas: varName ifTrue: assocBlock "Like the regular scopeHas but this one always uses the lookup rules for weak modularity. I.e. see all names exported from all external and submodules. " | assoc | self definesName: varName lookInSuper: true ifTrue: [:a | assocBlock value: a. ^ true]. "Next ask home module to look up name. Treat all neighbors as imported. " assoc _ self module localAssocFor: varName ifAbsent: [ "look in all external and submodules." self module neighborModules do: [:mod | mod exportedAssocFor: varName ifPresent: [:a :m | assocBlock value: a. ^ true]]. nil]. assoc ifNotNil: [assocBlock value: assoc. ^true]. "Finally look it up globally. This is a compatibility patch for now. Look it up this way instead of in Smalltalk to test multiple name definitions. " "Module root associationFor: varName ifPresent: [:a :mod | assocBlock value: a. ^ true]. " ^false! ! !Class methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 21:41'! removeFromChanges "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet. 7/18/96 sw: call removeClassAndMetaClassChanges:" self module changes removeClassAndMetaClassChanges: self! ! !Class methodsFor: 'organization' stamp: 'hg 9/6/2001 21:06'! environment module isNil | Preferences strongModules not ifTrue: [^ super environment]. ^ module! ! !Class methodsFor: 'organization' stamp: 'hg 9/6/2001 21:07'! environment: anEnvironment module _ anEnvironment! ! !Class methodsFor: 'modular subclasses' stamp: 'hg 9/29/2001 21:24'! subclass: t instanceVariableNames: f classVariableNames: d module: mod "This is the new standard initialization message for creating a new class as a subclass of an existing class (the receiver)." ^(ClassBuilder new) superclass: self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: #() module: mod ! ! !Class methodsFor: 'modular subclasses' stamp: 'hg 10/2/2001 17:09'! variableByteSubclass: t instanceVariableNames: f classVariableNames: d module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable byte-sized nonpointer variables." ^(ClassBuilder new) superclass: self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: #() module: mod ! ! !Class methodsFor: 'modular subclasses' stamp: 'hg 10/2/2001 17:09'! variableSubclass: t instanceVariableNames: f classVariableNames: d module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable pointer variables." ^(ClassBuilder new) superclass: self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: #() module: mod ! ! !Class methodsFor: 'modular subclasses' stamp: 'hg 10/2/2001 17:10'! variableWordSubclass: t instanceVariableNames: f classVariableNames: d module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable word-sized nonpointer variables." ^(ClassBuilder new) superclass: self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: #() module: mod ! ! !Class methodsFor: 'modular subclasses' stamp: 'hg 10/2/2001 17:10'! weakSubclass: t instanceVariableNames: f classVariableNames: d module: mod "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables." ^(ClassBuilder new) superclass: self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: #() module: mod ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'hg 9/8/2001 20:15'! checkBasicClasses "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 " | str str2 objCls morphCls modelCls playerCls | str _ '|veryDeepCopyWith: or veryDeepInner: is out of date.'. (objCls _ self objInMemory: #Object) ifNotNil: [ objCls instSize = 0 ifFalse: [self error: 'Many implementers of veryDeepCopyWith: are out of date']]. (morphCls _ self objInMemory: #Morph) ifNotNil: [ morphCls superclass == Object ifFalse: [self error: 'Morph', str]. (morphCls instVarNames copyFrom: 1 to: 6) = #('bounds' 'owner' 'submorphs' 'fullBounds' 'color' 'extension') ifFalse: [self error: 'Morph', str]]. "added ones are OK" str2 _ 'Player|copyUniClass and DeepCopier|mapUniClasses are out of date'. Behavior instVarNames = #('superclass' 'methodDict' 'format' ) ifFalse: [self error: str2]. ClassDescription instVarNames = #('instanceVariables' 'organization' ) ifFalse: [self error: str2]. Class instVarNames = #('subclasses' 'name' 'classPool' 'sharedPools' 'module' 'category' ) ifFalse: [self error: str2]. (modelCls _ self objInMemory: #Model) ifNotNil: [ modelCls superclass == Object ifFalse: [self error: str2]. modelCls class instVarNames = #() ifFalse: [self error: str2]]. (playerCls _ self objInMemory: #Player) ifNotNil: [ playerCls superclass == modelCls ifFalse: [self error: str2]. playerCls class instVarNames = #('scripts' 'slotInfo') ifFalse: [self error: str2]]. ! ! !Dictionary methodsFor: 'printing' stamp: 'hg 9/19/2001 13:40'! printElementsOn: aStream aStream nextPut: $(. self keysSortedSafely do: [:key | aStream print: key; nextPutAll: '->'; print: (self at: key ifAbsent: ['not found!!!!']); space]. aStream nextPut: $)! ! !Encoder methodsFor: 'private' stamp: 'hg 10/1/2001 20:47'! lookupInPools: varName ifFound: assocBlock Symbol hasInterned: varName ifTrue: [:sym | (Preferences valueOfFlag: #lenientScopeForGlobals) ifTrue: [ (class lenientScopeHas: sym ifTrue: assocBlock) ifTrue: [^ true]. "another lookup just to catch Pool variables. this is temporary" Module root associationFor: varName ifPresent: [:a :mod | assocBlock value: a. ^ true]] ifFalse: [ (Preferences strongModules ifTrue: [class strongScopeHas: sym ifTrue: assocBlock] ifFalse: [class weakScopeHas: sym ifTrue: assocBlock]) ifTrue: [^ true]]. ]. ^false! ! !HierarchicalUrl methodsFor: 'access' stamp: 'hg 8/20/2001 19:28'! path: anArray path _ (anArray size > 1 and: [anArray first = '']) ifTrue: [anArray allButFirst] ifFalse: [anArray]! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'hg 8/21/2001 14:15'! rootsIncludingPlayers "Return a new roots array with more objects. (Caller should store into rootArray.) Player (non-systemDefined) gets its class and metaclass put into the Roots array. Then ask for the segment again." | extras havePresenter players morphs env existing | userRootCnt ifNil: [userRootCnt _ arrayOfRoots size]. extras _ OrderedCollection new. arrayOfRoots do: [:root | (root isKindOf: Presenter) ifTrue: [havePresenter _ root]. (root isKindOf: PasteUpMorph) ifTrue: [ root isWorldMorph ifTrue: [havePresenter _ root presenter]]. (root isKindOf: Project) ifTrue: [havePresenter _ root world presenter]]. havePresenter ifNotNil: [ havePresenter flushPlayerListCache. "old and outside guys" morphs _ IdentitySet new: 400. havePresenter associatedMorph allMorphsAndBookPagesInto: morphs. players _ (morphs select: [:m | m player ~~ nil] thenCollect: [:m | m player]) asArray. players _ players select: [:ap | (arrayOfRoots includes: ap class) not & (ap class isSystemDefined not)]. extras addAll: (players collect: [:each | each class]). (env _ havePresenter world project module) ifNil: [ extras addAll: (players collect: [:each | each class class])]. extras addAll: morphs. "Make then ALL roots!!" ]. existing _ arrayOfRoots asIdentitySet. extras _ extras reject: [ :each | existing includes: each]. extras isEmpty ifTrue: [^ nil]. "no change" env ifNil: ["old pre-module" havePresenter _ players _ morphs _ nil. ^ arrayOfRoots, extras] "will contain multiples of some, but reduced later" ifNotNil: [ (env includesKey: #Object) ifTrue: [self error: 'only look in local env, not up chain']. "If get error, use a message other than includesKey:" extras do: [:cls | (env includesKey: cls name) ifFalse: [ env declare: cls name from: Smalltalk]]. havePresenter _ players _ morphs _ env _ nil. ^ arrayOfRoots, extras "still need in roots in case outside pointers" ]! ! !Metaclass methodsFor: 'accessing' stamp: 'hg 8/21/2001 14:15'! module ^thisClass module! ! !Metaclass methodsFor: 'compiling' stamp: 'hg 10/1/2001 20:38'! lenientScopeHas: name ifTrue: assocBlock ^thisClass lenientScopeHas: name ifTrue: assocBlock! ! !Metaclass methodsFor: 'compiling' stamp: 'hg 9/24/2001 19:06'! strongScopeHas: name ifTrue: assocBlock ^thisClass strongScopeHas: name ifTrue: assocBlock! ! !Metaclass methodsFor: 'compiling' stamp: 'hg 9/24/2001 19:06'! weakScopeHas: name ifTrue: assocBlock ^thisClass weakScopeHas: name ifTrue: assocBlock! ! !SmartRefStream methodsFor: 'import image segment' stamp: 'hg 8/21/2001 21:45'! mapClass: newClass origName: originalName "See if instances changed shape. If so, make a fake class for the old shape and return it. Remember the original class name." | newName oldInstVars fakeClass | newClass isMeta ifTrue: [^ newClass]. newName _ newClass name. (steady includes: newClass) & (newName == originalName) ifTrue: [^ newClass]. "instances in the segment have the right shape" oldInstVars _ structures at: originalName ifAbsent: [ self error: 'class is not in structures list']. "Missing in object file" fakeClass _ Object subclass: ('Fake37', originalName) asSymbol instanceVariableNames: oldInstVars allButFirst classVariableNames: '' poolDictionaries: '' category: 'Obsolete'. fakeClass module changes removeClassChanges: fakeClass name. "reduce clutter" ^ fakeClass ! ! !StringHolder methodsFor: 'message list menu' stamp: 'hg 8/21/2001 21:46'! removeFromCurrentChanges "Tell the changes mgr to forget that the current msg was changed." self selectedClassOrMetaClass changes removeSelectorChanges: self selectedMessageName class: self selectedClassOrMetaClass. self changed: #annotation! ! !CodeHolder methodsFor: 'commands' stamp: 'hg 8/21/2001 21:44'! adoptMessageInCurrentChangeset "Add the receiver's method to the current change set if not already there" self setClassAndSelectorIn: [:cl :sel | cl ifNotNil: [cl module changes adoptSelector: sel forClass: cl. self changed: #annotation]] ! ! !Browser methodsFor: 'class functions' stamp: 'hg 9/19/2001 15:26'! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class | oldClass _ self selectedClassOrMetaClass. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass _ oldClass superclass]. class _ oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #classList. self classListIndex: (self classList indexOf: ((class isKindOf: Metaclass) ifTrue: [class soleInstance name] ifFalse: [class name])). self clearUserEditFlag; editClass. ^ true] ifFalse: [^ false]! ! !Browser methodsFor: 'class functions' stamp: 'hg 9/21/2001 13:15'! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. " Cancel returns '' " newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [ Smalltalk browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ]. ! ! !Browser methodsFor: 'class list' stamp: 'hg 9/29/2001 22:32'! selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." | name | (name _ self selectedClassName) ifNil: [^ nil]. ^Module root allDefinitionsFor: name detect: [:value :module | (value isKindOf: Class) and: [ self selectedSystemCategoryName = module simulatedCategory]]! ! !Browser methodsFor: 'message category functions' stamp: 'hg 8/21/2001 21:42'! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. self selectedClassOrMetaClass changes reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer sortCategories. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'hg 8/21/2001 21:42'! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self selectedClassOrMetaClass changes reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'hg 8/21/2001 21:42'! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName _ self selectedMessageCategoryName. newName _ self request: 'Please type new category name' initialAnswer: oldName. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. newName = oldName ifTrue: [^ self]. self selectedClassOrMetaClass changes reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'system category functions' stamp: 'hg 9/10/2001 15:12'! potentialClassNames "Answer the names of all the classes that could be viewed in this browser. This hook is provided so that HierarchyBrowsers can indicate their restricted subset. For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers." ^ Module root classNames! ! !Debugger methodsFor: 'context stack menu' stamp: 'hg 9/29/2001 20:24'! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 12 14 17 20) selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger class methodsFor: 'class initialization' stamp: 'hg 9/29/2001 20:24'! initialize ErrorRecursion _ false. ContextStackKeystrokes _ Dictionary new at: $e put: #send; at: $t put: #doStep; at: $T put: #stepIntoBlock; at: $p put: #proceed; at: $r put: #restart; at: $f put: #fullStack; at: $w put: #where; yourself. "Debugger initialize"! ! !PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'di 9/14/2001 10:49'! openAsMorphEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." "PackagePaneBrowser openBrowser" | listHeight window | listHeight _ 0.4. (window _ SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #packageList selected: #packageListIndex changeSelected: #packageListIndex: menu: #packageMenu: keystroke: #packageListKey:from:) frame: (0 @ 0 extent: 0.15 @ listHeight). window addMorph: self buildMorphicSystemCatList frame: (0.15 @ 0 extent: 0.20 @ listHeight). self addClassAndSwitchesTo: window at: (0.35 @ 0 extent: 0.20 @ listHeight) plus: 0. window addMorph: self buildMorphicMessageCatList frame: (0.55 @ 0 extent: 0.20 @ listHeight). window addMorph: self buildMorphicMessageList frame: (0.75 @ 0 extent: 0.25 @ listHeight). self addLowerPanesTo: window at: (0 @ listHeight corner: 1 @ 1) with: editString. window setUpdatablePanesFrom: #(#packageList #systemCategoryList #classList #messageCategoryList #messageList ). ^ window! ! !PackagePaneBrowser methodsFor: 'package list' stamp: 'hg 9/26/2001 16:21'! packageList "Answer a list of the packages in the current system organization." ^SystemOrganization packageList! ! !PackagePaneBrowser methodsFor: 'class list' stamp: 'ak 6/4/2000 09:57'! classList "Answer an array of the class names of the selected category. Answer an empty array if no selection exists." ^systemCategoryListIndex = 0 ifTrue: [ self systemCategoryList isEmpty ifTrue: [systemOrganizer listAtCategoryNumber: (systemOrganizer categories indexOf: self package asSymbol)] ifFalse: [Array new]] ifFalse: [systemOrganizer listAtCategoryNumber: (systemOrganizer categories indexOf: self selectedSystemCategoryName asSymbol)]! ! !Symbol methodsFor: 'printing' stamp: 'hg 9/10/2001 11:47'! basicPrintOn: aStream "print symbol without the #" (Scanner isLiteralSymbol: self) ifTrue: [aStream nextPutAll: self] ifFalse: [super storeOn: aStream]! ! !Symbol methodsFor: 'printing' stamp: 'hg 9/10/2001 11:47'! storeOn: aStream aStream nextPut: $#. self basicPrintOn: aStream.! ! !SystemDictionary methodsFor: 'class names' stamp: 'hg 8/21/2001 21:52'! removeClassFromSystem: aClass logged: aBool "Delete the class, aClass, from the system, but log the removal neither to the current change set nor to the changes log" aBool ifTrue:[ aClass wantsChangeSetLogging ifTrue: [aClass module changes noteRemovalOf: aClass]. aClass acceptsLoggingOfCompilation ifTrue: [Smalltalk logChange: 'Smalltalk removeClassNamed: #', aClass name]. ]. SystemOrganization removeElement: aClass name. self removeFromStartUpList: aClass. self removeFromShutDownList: aClass. self removeKey: aClass name ifAbsent: []. self flushClassNameCache ! ! !SystemDictionary methodsFor: 'class names' stamp: 'hg 8/21/2001 21:51'! renameClass: aClass as: newName "Rename the class, aClass, to have the title newName." | oldref i | SystemOrganization classify: newName under: aClass category. SystemOrganization removeElement: aClass name. aClass module changes renameClass: aClass as: newName. oldref _ self associationAt: aClass name. self removeKey: aClass name. oldref key: newName. self add: oldref. "Old association preserves old refs" (Array with: StartUpList with: ShutDownList) do: [:list | i _ list indexOf: aClass name ifAbsent: [0]. i > 0 ifTrue: [list at: i put: newName]]. self flushClassNameCache! ! !SystemOrganizer methodsFor: 'accessing' stamp: 'di 9/14/2001 11:53'! invalidateCaches "For forward compatibility -- probably unreachable"! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:01'! addCategory: catString before: nextCategory "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:02'! allMethodSelectors "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:52'! categories: c "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:45'! categoriesMatching: matchString self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:06'! categoryFromUserWithPrompt: aPrompt self obsoleteMethod ! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:56'! changeFromCategorySpecs: categorySpecs self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:56'! changeFromString: aString self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:58'! classComment "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:57'! classComment: aString "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:07'! elementArray self obsoleteMethod ! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:43'! fileOut self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:43'! fileOutCategory: category on: aFileStream initializing: aBool self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:04'! fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:02'! letUserReclassify: anElement "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:04'! moveChangedCommentToFile: aFileStream numbered: fileIndex "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 10/1/2001 17:59'! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass self shouldNotImplement! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:43'! removeCategoriesMatching: matchString self obsoleteMethod ! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:02'! removeCategory: cat "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:59'! removeElement: element "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:59'! removeEmptyCategories "nothing sending this message should be used any longer" "But don't raise an error, since project loading uses it" "self obsoleteMethod" ^ self! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 20:32'! removeMissingClasses "nothing stored" ^self! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/10/2001 12:48'! removeSystemCategory: category self obsoleteMethod ! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:02'! renameCategory: oldCatString toBe: newCatString "nothing sending this message should be used any longer" self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:06'! scanFrom: aStream self obsoleteMethod ! ! !ModularSystemOrganizer methodsFor: 'obsolete methods' stamp: 'hg 9/7/2001 21:07'! setDefaultList: aSortedCollection self obsoleteMethod! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/26/2001 16:08'! categories "return cached list or if none compute it here. Use this to clear the cache:" "SystemOrganization invalidateCaches" | newList | cachedCategoryList ifNotNil: [^ cachedCategoryList]. newList _ OrderedCollection new. Module root deepSubmodulesDo: [:m | newList add: m simulatedCategory]. newList removeAll: self excludedCategories. "Cache the result while valid for later queries." cachedCategoryList _ newList asArray. ^ cachedCategoryList! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/24/2001 16:31'! categoryOfElement: c "old-style use, we know that c is the name of a class" Module root allDefinitionsFor: c detect: [:value :mod | (value isKindOf: Class) ifTrue: [^mod simulatedCategory]]. ^nil! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/8/2001 20:07'! classify: element under: heading suppressIfDefault: aBoolean "just do nothing" ^self! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/26/2001 16:12'! excludedCategories "Exclude categories for e.g. the virtual root. Use this to clear the cache:" "SystemOrganization invalidateCaches" ^(Array with: Module root with: Module smalltalk) collect: [:m | m simulatedCategory]! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'di 9/14/2001 10:28'! invalidateCaches cachedCategoryList _ nil! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/21/2001 13:23'! listAtCategoryNamed: cat | mod | mod _ (self moduleFromCategory: cat) ifNil: [^#()]. ^mod classNames! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/26/2001 15:51'! listAtCategoryNumber: anInteger ^(self moduleFromCategory: (self categories at: anInteger)) classNames! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/7/2001 20:34'! moduleFromCategory: cat ^Module moduleForCategory: cat forceCreate: false! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/26/2001 15:58'! numberOfCategoryOfElement: name "Answer the index of the category with which the argument, name, is associated." | categoryName | Module root allDefinitionsFor: name detect: [:value :module | (value isKindOf: Class) ifTrue: [ categoryName _ module simulatedCategory. self categories withIndexDo: [:cat :index | cat = categoryName ifTrue: [^index]]]]. ^0! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/7/2001 21:05'! objectForDataStream: refStrm self notYetImplemented ! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/7/2001 22:26'! obsoleteMethod self error: 'You cant do it this way with modules. Categories are computed from module paths.'! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/26/2001 16:17'! packageList "return a list of module names to use in the extra pane of the Package Browser" | squeak rootList squeakList basicList | squeak _ Module squeak name. rootList _ Module root submodules collect: [:mod | mod simulatedCategory]. squeakList _ Module squeak submodules collect: [:mod | mod simulatedCategory]. basicList _ (rootList copyUpTo: squeak), (Array with: squeak), squeakList, (rootList copyAfter: squeak). ^basicList copyWithoutAll: self excludedCategories ! ! !ModularSystemOrganizer methodsFor: 'handled SysOrg methods' stamp: 'hg 9/7/2001 20:39'! superclassOrder: category "Answer an OrderedCollection containing references to the classes in the category whose name is the argument, category (a string). The classes are ordered with superclasses first so they can be filed in." | list | list _ (self moduleFromCategory: category asSymbol) allClasses. ^ChangeSet superclassOrder: list! ! !ModularSystemOrganizer methodsFor: 'fileIn/Out' stamp: 'hg 9/7/2001 21:04'! printOn: aStream aStream nextPutAll: 'A replacement for SystemOrganization for modular system';cr! ! !ModularSystemOrganizer methodsFor: 'fileIn/Out' stamp: 'hg 9/7/2001 21:04'! printOnStream: aStream aStream nextPutAll: 'A replacement for SystemOrganization for modular system'; cr! ! !ModularSystemOrganizer class methodsFor: 'instance creation' stamp: 'hg 10/2/2001 21:10'! install | instance | PopUpMenu inform: 'The old SystemOrganization is about to be replaced. Existing browsers will be reset and you may be asked to confirm that it is OK to cancel changes. Please do so.'. instance _ self new. Smalltalk at: #SystemOrganization put: instance. Browser allSubInstancesDo: [:br | br systemOrganizer: instance; updateSystemCategories]. Smalltalk garbageCollect! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'hg 10/11/2001 22:39'! module "Necessary to support disjoint class hierarchies." ^Module smalltalk! ! !VirtualRootModule methodsFor: 'initializing' stamp: 'hg 9/24/2001 22:47'! invalidateCaches SystemOrganization invalidateCaches! ! !ModularSystemOrganizer reorganize! ('obsolete methods' addCategory:before: allMethodSelectors categories: categoriesMatching: categoryFromUserWithPrompt: changeFromCategorySpecs: changeFromString: classComment classComment: elementArray fileOut fileOutCategory:on:initializing: fileOutCommentOn:moveSource:toFile: letUserReclassify: moveChangedCommentToFile:numbered: putCommentOnFile:numbered:moveSource:forClass: removeCategoriesMatching: removeCategory: removeElement: removeEmptyCategories removeMissingClasses removeSystemCategory: renameCategory:toBe: scanFrom: setDefaultList:) ('handled SysOrg methods' categories categoryOfElement: classify:under:suppressIfDefault: excludedCategories invalidateCaches listAtCategoryNamed: listAtCategoryNumber: moduleFromCategory: numberOfCategoryOfElement: objectForDataStream: obsoleteMethod packageList superclassOrder:) ('fileIn/Out' printOn: printOnStream:) ! PackagePaneBrowser removeSelector: #selectedClass! Debugger initialize! Browser removeSelector: #selectedEnvironment! ClassCategoryReader removeSelector: #class! ClassBuilder removeSelector: #name:inEnvironment:subclassOf:type:instanceVariableNames:classVariableNames:poolDictionaries:category:! ClassBuilder removeSelector: #name:inEnvironment:subclassOf:type:instanceVariableNames:classVariableNames:poolDictionaries:category:unsafe:!