Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
7351 lines (6008 sloc) 282 KB
Object subclass: #ClassBuilder instanceVariableNames: 'environ classMap instVarMap progress maxClassIndex currentClassIndex' classVariableNames: 'QuietMode' poolDictionaries: '' category: 'Kernel-Classes'!!ClassBuilder commentStamp: 'ar 2/27/2003 22:55' prior: 0!Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more.You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works.Implementation notes:ClassBuilder relies on the assumption that it can see ALL subclasses of some class. If there are any existing subclasses of some class, regardless of whether they have instances or not, regardless of whether they are considered obsolete or not, ClassBuilder MUST SEE THEM.!!ClassBuilder methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'!informUserDuring: aBlock self class isSilent ifTrue: [ ^ aBlock value ]. UIManager default informUserDuring: [ :bar | progress := bar. aBlock value ]. progress := nil! !!ClassBuilder methodsFor: 'class definition' stamp: 'BenjaminVanRyseghem 11/24/2010 15:55'!class: oldClass instanceVariableNames: instVarString unsafe: unsafe "This is the basic initialization message to change the definition of an existing Metaclass" | instVars newClass needNew copyOfOldClass copyOfOldTraitComposition copyOfOldClassTraitComposition | environ := oldClass environment. instVars := instVarString subStrings: ' '. 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]]. "See if we need a new subclass or not" needNew := self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. needNew ifNil:[^nil]. "some error" needNew ifFalse:[^oldClass]. "no new class needed" "Create the new class" copyOfOldClass := oldClass copy. oldClass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldClass traitComposition copyTraitExpression ]. oldClass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldClass class traitComposition copyTraitExpression ]. newClass := self newSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. newClass := self recompile: false from: oldClass to: newClass mutate: false. "... set trait composition..." copyOfOldTraitComposition ifNotNil: [ newClass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newClass class setTraitComposition: copyOfOldClassTraitComposition ]. self doneCompiling: newClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass! !!ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:34'!name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category "Define a new class in the given environment" ^self name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: false! !!ClassBuilder methodsFor: 'class definition' stamp: 'BenjaminVanRyseghem 11/24/2010 15:56'!name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass instVars classVars copyOfOldClass copyOfOldTraitComposition copyOfOldClassTraitComposition newClass | environ := env. instVars := instVarString subStrings: ' '. classVars := (classVarString subStrings: ' ') collect: [ :x | x asSymbol ]. "Validate the proposed name" unsafe ifFalse: [ (self validateClassName: className) ifFalse: [ ^ nil ] ]. oldClass := env at: className ifAbsent: [ nil ]. oldClass isBehavior ifFalse: [ oldClass := nil ] ifTrue: [ copyOfOldClass := oldClass copy. copyOfOldClass superclass addSubclass: copyOfOldClass. copyOfOldClass ifNotNil: [ oldClass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldClass traitComposition copyTraitExpression ]. oldClass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldClass class traitComposition copyTraitExpression ] ] ]. "Already checked in #validateClassName:" [ | newCategory oldCategory needNew force organization | 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 ] ]. "See if we need a new subclass" needNew := self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. needNew == nil ifTrue: [ ^ nil ]. "some error" (needNew and: [ unsafe not ]) ifTrue: [ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue: [ self error: oldClass name , ' cannot be changed' ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and: [ oldClass shouldNotBeRedefined ]) ifTrue: [ self notify: oldClass name asText allBold , ' should not be redefined. \Proceed to store over it.' withCRs ] ]. needNew ifTrue: [ "Create the new class" newClass := self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. newClass == nil ifTrue: [ ^ nil ]. "Some error" newClass setName: className ] ifFalse: [ "Reuse the old class" newClass := oldClass ]. "Install the class variables and pool dictionaries... " force := (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." newCategory := category asSymbol. organization := environ ifNotNil: [ environ organization ]. oldClass isNil ifFalse: [ oldCategory := (organization categoryOfElement: oldClass name) asSymbol ]. organization classify: newClass name under: newCategory. newClass environment: environ. "... recompile ..." newClass := self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent: [ nil ]) == newClass ifFalse: [ environ at: newClass name put: newClass. Smalltalk globals flushClassNameCache ]. "... set trait composition..." copyOfOldTraitComposition ifNotNil: [ newClass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newClass class setTraitComposition: copyOfOldClassTraitComposition ]. newClass doneCompiling. "... notify interested clients ..." oldClass isNil ifTrue: [ SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. ^ newClass ]. newCategory ~= oldCategory ifTrue: [ SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category ] ifFalse: [ SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass ] ] ensure: [ copyOfOldClass ifNotNil: [ copyOfOldClass superclass removeSubclass: copyOfOldClass ]. Behavior flushObsoleteSubclasses ]. ^ newClass! !!ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 02:57'!needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Answer whether we need a new subclass to conform to the requested changes" | newFormat | "Compute the format of the new class" newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. "Check if we really need a new subclass" oldClass ifNil:[^true]. "yes, it's a new class" newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change" newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change" instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change" ^false! !!ClassBuilder methodsFor: 'class definition' stamp: 'pmm 3/13/2010 11:21'!newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Create a new subclass of the given superclass with the given specification." | newFormat newClass | "Compute the format of the new class" newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. (oldClass == nil or:[oldClass isMeta not]) ifTrue:[newClass := self privateNewSubclassOf: newSuper from: oldClass] ifFalse:[newClass := oldClass shallowCopy]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: newFormat; setInstVarNames: instVars. oldClass ifNotNil:[ newClass organization: oldClass organization. "Recompile the new class" oldClass hasMethods ifTrue:[newClass compileAllFrom: oldClass]. self recordClass: oldClass replacedBy: newClass. ]. (oldClass == nil or:[oldClass isObsolete not]) ifTrue:[newSuper addSubclass: newClass] ifFalse:[newSuper addObsoleteSubclass: newClass]. ^newClass! !!ClassBuilder methodsFor: 'class definition' stamp: 'Alexandre.Bergel 8/19/2009 11:22'!recompile: force from: oldClass to: newClass 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." oldClass == nil ifTrue:[^ newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ ^newClass]. currentClassIndex := 0. maxClassIndex := oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ "Recompile from newClass without mutating" self informUserDuring:[ newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ self mutate: oldClass to: newClass. ]. ^oldClass "now mutated to newClass"! !!ClassBuilder methodsFor: 'class definition' stamp: 'al 7/4/2009 16:55'!silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the instvar from srcClass to dstClass. Do not perform any checks." | srcVars dstVars dstIndex newClass copyOfSrcClass copyOfDstClass copyOfOldTraitComposition copyOfOldClassTraitComposition | copyOfSrcClass := srcClass copy. copyOfDstClass := dstClass copy. srcVars := srcClass instVarNames copyWithout: instVarName. srcClass == dstClass ifTrue:[dstVars := srcVars] ifFalse:[dstVars := dstClass instVarNames]. dstIndex := dstVars indexOf: prevInstVarName. dstVars := (dstVars copyFrom: 1 to: dstIndex), (Array with: instVarName), (dstVars copyFrom: dstIndex+1 to: dstVars size). instVarMap at: srcClass name put: srcVars. instVarMap at: dstClass name put: dstVars. (srcClass inheritsFrom: dstClass) ifTrue:[ copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. dstClass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := dstClass traitComposition copyTraitExpression ]. dstClass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := dstClass class traitComposition copyTraitExpression ]. newClass := self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. copyOfOldTraitComposition ifNotNil: [ newClass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newClass class setTraitComposition: copyOfOldClassTraitComposition ]. ] ifFalse:[ (dstClass inheritsFrom: srcClass) ifTrue:[ newClass := self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ] ifFalse:[ "Disjunct hierarchies" srcClass == dstClass ifFalse:[ newClass := self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ]. newClass := self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ]. ]. self doneCompiling: srcClass. self doneCompiling: dstClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfSrcClass to: srcClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfDstClass to: dstClass.! !!ClassBuilder methodsFor: 'class format' stamp: 'eem 6/13/2008 10:03'!computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex "Compute the new format for making oldClass a subclass of newSuper. Return the format or nil if there is any problem." | instSize isVar isWords isPointers isWeak | type == #compiledMethod ifTrue:[^CompiledMethod format]. instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). instSize > 254 ifTrue:[ self error: 'Class has too many instance variables (', instSize printString,')'. ^nil]. type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. (isPointers not and:[instSize > 0]) ifTrue:[ self error:'A non-pointer class cannot have instance variables'. ^nil]. ^(self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak) + (ccIndex bitShift: 11).! !!ClassBuilder methodsFor: 'class format' stamp: 'ar 7/11/1999 06:39'!format: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak "Compute the format for the given instance specfication." | cClass instSpec sizeHiBits fmt | self flag: #instSizeChange."Smalltalk browseAllCallsOn: #instSizeChange.Smalltalk browseAllImplementorsOf: #fixedFieldsOf:.Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:."" NOTE: This code supports the backward-compatible extension to 8 bits of instSize. For now the format word is... <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0> But when we revise the image format, it should become... <5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0>" sizeHiBits := (nInstVars+1) // 64. cClass := 0. "for now" instSpec := isWeak ifTrue:[4] ifFalse:[isPointers ifTrue: [isVar ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]] ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]] ifFalse: [isWords ifTrue: [6] ifFalse: [8]]]. fmt := sizeHiBits. fmt := (fmt bitShift: 5) + cClass. fmt := (fmt bitShift: 4) + instSpec. fmt := (fmt bitShift: 6) + ((nInstVars+1)\\64). "+1 since prim size field includes header" fmt := (fmt bitShift: 1). "This shift plus integer bit lets wordSize work like byteSize" ^fmt! !!ClassBuilder methodsFor: 'class mutation' stamp: 'al 7/4/2009 16:52'!mutate: oldClass to: newClass "Mutate the old class and subclasses into newClass and subclasses. Note: This method is slightly different from: #mutate:toSuper: since here we are at the root of reshaping and have two distinct roots." | copyOfOldTraitComposition copyOfOldClassTraitComposition | self showProgressFor: oldClass. "Convert the subclasses" oldClass subclasses do: [:oldSubclass | | newSubclass | copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. oldSubclass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldSubclass traitComposition copyTraitExpression ]. oldSubclass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldSubclass class traitComposition copyTraitExpression ]. newSubclass := self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. copyOfOldTraitComposition ifNotNil: [ newSubclass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newSubclass class setTraitComposition: copyOfOldClassTraitComposition ]. ]. "And any obsolete ones" oldClass obsoleteSubclasses do: [:oldSubclass | | newSubclass | oldSubclass ifNotNil: [ copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. oldSubclass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldSubclass traitComposition copyTraitExpression ]. oldSubclass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldSubclass class traitComposition copyTraitExpression ]. newSubclass := self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. copyOfOldTraitComposition ifNotNil: [ newSubclass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newSubclass class setTraitComposition: copyOfOldClassTraitComposition ]. ]. ]. self update: oldClass to: newClass. ^newClass! !!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/22/2002 03:16'!reshapeClass: oldClass toSuper: newSuper "Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class." | instVars | "ar 9/22/2002: The following is a left-over from some older code. I do *not* know why we uncompact oldClass here. If you do, then please let me know so I can put a comment here..." oldClass becomeUncompact. instVars := instVarMap at: oldClass name ifAbsent:[oldClass instVarNames]. ^self newSubclassOf: newSuper type: oldClass typeOfClass instanceVariables: instVars from: oldClass! !!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 23:42'!update: oldClass to: newClass "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. We can rely on two assumptions (which are critical): #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry. " | meta | meta := oldClass isMeta. "Note: Everything from here on will run without the ability to get interrupted to prevent any other process to create new instances of the old class." [ "Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy). Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below." oldClass superclass removeSubclass: oldClass. oldClass superclass removeObsoleteSubclass: oldClass. "Convert the instances of oldClass into instances of newClass" newClass updateInstancesFrom: oldClass. meta ifTrue:[oldClass becomeForward: newClass] ifFalse:[(Array with: oldClass with: oldClass class) elementsForwardIdentityTo: (Array with: newClass with: newClass class)]. Smalltalk garbageCollect. "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it." ] valueUnpreemptively.! !!ClassBuilder methodsFor: 'initialize' stamp: 'ar 3/3/2001 00:29'!doneCompiling: aClass "The receiver has finished modifying the class hierarchy. Do any necessary cleanup." aClass doneCompiling. Behavior flushObsoleteSubclasses.! !!ClassBuilder methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:47'!initialize super initialize. environ := Smalltalk. instVarMap := IdentityDictionary new.! !!ClassBuilder methodsFor: 'public' stamp: 'ar 8/29/1999 15:38'!class: oldClass instanceVariableNames: instVarString "This is the basic initialization message to change the definition of an existing Metaclass" oldClass isMeta ifFalse:[^self error: oldClass name, 'is not a Metaclass']. ^self class: oldClass instanceVariableNames: instVarString unsafe: false! !!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40'!moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the given instVar from srcClass to dstClass" (srcClass instVarNames includes: instVarName) ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. (srcClass inheritsFrom: dstClass) ifTrue:[ "Move the instvar up the hierarchy." (self validateClass: srcClass forMoving: instVarName upTo: dstClass) ifFalse:[^false]. ]. (dstClass inheritsFrom: srcClass) ifTrue:[ "Move the instvar down the hierarchy" (self validateClass: srcClass forMoving: instVarName downTo: dstClass) ifFalse:[^false]. ]. ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! !!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!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 inEnvironment: newSuper environment subclassOf: newSuper type: newSuper typeOfClass instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!ClassBuilder methodsFor: 'public' stamp: 'eem 6/13/2008 10:00'!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." | oldClassOrNil actualType | (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']. oldClassOrNil := aClass environment at: t ifAbsent:[nil]. actualType := (oldClassOrNil notNil and: [oldClassOrNil typeOfClass == #compiledMethod]) ifTrue: [#compiledMethod] ifFalse: [#bytes]. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: actualType instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!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 inEnvironment: aClass environment subclassOf: aClass type: #variable instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'!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 inEnvironment: aClass environment subclassOf: aClass type: #words instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'!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 inEnvironment: aClass environment subclassOf: aClass type: #weak instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!ClassBuilder methodsFor: 'validation' stamp: 'MarcusDenker 12/14/2009 19:34'!validateClass: srcClass forMoving: iv downTo: dstClass "Make sure that we don't have any accesses to the instVar left" srcClass withAllSubclassesDo:[:cls| (cls == dstClass or:[cls inheritsFrom: dstClass]) ifFalse:[ (cls whichSelectorsAccess: iv) isEmpty ifFalse:[ self notify: (iv printString asText allBold), ' is still used in ', cls name asText allBold,'.Proceed to move it to Undeclared'. ]. ]. ]. ^true! !!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:39'!validateClass: srcClass forMoving: iv upTo: dstClass "Make sure we don't have this instvar already" dstClass withAllSubclassesDo:[:cls| (cls == srcClass or:[cls inheritsFrom: srcClass]) ifFalse:[ cls isPointers ifFalse:[ self error: dstClass name, ' cannot have instance variables'. ^false]. cls instSize >= 254 ifTrue:[ self error: cls name, ' has more than 254 instance variables'. ^false]. (cls instVarNames includes: iv) ifTrue:[ self notify: (iv printString asText allBold),' is defined in ', cls name asText allBold,'Proceed to move it up to ', dstClass name asText allBold,' as well'. instVarMap at: cls name put: (cls instVarNames copyWithout: iv)]. ]. ]. ^true! !!ClassBuilder methodsFor: 'validation' stamp: 'AlainPlantec 9/23/2011 12:25'!validateClassName: aString "Validate the new class name" | allowed | aString isSymbol ifFalse: [ ^ false ]. allowed := ($0 to: $9), {$_}, ($A to: $Z), ($a to: $z). (aString detect: [:c | (allowed includes: c) not] ifNone: [ ]) ifNotNil: [ :c | self error: 'Invalid character: ''', c printString, ''''. ^ false]. aString first canBeGlobalVarInitial ifFalse:[ self error: 'Class names must be capitalized'. ^false]. environ at: aString ifPresent:[:old| (old isKindOf: Behavior) ifFalse:[ self notify: aString asText allBold, ' already exists!!\Proceed will store over it.' withCRs]]. ^ true! !!ClassBuilder methodsFor: 'validation' stamp: 'Janniklaval 10/23/2010 13:15'!validateClassvars: classVarArray from: oldClass forSuper: newSuper "Check if any of the classVars of oldClass conflict with the new superclass" | usedNames classVars temp | classVarArray isEmpty ifTrue:[^true]. "Okay" "Validate the class var names" usedNames := classVarArray asSet. usedNames size = classVarArray size ifFalse:[ classVarArray do:[:var| usedNames remove: var ifAbsent:[temp := var]]. self error: temp,' is multiply defined'. ^false]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp := var]]. self error: temp,' is a reserved name'. ^false]. newSuper == nil ifFalse:[ usedNames := newSuper allClassVarNames asSet. classVarArray do:[:iv| (usedNames includes: iv) ifTrue:[ newSuper withAllSuperclassesDo:[:cl| (cl classVarNames includes: iv) ifTrue:[temp := cl]]. (DuplicatedVariableError new) superclass: temp; variable: iv; signal: iv, ' is already defined in ', temp name. ^false]]]. classVars := classVarArray. oldClass == nil ifFalse:[ usedNames := Set new: 20. (oldClass allSubclasses reject: #isMeta) do: [:cl | usedNames addAll: cl classVarNames]. newSuper == nil ifFalse:[classVars := classVars, newSuper allClassVarNames asArray]. classVars do:[:iv| (usedNames includes: iv) ifTrue:[ (DuplicatedVariableError new) superclass: oldClass; variable: iv; signal: iv, ' is already defined in a subclass of ', oldClass name. ^false]]]. ^true! !!ClassBuilder methodsFor: 'validation' stamp: 'Janniklaval 10/23/2010 13:16'!validateInstvars: instVarArray from: oldClass forSuper: newSuper "Check if any of the instVars of oldClass conflict with the new superclass" | instVars usedNames temp | instVarArray isEmpty ifTrue:[^true]. "Okay" newSuper allowsSubInstVars ifFalse: [ self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ^ false]. "Validate the inst var names" usedNames := instVarArray asSet. usedNames size = instVarArray size ifFalse:[ instVarArray do:[:var| usedNames remove: var ifAbsent:[temp := var]]. self error: temp,' is multiply defined'. ^false]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp := var]]. self error: temp,' is a reserved name'. ^false]. newSuper == nil ifFalse:[ usedNames := newSuper allInstVarNames asSet. instVarArray do:[:iv| (usedNames includes: iv) ifTrue:[ newSuper withAllSuperclassesDo:[:cl| (cl instVarNames includes: iv) ifTrue:[temp := cl]]. (DuplicatedVariableError new) superclass: temp; variable: iv; signal: iv,' is already defined in ', temp name. ^false]]]. oldClass == nil ifFalse:[ usedNames := Set new: 20. oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames]. instVars := instVarArray. newSuper == nil ifFalse:[instVars := instVars, newSuper allInstVarNames]. instVars do:[:iv| (usedNames includes: iv) ifTrue:[ (DuplicatedVariableError new) superclass: oldClass; variable: iv; signal: iv, ' is already defined in a subclass of ', oldClass name. ^false]]]. ^true! !!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/13/2009 21:19'!validateSubclass: subclass canKeepLayoutFrom: oldClass forSubclassFormat: newType "Returns whether the immediate subclasses of oldClass can keep its layout" "Note: Squeak does not appear to model classFormat relationships.. so I'm putting some logic here. bkv 4/2/2003" "Only run this test for a real subclass - otherwise this prevents changing a class from #subclass: to #variableSubclass: etc." subclass = oldClass ifTrue:[^true]. "isWeak implies isVariant" (oldClass isVariable and: [ subclass isWeak ]) ifFalse: [ "In general we discourage format mis-matches" (subclass typeOfClass == newType) ifFalse: [ self error: subclass name,' cannot be recompiled'. ^ false ]]. ^ true! !!ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:19'!validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize "Validate the # of instVars and the format of the subclasses" | deltaSize | oldClass == nil ifTrue: [^ true]. "No subclasses" "Compute the # of instvars needed for all subclasses" deltaSize := newInstSize. (oldClass notNil) ifTrue: [deltaSize := deltaSize - oldClass instVarNames size]. (newSuper notNil) ifTrue: [deltaSize := deltaSize + newSuper instSize]. (oldClass notNil and: [oldClass superclass notNil]) ifTrue: [deltaSize := deltaSize - oldClass superclass instSize]. (oldClass == nil) ifTrue: [ (deltaSize > 254) ifTrue: [ self error: 'More than 254 instance variables'. ^ false]. ^ true]. oldClass withAllSubclassesDo: [:sub | ( sub instSize + deltaSize > 254 ) ifTrue: [ self error: sub name,' has more than 254 instance variables'. ^ false]. "If we get this far, check whether the immediate subclasses of oldClass can keep its layout." (newType ~~ #normal) ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]]. ^ true! !!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:50'!validateSuperclass: aSuperClass forSubclass: aClass "Check if it is okay to use aSuperClass as the superclass of aClass" aClass == nil ifTrue:["New class" (aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]]) ifFalse:[self error: aSuperClass name,' is not a valid superclass'. ^false]. ^true]. aSuperClass == aClass superclass ifTrue:[^true]. "No change" (aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy" ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name]. "Check for circular references" (aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]]) ifTrue:[self error: aSuperClass name,' inherits from ', aClass name. ^false]. ^true! !!ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'!privateNewSubclassOf: newSuper "Create a new meta and non-meta subclass of newSuper" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta newMeta | newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. newMeta := Metaclass new. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: newSuperMeta format. ^newMeta new! !!ClassBuilder methodsFor: 'private' stamp: 'pmm 3/13/2010 11:21'!privateNewSubclassOf: newSuper from: oldClass "Create a new meta and non-meta subclass of newSuper using oldClass as template" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta oldMeta newMeta | oldClass ifNil:[^self privateNewSubclassOf: newSuper]. newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. oldMeta := oldClass class. newMeta := oldMeta shallowCopy. 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]. "Record the meta class change" self recordClass: oldMeta replacedBy: newMeta. "And create a new instance" ^newMeta adoptInstance: oldClass from: oldMeta! !!ClassBuilder methodsFor: 'private' stamp: 'NS 1/27/2004 14:21'!recordClass: oldClass replacedBy: newClass "Keep the changes up to date when we're moving instVars around" (instVarMap includesKey: oldClass name) ifTrue:[ SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldClass to: newClass. ].! !!ClassBuilder methodsFor: 'private' stamp: 'gk 2/28/2005 16:35'!reservedNames "Return a list of names that must not be used for variables" ^#('self' 'super' 'thisContext' 'true' 'false' 'nil' self super thisContext #true #false #nil).! !!ClassBuilder methodsFor: 'private' stamp: 'ar 3/5/2001 12:00'!showProgressFor: aClass "Announce that we're processing aClass" progress == nil ifTrue:[^self]. aClass isObsolete ifTrue:[^self]. currentClassIndex := currentClassIndex + 1. (aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue: [progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')]! !!ClassBuilder methodsFor: 'private' stamp: 'StephaneDucasse 7/9/2010 23:05'!tooDangerousClasses "Return a list of class names which will not be modified in the public interface" ^#( "Object will break immediately" ProtoObject Object "Contexts and their superclasses" InstructionStream ContextPart BlockContext MethodContext BlockClosure "Superclasses of basic collections" Collection SequenceableCollection ArrayedCollection "Collections known to the VM" Array Bitmap String Symbol ByteArray CompiledMethod "Basic Numbers" Magnitude Number SmallInteger Float "Misc other" LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject )! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!ClassBuilder class instanceVariableNames: ''!!ClassBuilder class methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'!checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" UIManager default informUserDuring: [ :bar | self checkClassHierarchyConsistency: bar ]! !!ClassBuilder class methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'!cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." UIManager default informUserDuring: [ :bar | self cleanupAndCheckClassHierarchy: bar ]! !!ClassBuilder class methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'!cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." UIManager default informUserDuring: [ :bar | self cleanupClassHierarchy: bar ]! !!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:50'!beSilent: aBool "ClassDefiner beSilent: true" "ClassDefiner beSilent: false" QuietMode := aBool.! !!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:53'!beSilentDuring: aBlock "Temporarily suppress information about what is going on" | wasSilent result | wasSilent := self isSilent. self beSilent: true. result := aBlock value. self beSilent: wasSilent. ^result! !!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:48'!isSilent ^QuietMode == true! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'StephaneDucasse 5/27/2011 19:11'!checkClassHierarchyConsistency: informer "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" | classes | self crLog: 'Start checking the class hierarchy...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. self checkClassHierarchyConsistencyFor: meta. ]. self log: 'OK'.! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'!checkClassHierarchyConsistencyFor: aClassDescription "Check whether aClassDescription has a consistent superclass and consistent regular and obsolete subclasses" | mySuperclass | mySuperclass := aClassDescription superclass. (mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete ifTrue: [self error: 'Something wrong!!']. mySuperclass ifNil: [^ self]. "Obsolete subclasses of nil cannot be stored" (mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. aClassDescription subclasses do: [:each | each isObsolete ifTrue: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ]. aClassDescription obsoleteSubclasses do: [:each | each isObsolete ifFalse: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ].! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'StephaneDucasse 5/27/2011 19:12'!cleanupAndCheckClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." self crLog: '*** Before cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses. self cleanupClassHierarchy: informer. self checkClassHierarchyConsistency: informer. self crLog: ''; crLog: '*** After cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses.! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'StephaneDucasse 5/27/2011 19:12'!cleanupClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." | classes | self crLog: 'Start fixing the class hierarchy and cleaning up...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. self cleanupClassHierarchyFor: meta. ]. self logCr: 'DONE'.! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'lr 3/14/2010 21:13'!cleanupClassHierarchyFor: aClassDescription | myName mySuperclass | mySuperclass := aClassDescription superclass. (self isReallyObsolete: aClassDescription) ifTrue: [ "Remove class >>>from SystemDictionary if it is obsolete" myName := aClassDescription name asString. Smalltalk keys asArray do: [ :each | (each asString = myName and: [ (Smalltalk globals at: each) == aClassDescription ]) ifTrue: [ Smalltalk removeKey: each ] ]. "Make class officially obsolete if it is not" (aClassDescription name asString beginsWith: 'AnObsolete') ifFalse: [ aClassDescription obsolete ]. aClassDescription isObsolete ifFalse: [ self error: 'Something wrong!!' ]. "Add class to obsoleteSubclasses of its superclass" mySuperclass ifNil: [ self error: 'Obsolete subclasses of nil cannot be stored' ]. (mySuperclass obsoleteSubclasses includes: aClassDescription) ifFalse: [ mySuperclass addObsoleteSubclass: aClassDescription ] ] ifFalse: [ "check if superclass has aClassDescription in its obsolete subclasses" mySuperclass ifNil: [ mySuperclass := Class ]. "nil subclasses" mySuperclass removeObsoleteSubclass: aClassDescription ]. "And remove its obsolete subclasses if not actual superclass" aClassDescription obsoleteSubclasses do: [ :obs | obs superclass == aClassDescription ifFalse: [ aClassDescription removeObsoleteSubclass: obs ] ]! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'StephaneDucasse 5/27/2011 19:13'!countReallyObsoleteClassesAndMetaclasses "Counting really obsolete classes and metaclasses" | metaSize classSize | Smalltalk garbageCollect. metaSize := self reallyObsoleteMetaclasses size. self crLog: 'Really obsolete metaclasses: ', metaSize printString. classSize := self reallyObsoleteClasses size. Transcript crLog: 'Really obsolete classes: ', classSize printString; cr. "Metaclasses must correspond to classes!!" metaSize ~= classSize ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'!isReallyObsolete: aClassDescription "Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete isObsolete does not always return the right answer" ^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'!reallyObsoleteClasses | obsoleteClasses | obsoleteClasses := OrderedCollection new. Metaclass allInstances do: [:meta | meta allInstances do: [:each | (self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]]. ^ obsoleteClasses! !!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'!reallyObsoleteMetaclasses ^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! ! Object subclass: #SharedPool instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!SharedPool commentStamp: '<historical>' prior: 0!A shared pool represents a set of bindings which are accessible to all classes which import the pool in its 'pool dictionaries'. SharedPool is NOT a dictionary but rather a name space. Bindings are represented by 'class variables' - as long as we have no better way to represent them at least.!"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!SharedPool class instanceVariableNames: ''!!SharedPool class methodsFor: 'enumerating' stamp: 'tpr 12/14/2004 12:34'!keysDo: aBlock"A hopefully temporary fix for an issue arising from miss-spelled variable names in code being compiled. The correction code (see Class>possibleVariablesFor:continuedFrom: assumes that sharedPools are Dictionaries. The proper fix would involve making sure all pools are actually subclasses of SharedPool, which they are not currently." self bindingsDo:[:b| aBlock value: b key]! !!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 17:46'!bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" | aSymbol binding | aSymbol := varName asSymbol. "First look in classVar dictionary." binding := self classPool bindingOf: aSymbol. binding ifNotNil:[^binding]. "Next look in shared pools." self sharedPools do:[:pool | binding := pool bindingOf: aSymbol. binding ifNotNil:[^binding]. ]. "subclassing and environment are not preserved" ^nil! !!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 20:33'!bindingsDo: aBlock ^self classPool bindingsDo: aBlock! !!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 18:14'!classBindingOf: varName "For initialization messages grant the regular scope" ^super bindingOf: varName! !!SharedPool class methodsFor: 'name lookup' stamp: 'tween 9/13/2004 10:10'!hasBindingThatBeginsWith: aString "Answer true if the receiver has a binding that begins with aString, false otherwise" "First look in classVar dictionary." (self classPool hasBindingThatBeginsWith: aString) ifTrue:[^true]. "Next look in shared pools." self sharedPools do:[:pool | (pool hasBindingThatBeginsWith: aString) ifTrue: [^true]]. ^false! !!SharedPool class methodsFor: 'name lookup' stamp: 'tpr 5/29/2003 18:12'!includesKey: aName "does this pool include aName" ^(self bindingOf: aName) notNil! ! Object subclass: #Behavior uses: TPureBehavior instanceVariableNames: 'superclass methodDict format' classVariableNames: 'ObsoleteSubclasses' poolDictionaries: '' category: 'Kernel-Classes'!!Behavior commentStamp: 'al 12/8/2005 20:44' prior: 0!My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).!!Behavior methodsFor: '*System-Object Storage' stamp: 'di 3/27/1999 13:02'!rootStubInImageSegment: imageSegment ^ ImageSegmentRootStub new xxSuperclass: superclass format: format segment: imageSegment! !!Behavior methodsFor: '*System-Object Storage' stamp: 'MarianoMartinezPeck 1/18/2010 14:44'!startUpFrom: anObject "Override this when a per-instance startUp message needs to be sent. For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine. This can happens with ImageSegment for example." ^ nil! !!Behavior methodsFor: '*System-Support' stamp: 'StephaneDucasse 4/30/2011 21:36'!allCallsOn "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." ^ (self allCallsOnIn: self systemNavigation)! !!Behavior methodsFor: '*System-Support' stamp: 'StephaneDucasse 4/30/2011 21:35'!allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." ^ self systemNavigation allCallsOn: aSymbol from: self . ! !!Behavior methodsFor: '*System-Support' stamp: 'StephaneDucasse 4/30/2011 21:35'!allCallsOnIn: aSystemNavigation "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." ^ (aSystemNavigation allReferencesTo: (self environment associationAt: self theNonMetaClass name)), (aSystemNavigation allCallsOn: self theNonMetaClass name) ! !!Behavior methodsFor: '*System-Support'!allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system." ^ SystemNavigation default allUnsentMessagesIn: self selectors! !!Behavior methodsFor: '*Tools-Inspector' stamp: 'StephaneDucasse 5/28/2011 13:26'!inspectAllInstances "Inpsect all instances of the receiver. 1/26/96 sw" | all allSize prefix | all := self allInstances. (allSize := all size) isZero ifTrue: [^ self inform: 'There are no instances of ', self name]. prefix := allSize = 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name)! !!Behavior methodsFor: '*Tools-Inspector' stamp: 'StephaneDucasse 5/28/2011 13:26'!inspectSubInstances "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" | all allSize prefix | all := self allSubInstances. (allSize := all size) isZero ifTrue: [^ self inform: 'There are no instances of ', self name, 'or any of its subclasses']. prefix := allSize = 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! !!Behavior methodsFor: 'accessing' stamp: 'ajh 9/19/2001 17:30'!classDepth superclass ifNil: [^ 1]. ^ superclass classDepth + 1! !!Behavior methodsFor: 'accessing'!compilerClass "Answer a compiler class appropriate for source methods of this class." ^Compiler! !!Behavior methodsFor: 'accessing'!decompilerClass "Answer a decompiler class appropriate for compiled methods of this class." ^ self compilerClass decompilerClass! !!Behavior methodsFor: 'accessing' stamp: 'StephaneDucasse 3/16/2010 16:26'!environment "Return the environment in which the receiver is visible" ^Smalltalk globals! !!Behavior methodsFor: 'accessing'!evaluatorClass "Answer an evaluator class appropriate for evaluating expressions in the context of this class." ^Compiler! !!Behavior methodsFor: 'accessing'!format "Answer an Integer that encodes the kinds and numbers of variables of instances of the receiver." ^format! !!Behavior methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 1/8/2010 10:26'!methodDict methodDict == nil ifTrue: [self manageMDFault]. ^ methodDict! !!Behavior methodsFor: 'accessing' stamp: 'rca 7/26/2000 16:53'!name "Answer a String that is the name of the receiver." ^'a subclass of ', superclass name! !!Behavior methodsFor: 'accessing' stamp: 'Alexandre Bergel 4/27/2010 14:05'!numberOfInstanceVariables ^ self instVarNames size! !!Behavior methodsFor: 'accessing'!parserClass "Answer a parser class to use for parsing method headers." ^self compilerClass parserClass! !!Behavior methodsFor: 'accessing'!sourceCodeTemplate "Answer an expression to be edited and evaluated in order to define methods in this class or trait." ^'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! !!Behavior methodsFor: 'accessing'!subclassDefinerClass "Answer an evaluator class appropriate for evaluating definitions of new subclasses of this class." ^Compiler! !!Behavior methodsFor: 'accessing' stamp: 'ar 7/13/1999 22:00'!typeOfClass "Answer a symbol uniquely describing the type of the receiver" self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" self isBytes ifTrue:[^#bytes]. (self isWords and:[self isPointers not]) ifTrue:[^#words]. self isWeak ifTrue:[^#weak]. self isVariable ifTrue:[^#variable]. ^#normal.! !!Behavior methodsFor: 'accessing class hierarchy' stamp: 'StephaneDucasse 3/1/2011 21:24'!allSubclasses "Answer an orderedCollection of the receiver's and the receiver's descendent's subclasses. " | scan scanTop | scan := OrderedCollection withAll: self subclasses. scanTop := 1. [scanTop > scan size] whileFalse: [scan addAll: (scan at: scanTop) subclasses. scanTop := scanTop + 1]. ^ scan! !!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:06'!allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level "Walk the tree of subclasses, giving the class and its level" | subclassNames | classAndLevelBlock value: self value: level. self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" "Visit subclasses in alphabetical order" subclassNames := SortedCollection new. self subclassesDo: [:subC | subclassNames add: subC name]. subclassNames do: [:name | (self environment at: name) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level+1]! !!Behavior methodsFor: 'accessing class hierarchy'!allSuperclasses "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses. The first element is the receiver's immediate superclass, followed by its superclass; the last element is Object." | temp | ^ superclass == nil ifTrue: [ OrderedCollection new] ifFalse: [temp := superclass allSuperclasses. temp addFirst: superclass. temp]! !!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 1/28/2009 14:20'!allSuperclassesIncluding: aClass "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses up to aClass included. The first element is the receiver's immediate superclass up to aClass included." | temp | ^ superclass == aClass ifTrue: [ OrderedCollection with: aClass] ifFalse: [temp := superclass allSuperclassesIncluding: aClass. temp addFirst: superclass. temp]! !!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/14/2004 18:09'!subclasses "slow implementation since Behavior does not keep trace of subclasses" ^ self class allInstances select: [:each | each superclass = self ]! !!Behavior methodsFor: 'accessing class hierarchy'!superclass "Answer the receiver's superclass, a Class." ^superclass! !!Behavior methodsFor: 'accessing class hierarchy' stamp: 'ar 7/10/1999 12:10'!superclass: aClass "Change the receiver's superclass to be aClass." "Note: Do not use 'aClass isKindOf: Behavior' here in case we recompile from Behavior itself." (aClass == nil or: [aClass isBehavior]) ifTrue: [superclass := aClass. Object flushCache] ifFalse: [self error: 'superclass must be a class-describing object']! !!Behavior methodsFor: 'accessing class hierarchy'!withAllSubclasses "Answer a Set of the receiver, the receiver's descendent's, and the receiver's descendent's subclasses." ^ self allSubclasses add: self; yourself! !!Behavior methodsFor: 'accessing class hierarchy'!withAllSuperclasses "Answer an OrderedCollection of the receiver and the receiver's superclasses. The first element is the receiver, followed by its superclass; the last element is Object." | temp | temp := self allSuperclasses. temp addFirst: self. ^ temp! !!Behavior methodsFor: 'accessing instances and variables'!allClassVarNames "Answer a Set of the names of the receiver's and the receiver's ancestor's class variables." ^superclass allClassVarNames! !!Behavior methodsFor: 'accessing instances and variables'!allInstVarNames "Answer an Array of the names of the receiver's instance variables. The Array ordering is the order in which the variables are stored and accessed by the interpreter." | vars | superclass == nil ifTrue: [vars := self instVarNames copy] "Guarantee a copy is answered." ifFalse: [vars := superclass allInstVarNames , self instVarNames]. ^vars! !!Behavior methodsFor: 'accessing instances and variables' stamp: 'MarcusDenker 10/17/2009 16:49'!allInstances "Answer a collection of all current instances of the receiver." | all inst next | all := OrderedCollection new. inst := self someInstance. [inst == nil] whileFalse: [ next := inst nextInstance. inst == all ifFalse: [all add: inst]. inst := next]. ^ all asArray! !!Behavior methodsFor: 'accessing instances and variables' stamp: 'tpr 5/30/2003 13:04'!allSharedPools "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." ^superclass allSharedPools! !!Behavior methodsFor: 'accessing instances and variables' stamp: 'di 6/20/97 10:51'!allSubInstances "Answer a list of all current instances of the receiver and all of its subclasses." | aCollection | aCollection := OrderedCollection new. self allSubInstancesDo: [:x | x == aCollection ifFalse: [aCollection add: x]]. ^ aCollection! !!Behavior methodsFor: 'accessing instances and variables' stamp: 'ajh 10/17/2002 11:03'!allowsSubInstVars "Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses." ^ true! !!Behavior methodsFor: 'accessing instances and variables' stamp: 'nice 10/20/2009 22:03'!classVarNames "Answer a collection of the receiver's class variable names." ^#()! !!Behavior methodsFor: 'accessing instances and variables' stamp: 'StephaneDucasse 11/9/2010 14:47'!includesSharedPoolNamed: aSharedPoolString "Answer whether the receiver uses the shared pool named aSharedPoolString" ^ (self sharedPools anySatisfy: [:each | each name = aSharedPoolString])! !!Behavior methodsFor: 'accessing instances and variables'!instVarNames "Answer an Array of the instance variable names. Behaviors must make up fake local instance variable names because Behaviors have instance variables for the purpose of compiling methods, but these are not named instance variables." | mySize superSize | mySize := self instSize. superSize := superclass == nil ifTrue: [0] ifFalse: [superclass instSize]. mySize = superSize ifTrue: [^#()]. ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! !!Behavior methodsFor: 'accessing instances and variables'!instanceCount "Answer the number of instances of the receiver that are currently in use." | count | count := 0. self allInstancesDo: [:x | count := count + 1]. ^count! !!Behavior methodsFor: 'accessing instances and variables'!sharedPools "Answer a Set of the names of the pools (Dictionaries) that the receiver shares. 9/12/96 tk sharedPools have an order now" ^ OrderedCollection new! !!Behavior methodsFor: 'accessing instances and variables'!someInstance "Primitive. Answer the first instance in the enumeration of all instances of the receiver. Fails if there are none. Essential. See Object documentation whatIsAPrimitive." <primitive: 77> ^nil! !!Behavior methodsFor: 'accessing instances and variables'!subclassInstVarNames "Answer a Set of the names of the receiver's subclasses' instance variables." | vars | vars := Set new. self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames]. ^vars! !!Behavior methodsFor: 'accessing method dictionary'!>> selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^self compiledMethodAt: selector! !!Behavior methodsFor: 'accessing method dictionary'!addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil! !!Behavior methodsFor: 'accessing method dictionary'!addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod! !!Behavior methodsFor: 'accessing method dictionary'!addSelectorSilently: selector withMethod: compiledMethod self methodDictAddSelectorSilently: selector withMethod: compiledMethod. self registerLocalSelector: selector! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'MarcusDenker 10/24/2010 16:34'!allMethods "Return the collection of compiled method I and my superclasses are defining" "asArray is used to not bump into a bug when comparing compiled methods." ^ self allSelectors asArray collect: [ :s | self lookupSelector: s ]! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'kph 8/27/2008 22:31'!allSelectors "Answer all selectors understood by instances of the receiver" ^ self allSelectorsBelow: nil! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:29'!allSelectorsAbove ^ self allSelectorsAboveUntil: ProtoObject ! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:28'!allSelectorsAboveUntil: aRootClass | coll | coll := IdentitySet new. (self allSuperclassesIncluding: aRootClass) do: [:aClass | aClass selectorsDo: [ :sel | coll add: sel ]]. ^ coll ! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'dc 9/28/2008 15:54'!allSelectorsBelow: topClass | coll | coll := IdentitySet new. self withAllSuperclassesDo: [:aClass | aClass = topClass ifTrue: [^ coll ] ifFalse: [aClass selectorsDo: [ :sel | coll add: sel ]]]. ^ coll ! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 6/12/2006 10:48'!basicLocalSelectors "Direct accessor for the instance variable localSelectors. Because of hardcoded ivar indexes of Behavior and Class in the VM, Class and Metaclass declare the needed ivar and override this method as an accessor. By returning nil instead of declaring this method as a subclass responsibility, Behavior can be instantiated for creating anonymous classes." ^nil! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 3/25/2006 13:17'!basicLocalSelectors: aSetOrNil self subclassResponsibility ! !!Behavior methodsFor: 'accessing method dictionary'!changeRecordsAt: selector "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" ^ChangeSet scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) class: self meta: self isMeta category: (self whichCategoryIncludesSelector: selector) selector: selector.! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'nice 1/5/2010 15:59'!classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock "Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated with the class that defines the selector and the associated method. Otherwise absentBlock is evaluated." self withAllSuperclassesDo: [:class | | method | method := class compiledMethodAt: aSymbol ifAbsent: [nil]. method ifNotNil: [^ binaryBlock value: class value: method]. ]. ^ absentBlock value.! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/20/2005 11:11'!commentsAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." ^self commentsIn: (self sourceCodeAt: selector) asString. "Behavior commentsAt: #commentsAt:"! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'ul 11/15/2010 10:09'!commentsIn: sourceString | commentStart nextQuotePos someComments aPos | ('*"*' match: sourceString) ifFalse: [^#()]. someComments:= OrderedCollection new. sourceString size = 0 ifTrue: [^ someComments]. aPos:=1. nextQuotePos:= 0. [commentStart := sourceString findString: '"' startingAt: aPos. nextQuotePos:= self nextQuotePosIn: sourceString startingFrom: commentStart. (commentStart ~= 0 and: [nextQuotePos >commentStart])] whileTrue: [ commentStart ~= nextQuotePos ifTrue: [ someComments add: ((sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"').]. aPos := nextQuotePos+1]. ^someComments! !!Behavior methodsFor: 'accessing method dictionary'!compiledMethodAt: selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^ self methodDict at: selector! !!Behavior methodsFor: 'accessing method dictionary'!compiledMethodAt: selector ifAbsent: aBlock "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" ^ self methodDict at: selector ifAbsent: [aBlock value]! !!Behavior methodsFor: 'accessing method dictionary'!compress "Compact the method dictionary of the receiver." self methodDict rehash! !!Behavior methodsFor: 'accessing method dictionary'!compressedSourceCodeAt: selector "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" | rawText parse | rawText := (self sourceCodeAt: selector) asString. parse := self compilerClass new parse: rawText in: self notifying: nil. ^ rawText compressWithTable: ((selector keywords , parse tempNames , self instVarNames , #(self super ifTrue: ifFalse:) , ((0 to: 7) collect: [:i | String streamContents: [:s | s cr. i timesRepeat: [s tab]]]) , (self compiledMethodAt: selector) literalStrings) asSortedCollection: [:a :b | a size > b size])! !!Behavior methodsFor: 'accessing method dictionary'!deregisterLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors remove: aSymbol ifAbsent: []]! !!Behavior methodsFor: 'accessing method dictionary'!firstCommentAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." |someComments| someComments := self commentsAt: selector. ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first]"Behavior firstCommentAt: #firstCommentAt:"! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'damiencassou 5/30/2008 10:56'!firstPrecodeCommentFor: selector "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" | parser source tree | (#(#Comment #Definition #Hierarchy ) includes: selector) ifTrue: [ "Not really a selector" ^ nil ]. source := self sourceCodeAt: selector asSymbol ifAbsent: [ ^ nil ]. parser := self parserClass new. tree := parser parse: source readStream class: self noPattern: false context: nil notifying: nil ifFail: [ ^ nil ]. ^ (tree comment ifNil: [ ^ nil ]) first! !!Behavior methodsFor: 'accessing method dictionary'!"popeye" formalHeaderPartsFor: "olive oil" aSelector "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header The result will have 3 elements for a simple, argumentless selector. 5 elements for a single-argument selector 9 elements for a two-argument selector 13 elements for a three-argument, selector etc... The syntactic elements are: 1 comment preceding initial selector fragment 2 first selector fragment 3 comment following first selector fragment (nil if selector has no arguments) ---------------------- (ends here for, e.g., #copy) 4 first formal argument 5 comment following first formal argument (nil if selector has only one argument) ---------------------- (ends here for, e.g., #copyFrom:) 6 second keyword 7 comment following second keyword 8 second formal argument 9 comment following second formal argument (nil if selector has only two arguments) ---------------------- (ends here for, e.g., #copyFrom:to:) Any nil element signifies an absent comment. NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector)" Behavior class formalHeaderPartsFor: #formalHeaderPartsFor:" ! !!Behavior methodsFor: 'accessing method dictionary'!formalParametersAt: aSelector "Return the names of the arguments used in this method." | source | source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" ^(self parserClass new) parseParameterNames: source! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/2/1999 15:45'!lookupSelector: selector "Look up the given selector in my methodDictionary. Return the corresponding method if found. Otherwise chase the superclass chain and try again. Return nil if no method is found." | lookupClass | lookupClass := self. [lookupClass == nil] whileFalse: [(lookupClass includesSelector: selector) ifTrue: [^ lookupClass compiledMethodAt: selector]. lookupClass := lookupClass superclass]. ^ nil! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'dvf 9/27/2005 17:08'!methodDict: aDictionary methodDict := aDictionary! !!Behavior methodsFor: 'accessing method dictionary'!methodDictionary "Convenience" ^self methodDict! !!Behavior methodsFor: 'accessing method dictionary'!methodDictionary: aDictionary self methodDict: aDictionary! !!Behavior methodsFor: 'accessing method dictionary'!methodHeaderFor: selector "Answer the string corresponding to the method header for the given selector" | sourceString parser | sourceString := self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. (parser := self parserClass new) parseSelector: sourceString. ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) "Behavior methodHeaderFor: #methodHeaderFor: "! !!Behavior methodsFor: 'accessing method dictionary'!methodsDo: aBlock "Evaluate aBlock for all the compiled methods in my method dictionary." ^ self methodDict valuesDo: aBlock! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 12:04'!nextQuotePosIn: sourceString startingFrom: commentStart | pos nextQuotePos | pos := commentStart + 1. [((nextQuotePos := sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)) and: [nextQuotePos ~= 0]] whileTrue: [pos := nextQuotePos + 2]. ^nextQuotePos! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'StephaneDucasse 3/6/2010 09:26'!precodeCommentOrInheritedCommentFor: selector "Answer a string representing the first comment in the method associated with selector, considering however only comments that occur before the beginning of the actual code. If the version recorded in the receiver is uncommented, look up the inheritance chain. Return nil if none found." | aSuper aComment | ^ (aComment := self firstPrecodeCommentFor: selector) isEmptyOrNil ifTrue: [(self == Behavior or: [superclass == nil or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector]] ifFalse: [aComment]! !!Behavior methodsFor: 'accessing method dictionary'!registerLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors add: aSymbol]! !!Behavior methodsFor: 'accessing method dictionary'!removeSelector: aSelector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method. If the method to remove will be replaced by a method from my trait composition, the current method does not have to be removed because we mark it as non-local. If it is not identical to the actual method from the trait it will be replaced automatically by #noteChangedSelectors:. This is useful to avoid bootstrapping problems when moving methods to a trait (e.g., from TPureBehavior to TMethodDictionaryBehavior). Manual moving (implementing the method in the trait and then remove it from the class) does not work if the methods themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or addTraitSelector:withMethod:)" | changeFromLocalToTraitMethod | changeFromLocalToTraitMethod := (self includesLocalSelector: aSelector) and: [self hasTraitComposition and: [self traitComposition includesMethod: aSelector]]. changeFromLocalToTraitMethod ifFalse: [self basicRemoveSelector: aSelector] ifTrue: [self ensureLocalSelectors]. self deregisterLocalSelector: aSelector. self noteChangedSelectors: (Array with: aSelector) ! !!Behavior methodsFor: 'accessing method dictionary'!removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! !!Behavior methodsFor: 'accessing method dictionary'!selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys! !!Behavior methodsFor: 'accessing method dictionary'!selectorsAndMethodsDo: selectorAndMethodBlock "Evaluate selectorAndMethodBlock with two arguments for each selector/method pair in my method dictionary." ^ self methodDict keysAndValuesDo: selectorAndMethodBlock! !!Behavior methodsFor: 'accessing method dictionary'!selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: selectorBlock! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'md 1/2/2006 18:56'!selectorsWithArgs: numberOfArgs "Return all selectors defined in this class that take this number of arguments" ^ self selectors select: [:selector | selector numArgs = numberOfArgs]! !!Behavior methodsFor: 'accessing method dictionary'!sourceCodeAt: selector ^ (self methodDict at: selector) getSourceFor: selector in: self! !!Behavior methodsFor: 'accessing method dictionary'!sourceCodeAt: selector ifAbsent: aBlock ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! !!Behavior methodsFor: 'accessing method dictionary'!sourceMethodAt: selector "Answer the paragraph corresponding to the source code for the argument." ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! !!Behavior methodsFor: 'accessing method dictionary'!sourceMethodAt: selector ifAbsent: aBlock "Answer the paragraph corresponding to the source code for the argument." ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! !!Behavior methodsFor: 'accessing method dictionary'!standardMethodHeaderFor: aSelector | args | args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. args size = 0 ifTrue:[^aSelector asString]. args size = 1 ifTrue:[^aSelector,' arg1']. ^String streamContents:[:s| (aSelector findTokens:':') with: args do:[:tok :arg| s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. ]. ].! !!Behavior methodsFor: 'accessing method dictionary'!supermostPrecodeCommentFor: selector "Answer a string representing the precode comment in the most distant superclass's implementation of the selector. Return nil if none found." | aSuper superComment | (self == Behavior or: [superclass == nil or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: ["There is a super implementor" superComment := aSuper supermostPrecodeCommentFor: selector]. ^ superComment ifNil: [self firstPrecodeCommentFor: selector "ActorState supermostPrecodeCommentFor: #printOn:"]! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 12/6/2004 11:36'!ultimateSourceCodeAt: selector ifAbsent: aBlock "Return the source code at selector, deferring to superclass if necessary" ^ self sourceCodeAt: selector ifAbsent: [superclass ifNil: [aBlock value] ifNotNil: [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! !!Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 11/19/2004 15:18'!zapAllMethods "Remove all methods in this class which is assumed to be obsolete" methodDict := self emptyMethodDictionary. self class isMeta ifTrue: [self class zapAllMethods]! !!Behavior methodsFor: 'adding/removing methods' stamp: 'HenrikSperreJohansen 2/16/2011 13:34'!adoptInstance: anInstance "Change the class of anInstance to me. Primitive (found in Cog and new VMs) follows the same rules as primitiveChangeClassTo:, but returns the class rather than the modified instance" <primitive: 160 error: ec> anInstance primitiveChangeClassTo: self basicNew. ^self! !!Behavior methodsFor: 'adding/removing methods' stamp: 'VeronicaUquillas 6/11/2010 12:46'!basicAddSelector: 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. compiledMethod methodClass: self. compiledMethod selector: selector. "Now flush Pharo's method cache, either by selector or by method" oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache]. selector flushCache.! !!Behavior methodsFor: 'adding/removing methods' stamp: 'nice 12/3/2009 23:57'!localSelectors "Return a set of selectors defined locally. The instance variable is lazily initialized. If it is nil then there are no non-local selectors" ^ self basicLocalSelectors isNil ifTrue: [self selectors asSet] ifFalse: [self basicLocalSelectors].! !!Behavior methodsFor: 'adding/removing methods'!methodDictAddSelectorSilently: selector withMethod: compiledMethod self basicAddSelector: selector withMethod: compiledMethod! !!Behavior methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:08'!cleanUp "Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. Subclasses may override #cleanUp: to provide different levels of cleanliness"! !!Behavior methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:11'!cleanUp: aggressive "Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. The argument should be used to indicate how aggressive the cleanup should be. Some subclasses may act differently depending on its value - for example, ChangeSet will only delete all unused and reinitialize the current change set if we're asking it to be aggressive." ^self cleanUp! !!Behavior methodsFor: 'compiling'!binding ^ nil -> self! !!Behavior methodsFor: 'compiling'!compile: code "Compile the argument, code, as source code in the context of the receiver. Create an error notification if the code can not be compiled. The argument is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." ^self compile: code notifying: nil! !!Behavior methodsFor: 'compiling'!compile: code classified: category 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 classified: category notifying: requestor ifFail: failBlock. ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! !!Behavior methodsFor: 'compiling'!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 compile: code "a Text" classified: nil 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'!compileAll ^ self compileAllFrom: self! !!Behavior methodsFor: 'compiling' stamp: 'stephaneducasse 8/16/2010 23:21'!compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" | binding | oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. "Ensure that we share a common binding after recompilation. This is so that ClassBuilder reshapes avoid creating new bindings for every method when recompiling a large class hierarchy." binding := self binding. self methodsDo: [:m| m methodClassAssociation == binding ifFalse: [m methodClassAssociation: binding ]].! !!Behavior methodsFor: 'compiling'!decompile: selector "Find the compiled code associated with the argument, selector, as a message selector in the receiver's method dictionary and decompile it. Answer the resulting source code as a string. Create an error notification if the selector is not in the receiver's method dictionary." ^self decompilerClass new decompile: selector in: self! !!Behavior methodsFor: 'compiling'!defaultMethodTrailer ^ CompiledMethodTrailer empty! !!Behavior methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:50'!instVarNamesAndOffsetsDo: aBinaryBlock "This is part of the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the instance variable name strings and their integer offsets. The order is important. Names evaluated later will override the same names occurring earlier." "Nothing to do here; ClassDescription introduces named instance variables" ^self! !!Behavior methodsFor: 'compiling'!recompile: selector "Compile the method associated with selector in the receiver's method dictionary." ^self recompile: selector from: self! !!Behavior methodsFor: 'compiling'!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 basicAddSelector: selector withMethod: (methodNode generate: trailer).! !!Behavior methodsFor: 'compiling'!recompileChanges "Compile all the methods that are in the changes file. This validates sourceCode and variable references and forces methods to use the current bytecode set" self selectorsAndMethodsDo: [:sel :meth | meth fileIndex > 1 ifTrue: [self recompile: sel from: self]]! !!Behavior methodsFor: 'compiling'!recompileNonResidentMethod: method atSelector: selector from: oldClass "Recompile the method supplied in the context of this class." | trailer methodNode | trailer := method trailer. methodNode := self compilerClass new compile: (method getSourceFor: selector in: oldClass) in: self notifying: nil ifFail: ["We're in deep doo-doo if this fails (syntax error). Presumably the user will correct something and proceed, thus installing the result in this methodDict. We must retrieve that new method, and restore the original (or remove) and then return the method we retrieved." ^ self error: 'see comment']. selector == methodNode selector ifFalse: [self error: 'selector changed!!']. ^ methodNode generate: trailer! !!Behavior methodsFor: 'compiling' stamp: 'eem 6/19/2008 09:08'!variablesAndOffsetsDo: aBinaryBlock "This is the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed by the instance variable name strings and their integer offsets (1-relative). The order is important; names evaluated later will override the same names occurring earlier." "Only need to do instance variables here. CProtoObject introduces field definitions." self instVarNamesAndOffsetsDo: aBinaryBlock! !!Behavior methodsFor: 'copying'!copyOfMethodDictionary "Return a copy of the receiver's method dictionary" ^ self methodDict copy! !!Behavior methodsFor: 'copying'!deepCopy "Classes should only be shallowCopied or made anew." ^ self shallowCopy! !!Behavior methodsFor: 'copying'!postCopy super postCopy. self methodDictionary: self copyOfMethodDictionary! !!Behavior methodsFor: 'enumerating' stamp: 'nice 11/14/2009 19:22'!allInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver. Because aBlock might change the class of inst (for example, using become:), it is essential to compute next before aBlock value: inst." | inst next | inst := self someInstance. [inst == nil] whileFalse: [ next := inst nextInstance. aBlock value: inst. inst := next]! !!Behavior methodsFor: 'enumerating' stamp: 'di 6/20/97 10:50'!allSubInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver and all its subclasses." self allInstancesDo: aBlock. self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! !!Behavior methodsFor: 'enumerating'!allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclassesDo: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! !!Behavior methodsFor: 'enumerating'!allSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." superclass == nil ifFalse: [aBlock value: superclass. superclass allSuperclassesDo: aBlock]! !!Behavior methodsFor: 'enumerating' stamp: 'marcus.denker 9/29/2008 15:17'!allUnreferencedInstanceVariables "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" ^ self allInstVarNames reject: [:ivn | | definingClass | definingClass := self classThatDefinesInstanceVariable: ivn. definingClass withAllSubclasses anySatisfy: [:class | (class whichSelectorsAccess: ivn asSymbol) notEmpty]]! !!Behavior methodsFor: 'enumerating'!selectSubclasses: aBlock "Evaluate the argument, aBlock, with each of the receiver's (next level) subclasses as its argument. Collect into a Set only those subclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the subclasses of each of these successful subclasses and collect into the set those for which aBlock evaluates true. Answer the resulting set." | aSet | aSet := Set new. self allSubclasses do: [:aSubclass | (aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]]. ^aSet! !!Behavior methodsFor: 'enumerating'!selectSuperclasses: aBlock "Evaluate the argument, aBlock, with the receiver's superclasses as the argument. Collect into an OrderedCollection only those superclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the superclasses of each of these successful superclasses and collect into the OrderedCollection ones for which aBlock evaluates to true. Answer the resulting OrderedCollection." | aSet | aSet := Set new. self allSuperclasses do: [:aSuperclass | (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. ^aSet! !!Behavior methodsFor: 'enumerating' stamp: 'AdrianKuhn 12/22/2009 08:07'!subclassesDo: aBlock self subclasses do: aBlock! !!Behavior methodsFor: 'enumerating'!withAllSubclassesDo: aBlock "Evaluate the argument, aBlock, for the receiver and each of its subclasses." aBlock value: self. self allSubclassesDo: aBlock! !!Behavior methodsFor: 'enumerating' stamp: 'StephaneDucasse 2/13/2010 15:34'!withAllSuperAndSubclassesDo: aBlock self allSuperclassesDo: aBlock. aBlock value: self. self allSubclassesDo: aBlock! !!Behavior methodsFor: 'enumerating' stamp: 'ar 7/11/1999 04:21'!withAllSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." aBlock value: self. superclass == nil ifFalse: [superclass withAllSuperclassesDo: aBlock]! !!Behavior methodsFor: 'initialize-release'!emptyMethodDictionary ^ MethodDictionary new! !!Behavior methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:43'!initialize "moved here from the class side's #new" super initialize. superclass := Object. "no longer sending any messages, some of them crash the VM" methodDict := self emptyMethodDictionary. format := Object format! !!Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07'!nonObsoleteClass "Attempt to find and return the current version of this obsolete class" | obsName | obsName := self name. [obsName beginsWith: 'AnObsolete'] whileTrue: [obsName := obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. ^ self environment at: obsName asSymbol! !!Behavior methodsFor: 'initialize-release'!obsolete "Invalidate and recycle local methods, e.g., zap the method dictionary if can be done safely." self canZapMethodDictionary ifTrue: [self methodDict: self emptyMethodDictionary]. self hasTraitComposition ifTrue: [ self traitComposition traits do: [:each | each removeUser: self]]! !!Behavior methodsFor: 'initialize-release' stamp: 'al 12/12/2003 20:59'!superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver. Must only be sent to a new instance; else we would need Object flushCache." superclass := aClass. format := fmt. methodDict := mDict. self traitComposition: nil! !!Behavior methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/18/2009 12:00'!basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." <primitive: 70> self isVariable ifTrue: [ ^ self basicNew: 0 ]. "space must be low" OutOfMemory signal. ^ self basicNew "retry if user proceeds"! !!Behavior methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/18/2009 12:00'!basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." <primitive: 71> self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: ["arg okay; space must be low." OutOfMemory signal. ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! !!Behavior methodsFor: 'instance creation'!new ^ self basicNew initialize! !!Behavior methodsFor: 'instance creation' stamp: 'sd 5/20/2004 11:20'!new: sizeRequested "Answer an initialized instance of this class with the number of indexable variables specified by the argument, sizeRequested." ^ (self basicNew: sizeRequested) initialize ! !!Behavior methodsFor: 'memory usage' stamp: 'MarianoMartinezPeck 10/1/2010 13:21'!instancesSizeInMemory "Answers the number of bytes consumed by all its instancec including their object header" | bytes | bytes := 0. self allInstancesDo: [:each | bytes := bytes + each sizeInMemory ]. ^ bytes! !!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:13'!addObsoleteSubclass: aClass "Weakly remember that aClass was a subclass of the receiver and is now obsolete" | obs | obs := ObsoleteSubclasses at: self ifAbsent:[WeakArray new]. (obs includes: aClass) ifTrue:[^self]. obs := obs copyWithout: nil. obs := obs copyWith: aClass. ObsoleteSubclasses at: self put: obs.! !!Behavior methodsFor: 'obsolete subclasses' stamp: 'JB 2/19/2010 16:00'!allLocalCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." ^(SystemNavigation default allLocalCallsOn: aSymbol ofClass: (self theNonMetaClass)).! !!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:20'!obsoleteSubclasses "Return all the weakly remembered obsolete subclasses of the receiver" | obs | obs := ObsoleteSubclasses at: self ifAbsent: [^ #()]. ^ obs copyWithout: nil! !!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:21'!removeAllObsoleteSubclasses "Remove all the obsolete subclasses of the receiver" ObsoleteSubclasses removeKey: self ifAbsent: [].! !!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:22'!removeObsoleteSubclass: aClass "Remove aClass from the weakly remembered obsolete subclasses" | obs | obs := ObsoleteSubclasses at: self ifAbsent:[^ self]. (obs includes: aClass) ifFalse:[^self]. obs := obs copyWithout: aClass. obs := obs copyWithout: nil. ObsoleteSubclasses at: self put: obs! !!Behavior methodsFor: 'printing'!literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key := scannedLiteral key. value := scannedLiteral value. key isNil ifTrue: "###<metaclass soleInstance name>" [(self bindingOf: value) ifNotNil:[:assoc| (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isSymbol) ifTrue: "##<global var name>" [(self bindingOf: key) ifNotNil:[:assoc | ^assoc]. Undeclared at: key put: nil. ^Undeclared bindingOf: key]. requestor notify: '## must be followed by a non-local variable name'. ^false" Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class"! !!Behavior methodsFor: 'printing'!longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." aStream nextPutAll: '<<too complex to show>>'; cr.! !!Behavior methodsFor: 'printing'!prettyPrinterClass ^ PrettyPrinting prettyPrinterClassFor: self! !!Behavior methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:11'!printHierarchy "Answer a description containing the names and instance variable names of all of the subclasses and superclasses of the receiver." | aStream index | index := 0. aStream := (String new: 16) writeStream. self allSuperclasses reverseDo: [:aClass | aStream crtab: index. index := index + 1. aStream nextPutAll: aClass name. aStream space. aStream print: aClass instVarNames]. aStream cr. self printSubclassesOn: aStream level: index. ^aStream contents! !!Behavior methodsFor: 'printing'!printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. superclass printOn: aStream! !!Behavior methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'!printWithClosureAnalysisOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. superclass printWithClosureAnalysisOn: aStream! !!Behavior methodsFor: 'printing'!storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isVariableBinding) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key := aCodeLiteral key. (key isNil and: [(value := aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. (key isSymbol and: [(self bindingOf: key) notNil]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream! !!Behavior methodsFor: 'queries' stamp: 'StephaneDucasse 5/15/2011 17:21'!copiedFromSuperclass: method "Returns the methods that the receiver copied with its ancestors" self allSuperclassesDo: [ :cls| (cls includesSelector: method selector) ifTrue: [ ((cls >> method selector) getSource = method getSource) ifTrue: [ ^ {cls >> method selector}] ifFalse: [ ^ #()]]]. ^ #(). ! !!Behavior methodsFor: 'queries' stamp: 'StephaneDucasse 5/15/2011 17:21'!copiedMethodsFromSuperclass "Returns the methods that the receiver copied with its ancestors" | methods | methods := OrderedCollection new. self methodDict valuesDo: [ :method| methods addAll: (self copiedFromSuperclass: method)]. ^ methods! !!Behavior methodsFor: 'queries' stamp: 'StephaneDucasse 5/15/2011 17:20'!copiesFromSuperclass: method "Checks whether the receiver copied the argument, method, from its superclasses" self allSuperclassesDo: [ :cls| (cls includesSelector: method selector) ifTrue: [ ^ (cls >> method selector) getSource = method getSource]]. ^ false! !!Behavior methodsFor: 'queries' stamp: 'StephaneDucasse 5/15/2011 17:20'!copiesMethodsFromSuperclass "Checks whether the receiver copied some method from its superclass" self methodDict valuesDo: [ :method| (self copiesFromSuperclass: method) ifTrue: [ ^ true ]]. ^ false! !!Behavior methodsFor: 'queries' stamp: 'StephaneDucasse 12/5/2009 11:51'!whichClassDefinesClassVar: aString Symbol hasInterned: aString ifTrue: [ :aSymbol | ^self whichSuperclassSatisfies: [:aClass | aClass classVarNames anySatisfy: [:each | each = aSymbol]]]. ^#()! !!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'!whichClassDefinesInstVar: aString ^self whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! !!Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:51'!whichSelectorsAssign: instVarName "Answer a Set of selectors whose methods store into the argument, instVarName, as a named instance variable." ^self whichSelectorsStoreInto: instVarName! !!Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:52'!whichSelectorsRead: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." ^self whichSelectorsAccess: instVarName! !!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'!whichSuperclassSatisfies: aBlock (aBlock value: self) ifTrue: [^self]. ^superclass isNil ifTrue: [nil] ifFalse: [superclass whichSuperclassSatisfies: aBlock]! !!Behavior methodsFor: 'system startup'!shutDown ^ self! !!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'!shutDown: quitting "This message is sent on system shutdown to registered classes" ^self shutDown.! !!Behavior methodsFor: 'system startup'!startUp ^ self! !!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'!startUp: resuming "This message is sent to registered classes when the system is coming up." ^self startUp! !!Behavior methodsFor: 'testing'!canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" ^true! !!Behavior methodsFor: 'testing'!instSize "Answer the number of named instance variables (as opposed to indexed variables) of the receiver." self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange"" NOTE: This code supports the backward-compatible extension to 8 bits of instSize. When we revise the image format, it should become... ^ ((format bitShift: -1) bitAnd: 16rFF) - 1 Note also that every other method in this category will require 2 bits more of right shift after the change." ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! !!Behavior methodsFor: 'testing'!instSpec ^ (format bitShift: -7) bitAnd: 16rF! !!Behavior methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'!isBehavior "Return true if the receiver is a behavior" ^true! !!Behavior methodsFor: 'testing'!isBits "Answer whether the receiver contains just bits (not pointers)." ^ self instSpec >= 6! !!Behavior methodsFor: 'testing'!isBytes "Answer whether the receiver has 8-bit instance variables." ^ self instSpec >= 8! !!Behavior methodsFor: 'testing'!isFixed "Answer whether the receiver does not have a variable (indexable) part." ^self isVariable not! !!Behavior methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:57'!isMeta ^ false! !!Behavior methodsFor: 'testing' stamp: 'ar 7/14/1999 02:38'!isObsolete "Return true if the receiver is obsolete." ^self instanceCount = 0! !!Behavior methodsFor: 'testing'!isPointers "Answer whether the receiver contains just pointers (not bits)." ^self isBits not! !!Behavior methodsFor: 'testing'!isVariable "Answer whether the receiver has indexable variables." ^ self instSpec >= 2! !!Behavior methodsFor: 'testing' stamp: 'ar 3/21/98 02:36'!isWeak "Answer whether the receiver has contains weak references." ^ self instSpec = 4! !!Behavior methodsFor: 'testing' stamp: 'MarcusDenker 11/4/2010 13:37'!isWords "Answer true if the receiver is made of 32-bit instance variables." ^self isBytes not! !!Behavior methodsFor: 'testing' stamp: 'StephaneDucasse 3/20/2010 23:17'!shouldNotBeRedefined "Return true if the receiver should not be redefined. The assumption is that compact classes, classes in Smalltalk specialObjects and Behaviors should not be redefined" ^(Smalltalk compactClassesArray includes: self) or:[(Smalltalk specialObjectsArray includes: self) or: [self isKindOf: self]]! !!Behavior methodsFor: 'testing class hierarchy' stamp: 'ar 3/12/98 12:36'!includesBehavior: aClass ^self == aClass or:[self inheritsFrom: aClass]! !!Behavior methodsFor: 'testing class hierarchy'!inheritsFrom: aClass "Answer whether the argument, aClass, is on the receiver's superclass chain." | aSuperclass | aSuperclass := superclass. [aSuperclass == nil] whileFalse: [aSuperclass == aClass ifTrue: [^true]. aSuperclass := aSuperclass superclass]. ^false! !!Behavior methodsFor: 'testing class hierarchy'!kindOfSubclass "Answer a String that is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, a variableWordSubclass, or a weakSubclass." self isWeak ifTrue: [^ ' weakSubclass: ']. ^ self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [ ' variableByteSubclass: '] ifFalse: [ ' variableWordSubclass: ']] ifFalse: [ ' variableSubclass: ']] ifFalse: [ ' subclass: ']! !!Behavior methodsFor: 'testing method dictionary' stamp: 'al 2/29/2004 14:18'!bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^superclass bindingOf: varName! !!Behavior methodsFor: 'testing method dictionary' stamp: 'sd 5/7/2006 09:58'!canPerform: selector "Answer whether the receiver can safely perform to the message whose selector is the argument: it is not an abstract or cancelled method" ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! !!Behavior methodsFor: 'testing method dictionary'!canUnderstand: selector "Answer whether the receiver can respond to the message whose selector is the argument. The selector can be in the method dictionary of the receiver's class or any of its superclasses." (self includesSelector: selector) ifTrue: [^true]. superclass == nil ifTrue: [^false]. ^superclass canUnderstand: selector! !!Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/18/2003 18:13'!classBindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver's class" ^self bindingOf: varName! !!Behavior methodsFor: 'testing method dictionary'!hasMethods "Answer whether the receiver has any methods in its method dictionary." ^ self methodDict notEmpty! !!Behavior methodsFor: 'testing method dictionary'!includesLocalSelector: aSymbol ^self basicLocalSelectors isNil ifTrue: [self includesSelector: aSymbol] ifFalse: [self localSelectors includes: aSymbol]! !!Behavior methodsFor: 'testing method dictionary'!includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class." ^ self methodDict includesKey: aSymbol! !!Behavior methodsFor: 'testing method dictionary' stamp: 'StephaneDucasse 4/27/2010 11:48'!isAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my or in another composition somewhere deeper in the tree of traits compositions." ^(self includesLocalSelector: aSymbol) not and: [(self hasTraitComposition) and: [self traitComposition isAliasSelector: aSymbol]]! !!Behavior methodsFor: 'testing method dictionary'!isDisabledSelector: selector ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! !!Behavior methodsFor: 'testing method dictionary'!isLocalAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my trait composition." ^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition and: [self traitComposition isLocalAliasSelector: aSymbol]]! !!Behavior methodsFor: 'testing method dictionary'!thoroughHasSelectorReferringTo: literal special: specialFlag byte: specialByte "Answer true if any of my methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough " self methodsDo: [ :method | ((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [^true]]. ^false! !!Behavior methodsFor: 'testing method dictionary' stamp: 'G.C 10/22/2008 09:59'!thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough " | selectors | selectors := IdentitySet new. self selectorsAndMethodsDo: [ :sel :method | ((method refersToLiteral: literal) or: [ specialFlag and: [ method scanFor: specialByte ] ]) ifTrue: [ selectors add: sel ] ]. ^ selectors! !!Behavior methodsFor: 'testing method dictionary'!whichClassIncludesSelector: aSymbol "Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found. Answer nil if none found." "Rectangle whichClassIncludesSelector: #inspect." (self includesSelector: aSymbol) ifTrue: [^ self]. superclass == nil ifTrue: [^ nil]. ^ superclass whichClassIncludesSelector: aSymbol! !!Behavior methodsFor: 'testing method dictionary' stamp: 'MarcusDenker 2/21/2010 12:50'!whichSelectorsAccess: instVarName "Answer a set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. ^ self selectors select: [:sel | ((self methodDict at: sel) readsField: instVarIndex) or: [(self methodDict at: sel) writesField: instVarIndex]] "Point whichSelectorsAccess: 'x'."! !!Behavior methodsFor: 'testing method dictionary'!whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as aliteral." | special byte | special := Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:b |byte := b]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! !!Behavior methodsFor: 'testing method dictionary'!whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal." | who | who := IdentitySet new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method literals allButLast includes: literal]) ifTrue: [who add: sel]]]. ^ who! !!Behavior methodsFor: 'testing method dictionary' stamp: 'MarcusDenker 2/21/2010 12:51'!whichSelectorsStoreInto: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. ^ self selectors select: [:sel | (self methodDict at: sel) writesField: instVarIndex] "Point whichSelectorsStoreInto: 'x'."! !!Behavior methodsFor: 'traits'!addExclusionOf: aSymbol to: aTrait self setTraitComposition: ( self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! !!Behavior methodsFor: 'traits'!addToComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression add: aTrait; yourself)! !!Behavior methodsFor: 'traits'!addTraitSelector: aSymbol withMethod: aCompiledMethod "Add aMethod with selector aSymbol to my methodDict. aMethod must not be defined locally." | source methodAndNode | [(self includesLocalSelector: aSymbol) not] assert. self ensureLocalSelectors. source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. methodAndNode := self compile: source classified: nil notifying: nil trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: source fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. self basicAddSelector: aSymbol withMethod: methodAndNode method! !!Behavior methodsFor: 'traits'!applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors := self traitComposition changedSelectorsComparedTo: oldComposition. changedSelectors isEmpty ifFalse: [ self noteChangedSelectors: changedSelectors]. self traitComposition isEmpty ifTrue: [ self purgeLocalSelectors]. ^changedSelectors! !!Behavior methodsFor: 'traits' stamp: 'dvf 9/9/2005 19:45'!classesComposedWithMe ^{self}! !!Behavior methodsFor: 'traits'!ensureLocalSelectors "Ensures that the instance variable localSelectors is effectively used to maintain the set of local selectors. This method must be called before any non-local selectors are added to the method dictionary!!" self basicLocalSelectors isNil ifTrue: [self basicLocalSelectors: self selectors asSet]! !!Behavior methodsFor: 'traits' stamp: 'jannik.laval 5/1/2010 15:53'!flattenDown: aTrait | selectors | [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]] assert. selectors := (self traitComposition transformationOfTrait: aTrait) selectors. self basicLocalSelectors: self basicLocalSelectors , selectors. self removeFromComposition: aTrait.! !!Behavior methodsFor: 'traits' stamp: 'jannik.laval 5/1/2010 15:53'!flattenDownAllTraits self traitComposition allTraits do: [:each | self flattenDown: each]. [ self traitComposition isEmpty ] assert. self traitComposition: nil.! !!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'!hasTraitComposition self subclassResponsibility ! !!Behavior methodsFor: 'traits'!noteChangedSelectors: aCollection "Start update of my methodDict (after changes to traits in traitComposition or after a local method was removed from my methodDict). The argument is a collection of method selectors that may have been changed. Most of the time aCollection only holds one selector. But when there are aliases involved there may be several method changes that have to be propagated to users." | affectedSelectors | affectedSelectors := IdentitySet new. aCollection do: [:selector | affectedSelectors addAll: (self updateMethodDictionarySelector: selector)]. self notifyUsersOfChangedSelectors: affectedSelectors. ^ affectedSelectors! !!Behavior methodsFor: 'traits'!notifyUsersOfChangedSelector: aSelector self notifyUsersOfChangedSelectors: (Array with: aSelector)! !!Behavior methodsFor: 'traits'!notifyUsersOfChangedSelectors: aCollection! !!Behavior methodsFor: 'traits'!purgeLocalSelectors self basicLocalSelectors: nil! !!Behavior methodsFor: 'traits'!removeAlias: aSymbol of: aTrait self setTraitComposition: ( self traitComposition copyWithoutAlias: aSymbol of: aTrait)! !!Behavior methodsFor: 'traits'!removeFromComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression removeFromComposition: aTrait)! !!Behavior methodsFor: 'traits' stamp: 'jannik.laval 5/1/2010 15:53'!removeTraitSelector: aSymbol [(self includesLocalSelector: aSymbol) not] assert. self basicRemoveSelector: aSymbol! !!Behavior methodsFor: 'traits'!setTraitComposition: aTraitComposition | oldComposition | (self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self]. aTraitComposition assertValidUser: self. oldComposition := self traitComposition. self traitComposition: aTraitComposition. self applyChangesOfNewTraitCompositionReplacing: oldComposition. oldComposition traits do: [:each | each removeUser: self]. aTraitComposition traits do: [:each | each addUser: self]! !!Behavior methodsFor: 'traits'!setTraitCompositionFrom: aTraitExpression ^ self setTraitComposition: aTraitExpression asTraitComposition! !!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:36'!traitComposition self subclassResponsibility! !!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'!traitComposition: aTraitComposition self subclassResponsibility ! !!Behavior methodsFor: 'traits'!traitCompositionIncludes: aTrait ^self == aTrait or: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]! !!Behavior methodsFor: 'traits'!traitCompositionString ^self hasTraitComposition ifTrue: [self traitComposition asString] ifFalse: ['{}']! !!Behavior methodsFor: 'traits'!traitOrClassOfSelector: aSymbol "Return the trait or the class which originally defines the method aSymbol or return self if locally defined or if it is a conflict marker method. This is primarly used by Debugger to determin the behavior in which a recompiled method should be put. If a conflict method is recompiled it should be put into the class, thus return self. Also see TraitComposition>>traitProvidingSelector:" ((self includesLocalSelector: aSymbol) or: [ self hasTraitComposition not]) ifTrue: [^self]. ^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]! !!Behavior methodsFor: 'traits'!traitTransformations ^ self traitComposition transformations ! !!Behavior methodsFor: 'traits'!traits "Returns a collection of all traits used by the receiver" ^ self traitComposition traits! !!Behavior methodsFor: 'traits'!traitsProvidingSelector: aSymbol | result | result := OrderedCollection new. self hasTraitComposition ifFalse: [^result]. (self traitComposition methodDescriptionsForSelector: aSymbol) do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [ result addAll: (methodDescription locatedMethods collect: [:each | each location])]]. ^result! !!Behavior methodsFor: 'traits' stamp: 'nice 1/5/2010 15:59'!updateMethodDictionarySelector: aSymbol "A method with selector aSymbol in myself or my traitComposition has been changed. Do the appropriate update to my methodDict (remove or update method) and return all affected selectors of me so that my useres get notified." | modifiedSelectors descriptions | modifiedSelectors := IdentitySet new. descriptions := self hasTraitComposition ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ] ifFalse: [ #() ]. descriptions do: [:methodDescription | | effectiveMethod selector | selector := methodDescription selector. (self includesLocalSelector: selector) ifFalse: [ methodDescription isEmpty ifTrue: [ self removeTraitSelector: selector. modifiedSelectors add: selector] ifFalse: [ effectiveMethod := methodDescription effectiveMethod. self addTraitSelector: selector withMethod: effectiveMethod. modifiedSelectors add: selector]]]. ^modifiedSelectors! !!Behavior methodsFor: 'user interface' stamp: 'marcus.denker 9/29/2008 13:01'!unreferencedInstanceVariables "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses." ^ self instVarNames reject: [:ivn | self withAllSubclasses anySatisfy: [:class | (class whichSelectorsAccess: ivn) notEmpty]]! !!Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'!withAllSubAndSuperclassesDo: aBlock self withAllSubclassesDo: aBlock. self allSuperclassesDo: aBlock.! !!Behavior methodsFor: 'private' stamp: 'VeronicaUquillas 6/11/2010 12:46'!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 Pharo's method cache, either by selector or by method" oldMethod flushCache. selector flushCache! !!Behavior methodsFor: 'private' stamp: 'VeronicaUquillas 6/11/2010 12:45'!becomeCompact "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Pharo, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct index | self isWeak ifTrue: [^ self halt: 'You must not make a weak class compact']. cct := Smalltalk compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. index := cct indexOf: nil ifAbsent: [^ self halt: 'compact class table is full']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format := format + (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Purge any old instances" Smalltalk garbageCollect.! !!Behavior methodsFor: 'private' stamp: 'VeronicaUquillas 6/11/2010 12:45'!becomeCompactSimplyAt: index "Make me compact, but don't update the instances. For importing segments.""Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Pharo, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct | self isWeak ifTrue: [^ self halt: 'You must not make a weak class compact']. cct := Smalltalk compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format := format + (index bitShift: 11). "Caller must convert the instances"! !!Behavior methodsFor: 'private' stamp: 'StephaneDucasse 3/21/2010 12:29'!becomeUncompact | cct index | cct := Smalltalk compactClassesArray. (index := self indexIfCompact) = 0 ifTrue: [^ self]. (cct includes: self) ifFalse: [^ self halt "inconsistent state"]. "Update instspec so future instances will not be compact" format := format - (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" cct at: index put: nil.! !!Behavior methodsFor: 'private'!flushCache "Tell the interpreter to remove the contents of its method lookup cache, if it has one. Essential. See Object documentation whatIsAPrimitive." <primitive: 89> self primitiveFailed! !!Behavior methodsFor: 'private' stamp: 'StephaneDucasse 3/12/2011 15:39'!indexIfCompact "If these 5 bits are non-zero, then instances of this class will be compact. It is crucial that there be an entry in Smalltalk compactClassesArray for any class so optimized. See the msgs becomeCompact and becomeUncompact." ^ (format bitShift: -11) bitAnd: 16r1F"Array indexIfCompactVerify if the compactClassesArray and indexIfCompact are coherenSmalltalk compactClassesArray doWithIndex: [:c :i | c == nil ifFalse: [c indexIfCompact = i ifFalse: [self halt]]]"! !!Behavior methodsFor: 'private' stamp: 'MarianoMartinezPeck 1/8/2010 14:52'!manageMDFault"This method is to manage MethodDictionary faults. In this default implementation we just raise an error but maybe it is useful for external packages to override this behavior. For example, ClaseUseDiscovery can override this to recover from a MDFault." self error: 'There was a method dictionary is nil'! !!Behavior methodsFor: 'private' stamp: 'sd 11/19/2004 15:13'!setFormat: aFormatInstanceDescription "only use this method with extreme care since it modifies the format of the class ie a description of the number of instance variables and whether the class is compact, variable sized" format := aFormatInstanceDescription! !!Behavior methodsFor: 'private'!spaceUsed "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." | space | space := 0. self methodsDo: [:method | space := space + 16. "dict and org'n space" space := space + (method size + 6 "hdr + avg pad"). method literalsDo: [:lit | (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)]. (lit isMemberOf: Float) ifTrue: [space := space + 12]. (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)]. (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)]. (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]]. ^ space! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!Behavior class uses: TPureBehavior classTrait instanceVariableNames: ''!!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:23'!flushObsoleteSubclasses "Behavior flushObsoleteSubclasses" ObsoleteSubclasses finalizeValues.! !!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:51'!initialize "Behavior initialize" "Never called for real" ObsoleteSubclasses ifNil: [self initializeObsoleteSubclasses] ifNotNil: [| newDict | newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses. newDict rehash. ObsoleteSubclasses := newDict]! !!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:46'!initializeObsoleteSubclasses ObsoleteSubclasses := WeakKeyToCollectionDictionary new.! !!Behavior class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:08'!cleanUp "Flush the obsolete subclasses." self flushObsoleteSubclasses! !!Behavior class methodsFor: 'testing' stamp: 'dvf 9/27/2005 16:12'!canZapMethodDictionary "Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail." ^false! ! Behavior subclass: #ClassDescription uses: TClassAndTraitDescription instanceVariableNames: 'instanceVariables organization' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!ClassDescription commentStamp: '<historical>' prior: 0!I add a number of facilities to basic Behaviors: Named instance variables Category organization for methods The notion of a name of this class (implemented as subclass responsibility) The maintenance of a ChangeSet, and logging changes on a file Most of the mechanism for fileOut. I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).!!ClassDescription methodsFor: '*System-Support'!allUnreferencedClassVariables "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" ^ self systemNavigation allUnreferencedClassVariablesOf: self! !!ClassDescription methodsFor: '*deprecated12'!addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." self subclassResponsibility! !!ClassDescription methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 10:38'!chooseClassVarName "Present the user with a list of class variable names and answer the one selected, or nil if none" | lines labelStream allVars index | self deprecated: 'This code should be moved in the browser or tool abstraction'. lines := OrderedCollection new. allVars := OrderedCollection new. labelStream := (String new: 200) writeStream. self withAllSuperclasses reverseDo: [:class | | vars | vars := class classVarNames. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines). index = 0 ifTrue: [^ nil]. ^ allVars at: index! !!ClassDescription methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 10:45'!chooseInstVarAlphabeticallyThenDo: aBlock self deprecated: 'use SystemNavigation chooseInstVarAlphabeticallyFrom: aClass thenDo: aBlock instead' on: '27 August 2010' in: 'Pharo1.2'. SystemNavigation default chooseInstVarAlphabeticallyFrom: self thenDo: aBlock! !!ClassDescription methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 10:45'!chooseInstVarThenDo: aBlock "Put up a menu of all the instance variables in the receiver, and whenthe user chooses one, evaluate aBlock with the chosen variable as itsparameter. If the list is 6 or larger, then offer an alphabeticalformulation as an alternative. triggered by a 'show alphabetically' itemat the top of the list." self deprecated: 'use SystemNavigation chooseInstVarFrom: aClass thenDo: aBlock instead' on: '27 August 2010' in: 'Pharo1.2'. SystemNavigation default chooseInstVarFrom: self thenDo: aBlock ! !!ClassDescription methodsFor: '*deprecated12'!removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables. Create an error notification if the argument is not found." self subclassResponsibility! !!ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 23:57'!classVersion "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" "This method allows you to distinguish between class versions when the shape of the class hasn't changed (when there's no change in the instVar names). In the conversion methods you usually can tell by the inst var names what old version you have. In a few cases, though, the same inst var names were kept but their interpretation changed (like in the layoutFrame). By changing the class version when you keep the same instVars you can warn older and newer images that they have to convert." ^ 0! !!ClassDescription methodsFor: 'accessing' stamp: 'StephaneDucasse 5/1/2010 16:12'!numberOfLinesOfCode "Return the number of lines of code" | str | str := String new writeStream. Object fileOutOn: str. ^ str contents lineCount! !!ClassDescription methodsFor: 'accessing' stamp: 'Alexandre Bergel 4/27/2010 14:08'!version "Allows polymorphism with TraitDescription>>version" ^ self classVersion! !!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 2/17/2000 22:36'!classesThatImplementAllOf: selectorSet "Return an array of any classes that implement all the messages in selectorSet." | found remaining | found := OrderedCollection new. selectorSet do: [:sel | (self methodDict includesKey: sel) ifTrue: [found add: sel]]. found isEmpty ifTrue: [^ self subclasses inject: Array new into: [:subsThatDo :sub | subsThatDo , (sub classesThatImplementAllOf: selectorSet)]] ifFalse: [remaining := selectorSet copyWithoutAll: found. remaining isEmpty ifTrue: [^ Array with: self]. ^ self subclasses inject: Array new into: [:subsThatDo :sub | subsThatDo , (sub classesThatImplementAllOf: remaining)]]! !!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'StephaneDucasse 10/6/2010 19:46'!commentInventory "Answer a string with a count of the classes with and without comments for all the classes in the package of which this class is a member." "Morph commentInventory" ^ self environment organization commentInventory: (self category copyUpTo: $-), '*'! !!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:51'!printSubclassesOn: aStream level: level "As part of the algorithm for printing a description of the receiver, print the subclass on the file stream, aStream, indenting level times." | subclassNames | aStream crtab: level. aStream nextPutAll: self name. aStream space; print: self instVarNames. self == Class ifTrue: [aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'. ^self]. subclassNames := self subclasses asSortedCollection:[:c1 :c2| c1 name <= c2 name]. "Print subclasses in alphabetical order" subclassNames do: [:subclass | subclass printSubclassesOn: aStream level: level + 1]! !!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'!subclasses ^ Array new! !!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'!subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." ^self subclasses do: aBlock! !!ClassDescription methodsFor: 'accessing comment' stamp: 'PeterHugossonMiller 9/3/2009 00:54'!classCommentBlank | existingComment stream | existingComment := self theNonMetaClass organization classComment. existingComment isEmpty ifFalse: [^existingComment]. stream := (String new: 100) writeStream. stream nextPutAll: 'A'; nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']); nextPutAll: self name; nextPutAll: ' is xxxxxxxxx.'; cr; cr; nextPutAll: 'Instance Variables'. self instVarNames asSortedCollection do: [:each | stream cr; tab; nextPutAll: each; nextPut: $:; tab; tab; nextPutAll: '<Object>']. stream cr. self instVarNames asSortedCollection do: [:each | stream cr; nextPutAll: each; cr; tab; nextPutAll: '- xxxxx'; cr]. ^stream contents! !!ClassDescription methodsFor: 'accessing comment'!comment "Answer the receiver's comment. (If missing, supply a template) " | aString | aString := self instanceSide organization classComment. aString isEmpty ifFalse: [^ aString]. ^self classCommentBlank! !!ClassDescription methodsFor: 'accessing comment'!comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self instanceSide classComment: aStringOrText.! !!ClassDescription methodsFor: 'accessing comment'!comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self instanceSide classComment: aStringOrText stamp: aStamp.! !!ClassDescription methodsFor: 'accessing comment'!hasComment "return whether this class truly has a comment other than the default" | org | org := self instanceSide organization. ^org classComment isEmptyOrNil not! !!ClassDescription methodsFor: 'accessing method dictionary'!addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor | priorMethodOrNil oldProtocol newProtocol | priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. oldProtocol := self organization categoryOfElement: selector. SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category]. newProtocol := self organization categoryOfElement: selector. 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 oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor].! !!ClassDescription methodsFor: 'accessing method dictionary'!addSelectorSilently: selector withMethod: compiledMethod super addSelectorSilently: selector withMethod: compiledMethod. self instanceSide noteAddedSelector: selector meta: self isMeta.! !!ClassDescription methodsFor: 'accessing method dictionary'!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: 'sw 1/5/2001 06:53'!allMethodCategoriesIntegratedThrough: mostGenericClass "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" | aColl | aColl := OrderedCollection new. self withAllSuperclasses do: [:aClass | (aClass includesBehavior: mostGenericClass) ifTrue: [aColl addAll: aClass organization categories]]. aColl remove: 'no messages' asSymbol ifAbsent: []. ^ (aColl asSet asSortedCollection: [:a :b | a asLowercase < b asLowercase]) asArray"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! !!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'MarcusDenker 3/5/2010 14:31'!allMethodsInCategory: aName "Answer a list of all the methods of the receiver and all its superclasses that are in the category named aName" | aColl | aColl := OrderedCollection new. self withAllSuperclasses do: [:aClass | aColl addAll: (aName = ClassOrganizer allCategory ifTrue: [aClass organization allMethodSelectors] ifFalse: [aClass organization listAtCategoryNamed: aName])]. ^ aColl asSet asArray sort! !!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'MarcusDenker 3/5/2010 14:33'!methodsInCategory: aName "Answer a list of the methods of the receiver that are in category named aName" | aColl | aColl := Set withAll: (aName = ClassOrganizer allCategory ifTrue: [self organization allMethodSelectors] ifFalse: [self organization listAtCategoryNamed: aName]). ^ aColl asArray sort! !!ClassDescription methodsFor: 'accessing method dictionary'!noteAddedSelector: aSelector meta: isMeta "A hook allowing some classes to react to adding of certain selectors"! !!ClassDescription methodsFor: 'accessing method dictionary'!removeCategory: aString "Remove each of the messages categorized under aString in the method dictionary of the receiver. Then remove the category aString." | categoryName | categoryName := aString asSymbol. (self organization listAtCategoryNamed: categoryName) do: [:sel | self removeSelector: sel]. self organization removeCategory: categoryName! !!ClassDescription methodsFor: 'accessing method dictionary'!removeSelector: selector "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." | priorMethod priorProtocol | priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil]. priorProtocol := self whichCategoryIncludesSelector: selector. super removeSelector: selector. SystemChangeNotifier uniqueInstance doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil]. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! !!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:03'!classSide ^self theMetaClass! !!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:04'!instanceSide ^ self theNonMetaClass! !!ClassDescription methodsFor: 'accessing parallel hierarchy'!isClassSide ^self == self classSide! !!ClassDescription methodsFor: 'accessing parallel hierarchy'!isInstanceSide ^self isClassSide not! !!ClassDescription methodsFor: 'accessing parallel hierarchy'!isMeta ^self isClassSide! !!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:50'!theMetaClass "Sent to a class or metaclass, always return the metaclass" ^self class! !!ClassDescription methodsFor: 'accessing parallel hierarchy'!theNonMetaClass "Sent to a class or metaclass, always return the class" ^self! !!ClassDescription methodsFor: 'compiling'!acceptsLoggingOfCompilation "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" ^ true! !!ClassDescription methodsFor: 'compiling'!compile: code classified: heading "Compile the argument, code, as source code in the context of the receiver and install the result in the receiver's method dictionary under the classification indicated by the second argument, heading. nil 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 on an object that converts to a string." ^self compile: code classified: heading notifying: nil! !!ClassDescription methodsFor: 'compiling'!compile: text classified: category notifying: requestor | stamp | stamp := self acceptsLoggingOfCompilation ifTrue: [Author changeStamp] ifFalse: [nil]. ^ self compile: text classified: category withStamp: stamp notifying: requestor! !!ClassDescription methodsFor: 'compiling'!compile: text classified: category withStamp: changeStamp notifying: requestor ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! !!ClassDescription methodsFor: 'compiling'!compile: text classified: categorywithStamp: changeStamp notifying: requestor logSource: logSource | methodAndNode | methodAndNode := self compile: text asString classified: categorynotifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. logSource ifTrue: [ " replace 'text' with 'methodAndNode node sourceText' " self logMethodSource: methodAndNode node sourceTextforMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: requestor. ]. self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode method inProtocol: category notifying: requestor. self instanceSide noteCompilationOf: methodAndNode selector meta:self isClassSide. ^ methodAndNode selector! !!ClassDescription methodsFor: 'compiling'!compile: code notifying: requestor "Refer to the comment in Behavior|compile:notifying:." ^self compile: code classified: ClassOrganizer default notifying: requestor! !!ClassDescription methodsFor: 'compiling'!compileSilently: code "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: '' notifying: nil.! !!ClassDescription methodsFor: 'compiling'!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'!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'!doneCompiling "A ClassBuilder has finished the compilation of the receiver. This message is a notification for a class that needs to do some cleanup / reinitialization after it has been recompiled."! !!ClassDescription methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:48'!instVarNamesAndOffsetsDo: aBinaryBlock "This is part of the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the instance variable name strings and their integer offsets. The order is important. Names evaluated later will override the same names occurring earlier." | superInstSize | (superInstSize := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue: [superclass instVarNamesAndOffsetsDo: aBinaryBlock]. 1 to: self instSize - superInstSize do: [:i| aBinaryBlock value: (instanceVariables at: i) value: i + superInstSize]! !!ClassDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 11:51'!moveInstVarNamed: instVarName to: anotherClass after: prevInstVarName "Move the given instance variable to another class." self == anotherClass ifFalse:[ self notify:'Warning:' asText allBold,' moving ', instVarName printString,' from ', self name,' to ', anotherClass name,' will not be recorded in the change set correctly.Proceed to do it anyways.']. ^(ClassBuilder new) moveInstVarNamed: instVarName from: self to: anotherClass after: prevInstVarName! !!ClassDescription methodsFor: 'compiling'!noteCompilationOf: aSelector meta: isMeta "A hook allowing some classes to react to recompilation of certain selectors"! !!ClassDescription methodsFor: 'compiling'!reformatAll "Reformat all methods in this class. Leaves old code accessible to version browsing" self selectorsDo: [:sel | self reformatMethodAt: sel]! !!ClassDescription methodsFor: 'compiling' stamp: 'alain.plantec 5/18/2009 15:46'!reformatMethodAt: selector | newCodeString method | newCodeString := self prettyPrinterClass format: (self sourceCodeAt: selector) in: self notifying: nil. method := self compiledMethodAt: selector. method putSource: newCodeString fromParseNode: nil class: self category: (self organization categoryOfElement: selector) inFile: 2 priorMethod: method! !!ClassDescription methodsFor: 'compiling'!wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" ^ true! !!ClassDescription methodsFor: 'compiling'!wantsRecompilationProgressReported "Answer whether the receiver would like progress of its recompilation reported interactively to the user." ^ true! !!ClassDescription methodsFor: 'copying'!copy: sel from: class "Install the method associated with the first argument, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under -As yet not classified-." self copy: sel from: class classified: nil! !!ClassDescription methodsFor: 'copying'!copy: sel from: class classified: cat "Install the method associated with the first arugment, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under the third argument, cat." | code category | "Useful when modifying an existing class" code := class sourceMethodAt: sel. code == nil ifFalse: [cat == nil ifTrue: [category := class organization categoryOfElement: sel] ifFalse: [category := cat]. (self methodDict includesKey: sel) ifTrue: [code asString = (self sourceMethodAt: sel) asString ifFalse: [self error: self name , ' ' , sel , ' will be redefined if you proceed.']]. self compile: code classified: category]! !!ClassDescription methodsFor: 'copying'!copyAll: selArray from: class "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under -As yet not classified-." self copyAll: selArray from: class classified: nil! !!ClassDescription methodsFor: 'copying'!copyAll: selArray from: class classified: cat "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under the third argument, cat." selArray do: [:s | (class includesLocalSelector: s) ifTrue: [ self copy: s from: class classified: cat ] ]! !!ClassDescription methodsFor: 'copying'!copyAllCategoriesFrom: aClass "Specify that the categories of messages for the receiver include all of those found in the class, aClass. Install each of the messages found in these categories into the method dictionary of the receiver, classified under the appropriate categories." aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! !!ClassDescription methodsFor: 'copying'!copyCategory: cat from: class "Specify that one of the categories of messages for the receiver is cat, as found in the class, class. Copy each message found in this category." self copyCategory: cat from: class classified: cat! !!ClassDescription methodsFor: 'copying'!copyCategory: cat from: aClass classified: newCat "Specify that one of the categories of messages for the receiver is the third argument, newCat. Copy each message found in the category cat in class aClass into this new category." self copyAll: (aClass organization listAtCategoryNamed: cat) from: aClass classified: newCat! !!ClassDescription methodsFor: 'copying'!copyMethodDictionaryFrom: donorClass "Copy the method dictionary of the donor class over to the receiver" self methodDict: donorClass copyOfMethodDictionary. self organization: donorClass organization deepCopy.! !!ClassDescription methodsFor: 'fileIn/Out'!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 oldComment oldStamp | oldComment := self organization classComment. oldStamp := self organization commentStamp. (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString string oldStamp: oldStamp newStamp: aStamp. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr := self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr isNil) ifTrue: [^ self 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 organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString oldStamp: oldStamp newStamp: aStamp! !!ClassDescription methodsFor: 'fileIn/Out'!fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver's category, aString, onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .sources file, and should only write one preamble per method category." | selectors | aFileStream cr. selectors := (aSymbol asString = ClassOrganizer allCategory) ifTrue: [ self organization allMethodSelectors ] ifFalse: [ self organization listAtCategoryNamed: aSymbol ]. "Overridden to preserve author stamps in sources file regardless" selectors do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]. ^ self! !!ClassDescription methodsFor: 'fileIn/Out'!moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes := self selectors select: [:sel | (self compiledMethodAt: sel) fileIndex > 1 ]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! !!ClassDescription methodsFor: 'filein/out'!classComment: aString "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." ^ self classComment: aString stamp: '<historical>'! !!ClassDescription methodsFor: 'filein/out'!commentStamp: changeStamp self organization commentStamp: changeStamp. ^ self commentStamp: changeStamp prior: 0! !!ClassDescription methodsFor: 'filein/out'!commentStamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCommentReader new setClass: self category: #Comment changeStamp: changeStamp! !!ClassDescription methodsFor: 'filein/out' stamp: 'StephaneDucasse 10/6/2010 19:46'!definition "Answer a String that defines the receiver." | aStream | aStream := (String new: 300) writeStream. superclass == nil ifTrue: [aStream nextPutAll: 'ProtoObject'] ifFalse: [aStream nextPutAll: superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. (self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [ aStream cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString]. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '; store: (self environment organization categoryOfElement: self name) asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass: nil'. ]. ^ aStream contents! !!ClassDescription methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:55'!fileOutCategory: catName | internalStream | internalStream := (String new: 1000) writeStream. internalStream header; timeStamp. self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. internalStream trailer. ^ FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true.! !!ClassDescription methodsFor: 'filein/out'!fileOutChangedMessages: aSet on: aFileStream "File a description of the messages of the receiver that have been changed (i.e., are entered into the argument, aSet) onto aFileStream." self fileOutChangedMessages: aSet on: aFileStream moveSource: false toFile: 0! !!ClassDescription methodsFor: 'filein/out' stamp: 'MarcusDenker 2/19/2010 18:38'!fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .changes file, and should only write a preamble for every method." | org | (org := self organization) categories do: [:cat | | sels | sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do:[:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]]! !!ClassDescription methodsFor: 'filein/out' stamp: 'nice 1/5/2010 15:59'!fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File all historical description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .changes file, and should only write a preamble for every method." | org | (org := self organization) categories do: [:cat | | sels | sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do: [:sel | self printMethodChunkHistorically: sel on: aFileStream moveSource: moveSource toFile: fileIndex]]! !!ClassDescription methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:55'!fileOutMethod: selector "Write source code of a single method on a file. Make up a name for the file." | internalStream | (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. internalStream := (String new: 1000) writeStream. internalStream header; timeStamp. self printMethodChunk: selector withPreamble: true on: internalStream moveSource: false toFile: 0. FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true.! !!ClassDescription methodsFor: 'filein/out'!fileOutOn: aFileStream "File a description of the receiver on aFileStream." self fileOutOn: aFileStream moveSource: false toFile: 0! !!ClassDescription methodsFor: 'filein/out'!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 nextChunkPut: self definition. 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'!fileOutOrganizationOn: aFileStream "File a description of the receiver's organization on aFileStream." aFileStream cr; nextPut: $!!. aFileStream nextChunkPut: self name, ' reorganize'; cr. aFileStream nextChunkPut: self organization printString; cr! !!ClassDescription methodsFor: 'filein/out'!localMethods "returns the methods of classes including the ones of the traits that the class uses" ^ self methods select: [:each | self includesLocalSelector: each selector].! !!ClassDescription methodsFor: 'filein/out'!methods "returns the methods of classes including the ones of the traits that the class uses" ^ self methodDict values ! !!ClassDescription methodsFor: 'filein/out'!methodsFor: categoryName "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver." ^ ClassCategoryReader new setClass: self category: categoryName asSymbol "(False methodsFor: 'logical operations') inspect"! !!ClassDescription methodsFor: 'filein/out'!methodsFor: aString priorSource: sourcePosition inFile: fileIndex "Prior source pointer ignored when filing in." ^ self methodsFor: aString! !!ClassDescription methodsFor: 'filein/out'!methodsFor: categoryName stamp: changeStamp ^ self methodsFor: categoryName stamp: (Author fixStamp: changeStamp) prior: 0! !!ClassDescription methodsFor: 'filein/out'!methodsFor: categoryName stamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCategoryReader new setClass: self category: categoryName asSymbol changeStamp: changeStamp"Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! !!ClassDescription methodsFor: 'filein/out' stamp: 'MarcusDenker 2/21/2010 12:51'!moveChangesWithVersionsTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes := self selectors select: [:sel | (self methodDict at: sel) fileIndex > 1]. self fileOutChangedMessagesHistorically: changes on: newFile moveSource: true toFile: 2! !!ClassDescription methodsFor: 'filein/out'!printCategoryChunk: categoryName on: aFileStream ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! !!ClassDescription methodsFor: 'filein/out'!printCategoryChunk: category on: aFileStream priorMethod: priorMethod ^ self printCategoryChunk: category on: aFileStream withStamp: Author changeStamp priorMethod: priorMethod! !!ClassDescription methodsFor: 'filein/out'!printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod "Print a method category preamble. This must have a category name. It may have an author/date stamp, and it may have a prior source link. If it has a prior source link, it MUST have a stamp, even if it is empty.""The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." aFileStream cr; nextPut: $!!. aFileStream nextChunkPut: (String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. (changeStamp ~~ nil and: [changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue: [strm nextPutAll: ' stamp: '; print: changeStamp]. priorMethod ~~ nil ifTrue: [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]). ! !!ClassDescription methodsFor: 'filein/out'!printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp priorMethod: nil! !!ClassDescription methodsFor: 'filein/out'!printMethodChunk: selector withPreamble: doPreamble on: outStream moveSource: moveSource toFile: fileIndex "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method oldPos newPos sourceFile endPos | doPreamble ifTrue: [preamble := self name , ' methodsFor: ' , (self organization categoryOfElement: selector) asString printString] ifFalse: [preamble := '']. method := self methodDict at: selector ifAbsent: [outStream nextPutAll: selector; cr. outStream tab; nextPutAll: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. outStream nextPutAll: ' '. ^ outStream]. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [(oldPos := method filePosition) = 0]) ifTrue: ["The source code is not accessible. We must decompile..." preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. outStream nextChunkPut: method decompileString] ifFalse: [sourceFile := SourceFiles at: method fileIndex. preamble size > 0 ifTrue: "Copy the preamble" [outStream copyPreamble: preamble from: sourceFile at: oldPos] ifFalse: [sourceFile position: oldPos]. "Copy the method chunk" newPos := outStream position. outStream copyMethodChunkFrom: sourceFile. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. moveSource ifTrue: "Set the new method source pointer" [endPos := outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. ^ outStream cr! !!ClassDescription methodsFor: 'filein/out' stamp: 'nice 1/5/2010 15:59'!printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex "Copy all source codes historically for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method sourceFile endPos category changeList newPos | category := self organization categoryOfElement: selector. preamble := self name , ' methodsFor: ', category asString printString. method := self methodDict at: selector. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [method filePosition = 0]) ifTrue: [ outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. outStream nextChunkPut: method decompileString. outStream nextChunkPut: ' '; cr] ifFalse: [ changeList := ChangeSet scanVersionsOf: method class: self meta: self isMeta category: category selector: selector. newPos := nil. sourceFile := SourceFiles at: method fileIndex. changeList reverseDo: [ :chgRec | | prior | chgRec fileIndex = fileIndex ifTrue: [ outStream copyPreamble: preamble from: sourceFile at: chgRec position. (prior := chgRec prior) ifNotNil: [ outStream position: outStream position - 2. outStream nextPutAll: ' prior: ', ( prior first = method fileIndex ifFalse: [prior third] ifTrue: [ SourceFiles sourcePointerFromFileIndex: method fileIndex andPosition: newPos]) printString. outStream nextPut: $!!; cr]. "Copy the method chunk" newPos := outStream position. outStream copyMethodChunkFrom: sourceFile at: chgRec position. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. outStream nextChunkPut: ' '; cr]]. moveSource ifTrue: [ endPos := outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. ^ outStream! !!ClassDescription methodsFor: 'filein/out' stamp: 'StephaneDucasse 5/28/2011 13:39'!putClassCommentToCondensedChangesFile: aFileStream "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." | header aStamp aCommentRemoteStr | self isMeta ifTrue: [^ self]. "bulletproofing only" ((aCommentRemoteStr := self organization commentRemoteStr) isNil or: [aCommentRemoteStr sourceFileNumber = 1]) ifTrue: [^ self]. aFileStream cr; nextPut: $!!. header := String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. (aStamp := self organization commentStamp ifNil: ['<historical>']) storeOn: strm. strm nextPutAll: ' prior: 0']. aFileStream nextChunkPut: header. aFileStream cr. self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! !!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:00'!obsolete "Make the receiver obsolete." superclass removeSubclass: self. self organization: nil. super obsolete.! !!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:26'!superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. instanceVariables := nil. self organization: nil.! !!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 23:25'!updateInstances: oldInstances from: oldClass isMeta: isMeta "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." | map variable instSize newInstances | oldInstances isEmpty ifTrue:[^#()]. "no instances to convert" isMeta ifTrue: [ oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. self soleInstance class == self ifTrue:[ ^self error:'Metaclasses can only have one instance']]. map := self instVarMappingFrom: oldClass. variable := self isVariable. instSize := self instSize. newInstances := Array new: oldInstances size. 1 to: oldInstances size do:[:i| newInstances at: i put: ( self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. "Now perform a bulk mutation of old instances into new ones" oldInstances elementsExchangeIdentityWith: newInstances. ^newInstances "which are now old"! !!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 20:48'!updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" | oldInstances | oldInstances := oldClass allInstances asArray. oldInstances := self updateInstances: oldInstances from: oldClass isMeta: self isMeta. "Now fix up instances in segments that are out on the disk." ImageSegment allSubInstancesDo: [:seg | seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta]. ^oldInstances" | crashingBlock class | class := Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar := value'. class compile:'crashingBlock ^[instVar]'. crashingBlock := (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. crashingBlock. crashingBlock value. "! !!ClassDescription methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:04'!addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." self subclassResponsibility! !!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'!allInstVarNamesEverywhere "Answer the set of inst var names used by the receiver, all superclasses, and all subclasses" | aList | aList := OrderedCollection new. (self allSuperclasses , self withAllSubclasses asOrderedCollection) do: [:cls | aList addAll: cls instVarNames]. ^ aList asSet "BorderedMorph allInstVarNamesEverywhere"! !!ClassDescription methodsFor: 'instance variables' stamp: 'BenjaminVanRyseghem 11/24/2010 15:56'!checkForInstVarsOK: instVarString "Return true if instVarString does no include any names used in a subclass" | instVarArray | instVarArray := instVarString subStrings: ' '. self allSubclasses do: [:cl | cl instVarNames do: [:n | (instVarArray includes: n) ifTrue: [self error: n , ' is already used in ' , cl name. ^ false]]]. ^ true! !!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'!classThatDefinesClassVariable: classVarName "Answer the class that defines the given class variable" (self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. ^self superclass ifNotNil: [self superclass classThatDefinesClassVariable: classVarName]! !!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'!classThatDefinesInstanceVariable: instVarName (self instVarNames notNil and: [self instVarNames includes: instVarName asString]) ifTrue: [^ self]. ^self superclass ifNotNil: [self superclass classThatDefinesInstanceVariable: instVarName]! !!ClassDescription methodsFor: 'instance variables'!forceNewFrom: anArray "Create a new instance of the class and fill its instance variables up with the array." | object max | object := self new. max := self instSize. anArray doWithIndex: [:each :index | index > max ifFalse: [object instVarAt: index put: each]]. ^ object! !!ClassDescription methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:06'!hasInstVarNamed: aString "Return true whether the receiver defines an instance variable named aString." ^ self instVarNames includes: aString! !!ClassDescription methodsFor: 'instance variables' stamp: 'StephaneDucasse 5/28/2011 13:32'!instVarIndexFor: instVarName "Answer the index of the named instance variable." | index | index := instanceVariables == nil ifTrue: [0] ifFalse: [instanceVariables indexOf: instVarName]. index = 0 ifTrue: [^superclass == nil ifTrue: [0] ifFalse: [superclass instVarIndexFor: instVarName]]. ^superclass == nil ifTrue: [index] ifFalse: [index + superclass instSize]! !!ClassDescription methodsFor: 'instance variables' stamp: 'ul 11/15/2010 10:10'!instVarIndexFor: instVarName ifAbsent: aBlock "Answer the index of the named instance variable." | index | index := instanceVariables == nil ifTrue: [0] ifFalse: [instanceVariables indexOf: instVarName ifAbsent: [0]]. index = 0 ifTrue: [^superclass == nil ifTrue: [aBlock value] ifFalse: [superclass instVarIndexFor: instVarName ifAbsent: aBlock]]. ^superclass == nil ifTrue: [index] ifFalse: [index + superclass instSize]! !!ClassDescription methodsFor: 'instance variables'!instVarNameForIndex: index "Answer the named instance variable with index index or nil if none." | superInstSize | index > self instSize ifTrue: [^nil]. superInstSize := superclass isNil ifTrue: [0] ifFalse: [superclass instSize]. index > superInstSize ifTrue: [^instanceVariables at: index - superInstSize]. superclass isNil ifTrue: [^nil]. ^superclass instVarNameForIndex: index "(Object allSubclasses select: [:cls| cls instSize > cls superclass instSize and: [cls subclasses isEmpty and: [cls superclass instSize > 0]]]) collect: [:cls| (1 to: cls instSize) collect: [:i| cls instVarNameForIndex: i]]"! !!ClassDescription methodsFor: 'instance variables'!instVarNames "Answer an Array of the receiver's instance variable names." instanceVariables == nil ifTrue: [^#()] ifFalse: [^instanceVariables]! !!ClassDescription methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:05'!removeInstVarNamed: aString "Remove the argument, aString, as one of the receiver's instance variables. Create an error notification if the argument is not found." self subclassResponsibility! !!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'!renameInstVar: oldName to: newName (self confirm: 'WARNING: Renaming of instance variablesis subject to substitution ambiguities.Do you still wish to attempt it?') ifFalse: [self halt]. "...In other words, this does a dumb text search-and-replace, which might improperly alter, eg, a literal string. As long as the oldName is unique, everything should work jes' fine. - di" ^ self renameSilentlyInstVar: oldName to: newName! !!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'!renameSilentlyInstVar: old to: new | i oldName newName | oldName := old asString. newName := new asString. (i := self instVarNames indexOf: oldName) = 0 ifTrue: [self error: oldName , ' is not defined in ', self name]. self allSuperclasses , self withAllSubclasses asOrderedCollection do: [:cls | (cls instVarNames includes: newName) ifTrue: [self error: newName , ' is already used in ', cls name]]. self instVarNames replaceFrom: i to: i with: (Array with: newName). self replaceSilently: oldName to: newName. "replace in text body of all methods"! !!ClassDescription methodsFor: 'instance variables' stamp: 'nice 12/4/2009 00:00'!replaceSilently: old to: new "text-replace any part of a method. Used for class and pool variables. Don't touch the header. Not guaranteed to work if name appears in odd circumstances" | oldName newName | oldName := old asString. newName := new asString. self withAllSubclasses do: [:cls | | sels | sels := cls selectors copyWithoutAll: #(DoIt DoItIn:). sels do: [:sel | | oldCode newCode parser header body | oldCode := cls sourceCodeAt: sel. "Don't make changes in the method header" (parser := cls parserClass new) parseSelector: oldCode. header := oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size). body := header size > oldCode size ifTrue: [''] ifFalse: [oldCode copyFrom: header size+1 to: oldCode size]. newCode := header , (body copyReplaceTokens: oldName with: newName). newCode ~= oldCode ifTrue: [cls compile: newCode classified: (cls organization categoryOfElement: sel) notifying: nil]]. cls isMeta ifFalse: [| oldCode newCode | oldCode := cls comment. newCode := oldCode copyReplaceTokens: oldName with: newName. newCode ~= oldCode ifTrue: [cls comment: newCode]]]! !!ClassDescription methodsFor: 'organization'!methodReferencesInCategory: aCategoryName ^(self organization listAtCategoryNamed: aCategoryName) collect: [:ea | SourcedMethodReference new setClassSymbol: self theNonMetaClass name classIsMeta: self isMeta methodSymbol: ea stringVersion: '']! !!ClassDescription methodsFor: 'organization' stamp: 'MarcusDenker 2/21/2010 12:51'!organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization ifNil: [self organization: (ClassOrganizer defaultList: self selectors asArray sort)]. (organization isMemberOf: Array) ifTrue: [self recoverFromMDFaultWithTrace]. "Making sure that subject is set correctly. It should not be necessary." organization ifNotNil: [organization setSubject: self]. ^ organization! !!ClassDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:04'!organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." aClassOrg ifNotNil: [aClassOrg setSubject: self]. organization := aClassOrg! !!ClassDescription methodsFor: 'organization'!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 organization! !!ClassDescription methodsFor: 'organization'!whichCategoryIncludesSelector: aSelector "Answer the category of the argument, aSelector, in the organization of the receiver, or answer nil if the receiver does not inlcude this selector." (self includesSelector: aSelector) ifTrue: [^ self organization categoryOfElement: aSelector] ifFalse: [^nil]! !!ClassDescription methodsFor: 'organization'!zapOrganization "Remove the organization of this class by message categories. This is typically done to save space in small systems. Classes and methods created or filed in subsequently will, nonetheless, be organized" self organization: nil. self isClassSide ifFalse: [self classSide zapOrganization]! !!ClassDescription methodsFor: 'organization updating'!applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. ^ changedSelectors.! !!ClassDescription methodsFor: 'organization updating' stamp: 'nice 1/5/2010 15:59'!noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition aCollection do: [:each | | oldCategory newCategory | oldCategory := self organization categoryOfElement: each. newCategory := (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory. self noteRecategorizedSelector: each from: oldCategory to: newCategory]! !!ClassDescription methodsFor: 'organization updating'!noteRecategorizedSelector: aSymbol from: oldCategoryOrNil to: newCategoryOrNil | changedCategories | changedCategories := self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil. changedCategories do: [:each | (self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]! !!ClassDescription methodsFor: 'organization updating'!notifyOfRecategorizedSelector: element from: oldCategory to: newCategory SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self! !!ClassDescription methodsFor: 'organization updating' stamp: 'nice 1/5/2010 15:59'!updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil | changedCategories composition | changedCategories := IdentitySet new. composition := self hasTraitComposition ifTrue: [self traitComposition] ifFalse: [TraitComposition new]. (composition methodDescriptionsForSelector: aSymbol) do: [:each | | currentCategory effectiveCategory sel | sel := each selector. (self includesLocalSelector: sel) ifFalse: [ currentCategory := self organization categoryOfElement: sel. effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil. effectiveCategory isNil ifTrue: [ currentCategory ifNotNil: [changedCategories add: currentCategory]. self organization removeElement: sel. ] ifFalse: [ ((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [ currentCategory ifNotNil: [changedCategories add: currentCategory]. self organization classify: sel under: effectiveCategory suppressIfDefault: false]]]]. ^ changedCategories! !!ClassDescription methodsFor: 'printing' stamp: 'nice 10/22/2009 09:39'!classVariablesString "Answer a string of my class variable names separated by spaces." ^String streamContents: [ :stream | self classVarNames do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! !!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:51'!instanceVariablesString "Answer a string of my instance variable names separated by spaces." ^String streamContents: [ :stream | self instVarNames do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! !!ClassDescription methodsFor: 'printing'!printOn: aStream aStream nextPutAll: self name! !!ClassDescription methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'!printWithClosureAnalysisOn: aStream aStream nextPutAll: self name! !!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:52'!sharedPoolsString "Answer a string of my shared pool names separated by spaces." ^String streamContents: [ :stream | self sharedPools do: [ :each | stream nextPutAll: (self environment keyAtIdentityValue: each ifAbsent: [ 'private' ]) ] separatedBy: [ stream space ] ]! !!ClassDescription methodsFor: 'printing'!storeOn: aStream "Classes and Metaclasses have global names." aStream nextPutAll: self name! !!ClassDescription methodsFor: 'testing' stamp: 'Alexandre Bergel 8/12/2010 18:51'!isAbstractClass self subclassResponsibility! !!ClassDescription methodsFor: 'private'!errorCategoryName self error: 'Category name must be a String'! !!ClassDescription methodsFor: 'private' stamp: 'al 11/28/2005 11:51'!instVarMappingFrom: oldClass "Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass." | oldInstVarNames | oldInstVarNames := oldClass allInstVarNames. ^self allInstVarNames collect: [:instVarName | oldInstVarNames indexOf: instVarName].! !!ClassDescription methodsFor: 'private' stamp: 'StephaneDucasse 3/3/2010 13:43'!linesOfCode "An approximate measure of lines of code. Includes comments, but excludes blank lines." | lines | lines := self localMethods inject: 0 into: [:sum :each | sum + each linesOfCode]. ^ self isMeta ifTrue: [lines] ifFalse: [lines + self class linesOfCode]! !!ClassDescription methodsFor: 'private' stamp: 'alain.plantec 5/18/2009 08:43'!logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor aCompiledMethodWithNode method putSource: aText fromParseNode: aCompiledMethodWithNode node class: self category: category withStamp: changeStamp inFile: 2 priorMethod: (self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: []) ! !!ClassDescription methodsFor: 'private' stamp: 'ar 7/10/1999 11:17'!newInstanceFrom: oldInstance variable: variable size: instSize map: map "Create a new instance of the receiver based on the given old instance. The supplied map contains a mapping of the old instVar names into the receiver's instVars" | new | variable ifTrue: [new := self basicNew: oldInstance basicSize] ifFalse: [new := self basicNew]. 1 to: instSize do: [:offset | (map at: offset) > 0 ifTrue: [new instVarAt: offset put: (oldInstance instVarAt: (map at: offset))]]. variable ifTrue: [1 to: oldInstance basicSize do: [:offset | new basicAt: offset put: (oldInstance basicAt: offset)]]. ^new! !!ClassDescription methodsFor: 'private' stamp: 'Alexandre Bergel 4/27/2010 14:17'!numberOfMethods "count all methods that are local (not comming from a trait)" | num | num := self localMethods size. ^ self isMeta ifTrue: [ num ] ifFalse: [ num + self class numberOfMethods ] ! !!ClassDescription methodsFor: 'private' stamp: 'ar 7/15/1999 17:04'!setInstVarNames: instVarArray "Private - for class initialization only" | required | required := self instSize. superclass notNil ifTrue:[required := required - superclass instSize]. instVarArray size = required ifFalse:[^self error: required printString, ' instvar names are required']. instVarArray isEmpty ifTrue:[instanceVariables := nil] ifFalse:[instanceVariables := instVarArray asArray].! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!ClassDescription class uses: TClassAndTraitDescription classTrait instanceVariableNames: ''! ClassDescription subclass: #Class uses: TBehaviorCategorization instanceVariableNames: 'subclasses name classPool sharedPools environment category traitComposition localSelectors' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!Class commentStamp: '<historical>' prior: 0!I add a number of facilities to those in ClassDescription: A set of all my subclasses (defined in ClassDescription, but only used here and below) A name by which I can be found in a SystemDictionary A classPool for class variables shared between this class and its metaclass A list of sharedPools which probably should be supplanted by some better mechanism.My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription.The slot 'subclasses' is a redundant structure. It is never used during execution, but is used by the development system to simplify or speed certain operations. !!Class methodsFor: '*HelpSystem-Core' stamp: 'tbn 3/11/2010 23:42'!asHelpTopic ^SystemReference forClass: self! !!Class methodsFor: '*Monticello' stamp: 'al 3/26/2006 21:31'!asClassDefinition ^ MCClassDefinition name: self name superclassName: self superclass name traitComposition: self traitCompositionString classTraitComposition: self class traitCompositionString category: self category instVarNames: self instVarNames classVarNames: self classVarNames poolDictionaryNames: self poolDictionaryNames classInstVarNames: self class instVarNames type: self typeOfClass comment: self organization classComment asString commentStamp: self organization commentStamp ! !!Class methodsFor: '*Monticello' stamp: 'avi 3/10/2004 13:32'!classDefinitions ^ Array with: self asClassDefinition! !!Class methodsFor: '*Monticello' stamp: 'ab 4/14/2003 22:30'!poolDictionaryNames ^ self sharedPools collect: [:ea | self environment keyAtIdentityValue: ea]! !!Class methodsFor: '*System-Object Storage' stamp: 'Alexandre.Bergel 8/19/2009 11:13'!objectForDataStream: refStrm "I am about to be written on an object file. Write a reference to a class in Smalltalk instead." refStrm insideASegment ifFalse: ["Normal use" ^ DiskProxy global: self theNonMetaClass name selector: #withClassVersion: args: {self classVersion}] ifTrue: ["recording objects to go into an ImageSegment" (refStrm rootObject includes: self) ifTrue: [^ self]. "is in roots, intensionally write out, ^ self" "A normal class. remove it from references. Do not trace." refStrm references removeKey: self ifAbsent: []. "already there" ^ nil]! !!Class methodsFor: '*System-Object Storage' stamp: 'Alexandre.Bergel 8/19/2009 11:14'!storeDataOn: aDataStream "I don't get stored. Use a DiskProxy" self error: 'use a DiskProxy to store a Class'! !!Class methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 10:53'!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." self deprecated: 'Use addClassVarNamed: ' on: '27 August 2010' in: 'Pharo1.2'. self addClassVarNamed: aString.! !!Class methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 11:38'!addInstVarName: aString self deprecated: 'use addInstVarNamed: instead' on: '27 August 2010' in: 'Pharo1.2'. self addInstVarNamed: aString ! !!Class methodsFor: '*deprecated12' stamp: 'sd 8/27/2010 16:03'!removeClassVarName: aString "Remove the class variable whose name is the argument, aString, from the names defined in the receiver, a class. Create an error notification if aString is not a class variable or if it is still being used in the code of the class." self deprecated: 'Use removeClassVarNamed: ' on: '27 August 2010' in: 'Pharo1.2'. self removeClassVarNamed: aString.! !!Class methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 11:39'!removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables." self deprecated: 'use removeInstVarNamed: instead' on: '27 August 2010' in: 'Pharo1.2'. self removeInstVarNamed: aString ! !!Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'!basicCategory ^category! !!Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'!basicCategory: aSymbol category := aSymbol! !!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!basicLocalSelectors "Direct accessor for the instance variable localSelectors. Since localSelectors is lazily initialized, this may return nil, which means that all selectors are local." ^ localSelectors! !!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!basicLocalSelectors: aSetOrNil localSelectors := aSetOrNil! !!Class methodsFor: 'accessing'!classPool "Answer the dictionary of class variables." classPool == nil ifTrue: [^Dictionary new] ifFalse: [^classPool]! !!Class methodsFor: 'accessing' stamp: 'BG 8/11/2002 20:53'!classPoolFrom: aClass "share the classPool with aClass." classPool := aClass classPool! !!Class methodsFor: 'accessing' stamp: 'al 9/3/2004 13:37'!classPool: aDictionary classPool := aDictionary! !!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'!hasTraitComposition ^traitComposition notNil! !!Class methodsFor: 'accessing'!name "Answer the name of the receiver." name == nil ifTrue: [^super name] ifFalse: [^name]! !!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'!traitComposition traitComposition ifNil: [traitComposition := TraitComposition new]. ^traitComposition! !!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:37'!traitComposition: aTraitComposition traitComposition := aTraitComposition! !!Class methodsFor: 'accessing class hierarchy' stamp: 'tk 10/17/1999 13:31'!addSubclass: aSubclass "Make the argument, aSubclass, be one of the subclasses of the receiver. Create an error notification if the argument's superclass is not the receiver." aSubclass superclass ~~ self ifTrue: [^self error: aSubclass name , ' is not my subclass']. subclasses == nil ifTrue: [subclasses := Array with: aSubclass. ^self]. subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass" subclasses := subclasses copyWith: aSubclass.! !!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:54'!removeSubclass: aSubclass "If the argument, aSubclass, is one of the receiver's subclasses, remove it." subclasses == nil ifFalse: [subclasses := subclasses copyWithout: aSubclass. subclasses isEmpty ifTrue: [subclasses := nil]].! !!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'!subclasses "Answer a Set containing the receiver's subclasses." ^subclasses == nil ifTrue: [#()] ifFalse: [subclasses copy]! !!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'!subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." subclasses == nil ifFalse:[subclasses do: aBlock]! !!Class methodsFor: 'class name' stamp: 'FernandoOlivero 5/17/2010 13:04'!rename: aString "The new name of the receiver is the argument, aString." | oldName newName | (newName := aString asSymbol) = (oldName := self name) ifTrue: [^ self]. (self environment includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. name := newName. self environment renameClass: self from: oldName. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , 'from Undeclared. Check them after this change.']. ! !!Class methodsFor: 'class variables' stamp: 'StephaneDucasse 8/27/2010 10:52'!addClassVarNamed: 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 oldState | oldState := self copy. aString first canBeGlobalVarInitial ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol := aString asSymbol. self withAllSubclasses do: [:subclass | (subclass bindingOf: symbol) ifNotNil:[ ^ 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" classPool declare: symbol from: Undeclared. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! !!Class methodsFor: 'class variables' stamp: 'nice 10/20/2009 20:47'!allClassVarNames "Answer a Set of the names of the receiver's class variables, including those defined in the superclasses of the receiver." | aSet | self superclass == nil ifTrue: [^self classVarNames asSet] "This is the keys so it is a new Set." ifFalse: [aSet := self superclass allClassVarNames. aSet addAll: self classVarNames. ^aSet]! !!Class methodsFor: 'class variables' stamp: 'MarcusDenker 2/19/2010 11:40'!classVarNamed: name "Answer the content of the Class Variable" ^self classPool at: name asSymbol ifAbsent: [self error: 'no such lass var']! !!Class methodsFor: 'class variables' stamp: 'MarcusDenker 2/19/2010 11:42'!classVarNamed: name put: anObject "Store anObject in the class variable." | symbol | symbol := name asSymbol. (self classPool includesKey: symbol) ifFalse: [^self error: 'no such lass var']. self classPool at: symbol put: anObject.! !!Class methodsFor: 'class variables' stamp: 'nice 10/20/2009 22:02'!classVarNames "Answer a collection of the names of the class variables defined in the receiver." ^self classPool keys asArray sort! !!Class methodsFor: 'class variables' stamp: 'tk 3/15/98 20:19'!ensureClassPool classPool ifNil: [classPool := Dictionary new].! !!Class methodsFor: 'class variables' stamp: 'StephaneDucasse 8/27/2010 10:55'!hasClassVarNamed: aString "Return whether the receiver has a class variables (shared variables among its class and subclasses) named: aString" ^ self classVarNames includes: aString! !!Class methodsFor: 'class variables' stamp: 'StephaneDucasse 5/27/2011 19:10'!removeClassVarNamed: aString "Remove the class variable whose name is the argument, aString, from the names defined in the receiver, a class. Create an error notification if aString is not a class variable or if it is still being used in the code of the class." | aSymbol | aSymbol := aString asSymbol. (classPool includesKey: aSymbol) ifFalse: [^self error: aString, ' is not a class variable']. self withAllSubclasses do:[:subclass | (Array with: subclass with: subclass class) do:[:classOrMeta | (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) isEmpty ifFalse: [ InMidstOfFileinNotification signal ifTrue: [ self crLog: self name, ' (' , aString , ' is Undeclared) '. ^Undeclared declare: aSymbol from: classPool]. (self confirm: (aString,' is still used in code of class ', classOrMeta name, '.\Is it okay to move it to Undeclared?') withCRs) ifTrue:[^Undeclared declare: aSymbol from: classPool] ifFalse:[^self]]]]. classPool removeKey: aSymbol. classPool isEmpty ifTrue: [classPool := nil].! !!Class methodsFor: 'class variables' stamp: 'StephaneDucasse 11/11/2010 22:38'!usesClassVarNamed: aString "Return whether the receiver or its superclasses have a class variable named: aString" ^ self allClassVarNames includes: aString! !!Class methodsFor: 'compiling' stamp: 'stephaneducasse 8/16/2010 23:19'!binding "Answer a binding for the receiver, sharing if possible" | binding | binding := self environment associationAt: name ifAbsent: [nil -> self]. ^binding value == self ifTrue: [binding] ifFalse: [nil -> self]! !!Class methodsFor: 'compiling' stamp: 'nice 1/5/2010 20:30'!bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" | aSymbol binding | aSymbol := varName asSymbol. "First look in classVar dictionary." binding := self classPool bindingOf: aSymbol. binding ifNotNil:[^binding]. "Next look in shared pools." self sharedPools do:[:pool | | aBinding | aBinding := pool bindingOf: aSymbol. aBinding ifNotNil:[^aBinding]. ]. "Next look in declared environment." binding := self environment bindingOf: aSymbol. binding ifNotNil:[^binding]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ nil] ifFalse: [^ superclass bindingOf: aSymbol].! !!Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:13'!canFindWithoutEnvironment: varName "This method is used for analysis of system structure -- see senders." "Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment." "First look in classVar dictionary." (self classPool bindingOf: varName) ifNotNil:[^true]. "Next look in shared pools." self sharedPools do:[:pool | (pool bindingOf: varName) ifNotNil:[^true]. ]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ false] ifFalse: [^ (superclass bindingOf: varName) notNil].! !!Class methodsFor: 'compiling' stamp: 'ar 7/14/1999 04:56'!compileAll super compileAll. self class compileAll.! !!Class methodsFor: 'compiling'!compileAllFrom: oldClass "Recompile all the methods in the receiver's method dictionary (not the subclasses). Also recompile the methods in the metaclass." super compileAllFrom: oldClass. self class compileAllFrom: oldClass class! !!Class methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:24'!possibleVariablesFor: misspelled continuedFrom: oldResults | results | results := misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. self sharedPools do: [:pool | results := misspelled correctAgainstDictionary: pool continuedFrom: results ]. superclass == nil ifTrue: [ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ] ifFalse: [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! !!Class methodsFor: 'copying' stamp: 'di 2/17/2000 22:43'!copy | newClass | newClass := self class copy new superclass: superclass methodDict: self methodDict copy format: format name: name organization: self organization copy instVarNames: instanceVariables copy classPool: classPool copy sharedPools: sharedPools. Class instSize+1 to: self class instSize do: [:offset | newClass instVarAt: offset put: (self instVarAt: offset)]. ^ newClass! !!Class methodsFor: 'copying' stamp: 'lr 3/14/2010 21:13'!duplicateClassWithNewName: aSymbol | copysName class newDefinition | copysName := aSymbol asSymbol. copysName = self name ifTrue: [ ^ self ]. (Smalltalk globals includesKey: copysName) ifTrue: [ ^ self error: copysName , ' already exists' ]. newDefinition := self definition copyReplaceAll: '#' , self name asString with: '#' , copysName asString. class := Compiler evaluate: newDefinition logged: true. class class instanceVariableNames: self class instanceVariablesString. class copyAllCategoriesFrom: self. class class copyAllCategoriesFrom: self class. ^ class! !!Class methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 00:53'!fileOut "Create a file whose name is the name of the receiver with '.st' as the extension, and file a description of the receiver onto it." | internalStream | internalStream := (String new: 100) writeStream. internalStream header; timeStamp. self hasSharedPools ifTrue: [ self shouldFileOutPools ifTrue: [self fileOutSharedPoolsOn: internalStream]]. self fileOutOn: internalStream moveSource: false toFile: 0. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true! !!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:00'!fileOutInitializerOn: aStream ^self class fileOutInitializerOn: aStream! !!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'!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." ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! !!Class methodsFor: 'fileIn/Out' stamp: 'StephaneDucasse 5/27/2011 19:09'!fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool "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." self crLog: self name. super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. self class nonTrivial ifTrue: [aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. self class fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool]! !!Class methodsFor: 'fileIn/Out' stamp: 'StephaneDucasse 5/27/2011 19:10'!fileOutPool: aPool onFileStream: aFileStream | aPoolName | (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. aPoolName := self environment keyAtIdentityValue: aPool. self crLog: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asSortedCollection do: [ :aKey | | aValue | aValue := aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. (aValue isKindOf: Number) ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! !!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'!fileOutSharedPoolsOn: aFileStream "file out the shared pools of this class after prompting the user about each pool" | poolsToFileOut | poolsToFileOut := self sharedPools select: [:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))]. poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. ! !!Class methodsFor: 'fileIn/Out' stamp: 'md 4/30/2008 15:36'!hasSharedPools ^ self sharedPools notEmpty! !!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!reformatAll "Reformat all methods in this class. Leaves old code accessible to version browsing" super reformatAll. "me..." self class reformatAll "...and my metaclass"! !!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!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:" ChangeSet current removeClassAndMetaClassChanges: self! !!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!shouldFileOutPool: aPoolName "respond with true if the user wants to file out aPoolName" ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! !!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!shouldFileOutPools "respond with true if the user wants to file out the shared pools" ^self confirm: 'FileOut selected sharedPools?'! !!Class methodsFor: 'fileIn/Out' stamp: 'ar 4/10/2005 20:27'!withClassVersion: aVersion aVersion = self classVersion ifTrue:[^self]. ^self error: 'Invalid class version'! !!Class methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 11/24/2010 15:55'!declare: varString "Declare class variables common to all instances. Answer whether recompilation is advisable." | newVars conflicts | newVars := (varString subStrings: ' ') collect: [:x | x asSymbol]. conflicts := false. classPool == nil ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: [:var | self removeClassVarNamed: var]]. (newVars reject: [:var | self classPool includesKey: var]) do: [:var | "adding" "check if new vars defined elsewhere" (self bindingOf: var) notNil ifTrue: [(DuplicatedVariableError new) variable: var; signal: var , ' is defined elsewhere'. conflicts := true]]. newVars size > 0 ifTrue: [classPool := self classPool. "in case it was nil" newVars do: [:var | classPool declare: var from: Undeclared]]. ^conflicts! !!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 14:07'!obsolete "Change the receiver and all of its subclasses to an obsolete class." self == Object ifTrue: [^self error: 'Object is NOT obsolete']. self setName: 'AnObsolete' , self name. Object class instSize + 1 to: self class instSize do: [:i | self instVarAt: i put: nil]. "Store nil over class instVars." self classPool: nil. self sharedPools: nil. self class obsolete. super obsolete.! !!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'!removeFromSystem "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." self removeFromSystem: true.! !!Class methodsFor: 'initialize-release' stamp: 'sd 4/24/2008 22:28'!removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." "tell class to deactivate and unload itself-- two separate events in the module system" self unload. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self environment forgetClass: self logged: logged. self obsolete.! !!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:36'!removeFromSystemUnlogged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver. Do not log the removal either to the current change set nor to the system changes log" ^self removeFromSystem: false! !!Class methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 11/24/2010 15:55'!sharing: poolString "Set up sharedPools. Answer whether recompilation is advisable." | oldPools | oldPools := self sharedPools. sharedPools := OrderedCollection new. (poolString subStrings: ' ') do: [:poolName | sharedPools add: (self environment at: poolName asSymbol ifAbsent:[ (self confirm: 'The pool dictionary ', poolName,' does not exist.', '\Do you want it automatically created?' withCRs) ifTrue:[self environment at: poolName asSymbol put: Dictionary new] ifFalse:[^self error: poolName,' does not exist']])]. sharedPools isEmpty ifTrue: [sharedPools := nil]. oldPools do: [:pool | | found | found := self sharedPools anySatisfy: [:p | p == pool]. found ifFalse: [^ true "A pool got deleted"]]. ^ false! !!Class methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 10:55'!superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet "Answer an instance of me, a new class, using the arguments of the message as the needed information. Must only be sent to a new instance; else we would need Object flushCache." superclass := sup. methodDict := md. format := ft. name := nm. instanceVariables := nilOrArray. classPool := pool. sharedPools := poolSet. self organization: org.! !!Class methodsFor: 'initialize-release' stamp: 'ar 7/20/1999 11:23'!superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. subclasses := nil. "Important for moving down the subclasses field into Class"! !!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'!unload "Sent when a the class is removed. Does nothing, but may be overridden by (class-side) subclasses."! !!Class methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:38'!addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." ^(ClassBuilder new) name: self name inEnvironment: self environment subclassOf: self superclass type: self typeOfClass instanceVariableNames: self instanceVariablesString, ' ', aString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category! !!Class methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:38'!removeInstVarNamed: 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 inEnvironment: self environment subclassOf: self superclass type: self typeOfClass instanceVariableNames: newInstVarString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category! !!Class methodsFor: 'organization'!category "Answer the system organization category for the receiver. First check whether the category name stored in the ivar is still correct and only if this fails look it up (latter is much more expensive)" | result | self basicCategory ifNotNil: [ :symbol | ((self environment organization listAtCategoryNamed: symbol) includes: self name) ifTrue: [ ^symbol ] ]. self basicCategory: (result := self environment organization categoryOfElement: self name). ^result! !!Class methodsFor: 'organization'!category: aString "Categorize the receiver under the system category, aString, removing it from any previous categorization." | oldCategory | oldCategory := self basicCategory. aString isString ifTrue: [ self basicCategory: aString asSymbol. self environment organization classify: self name under: self basicCategory ] ifFalse: [self errorCategoryName]. SystemChangeNotifier uniqueInstance class: self recategorizedFrom: oldCategory to: self basicCategory! !!Class methodsFor: 'organization' stamp: 'di 11/16/1999 16:25'!environment environment == nil ifTrue: [^ super environment]. ^ environment! !!Class methodsFor: 'organization' stamp: 'di 12/23/1999 11:42'!environment: anEnvironment environment := anEnvironment! !!Class methodsFor: 'pool variables' stamp: 'tpr 5/30/2003 13:04'!addSharedPool: aSharedPool "Add the argument, aSharedPool, as one of the receiver's shared pools. Create an error if the shared pool is already one of the pools. This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses" (self sharedPools includes: aSharedPool) ifTrue: [^self error: 'This is already in my shared pool list']. sharedPools == nil ifTrue: [sharedPools := OrderedCollection with: aSharedPool] ifFalse: [sharedPools add: aSharedPool]! !!Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 14:25'!allSharedPools "Answer a Set of the pools the receiver shares, including those defined in the superclasses of the receiver." | aSet | ^self superclass == nil ifTrue: [self sharedPools copy] ifFalse: [aSet := self superclass allSharedPools. aSet addAll: self sharedPools. aSet]! !!Class methodsFor: 'pool variables' stamp: 'StephaneDucasse 11/11/2010 22:39'!hasPoolVarNamed: aString "Return whether the receiver has a pool variable named: aString" self hasSharedPools ifTrue: [ self sharedPools do: [:each | (each usesClassVarNamed: aString) ifTrue: [ ^true ]]] ifFalse: [ ^false ]. ^false! !!Class methodsFor: 'pool variables' stamp: 'tk 9/12/96'!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: [sharedPools remove: aDictionary. sharedPools isEmpty ifTrue: [sharedPools := nil]. ^self]. "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]]]. sharedPools remove: aDictionary. sharedPools isEmpty ifTrue: [sharedPools := nil]! !!Class methodsFor: 'pool variables'!sharedPools "Answer a Set of the pool dictionaries declared in the receiver." sharedPools == nil ifTrue: [^OrderedCollection new] ifFalse: [^sharedPools]! !!Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 13:41'!sharedPools: aCollection sharedPools := aCollection! !!Class methodsFor: 'pool variables' stamp: 'StephaneDucasse 11/11/2010 22:39'!usesPoolVarNamed: aString "Return whether the receiver has a pool variable named: aString" self hasSharedPools ifTrue: [ self allSharedPools do: [:each | (each usesClassVarNamed: aString) ifTrue: [^true]]] ifFalse: [^false]. ^false! !!Class methodsFor: 'self evaluating' stamp: 'nice 11/5/2009 21:56'!isSelfEvaluating ^self isObsolete not! !!Class methodsFor: 'subclass creation' stamp: 'Alexandre Bergel 6/3/2010 08:39'!newSubclass | i className | i := 1. [className := (self name , i printString) asSymbol. self environment includesKey: className] whileTrue: [i := i + 1]. ^ self subclass: className instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified'"Point newSubclass new"! !!Class methodsFor: 'subclass creation' stamp: 'AlexandreBergel 1/26/2009 10:22'!subclass: t ^ self subclass: t instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified' ! !!Class methodsFor: 'subclass creation' stamp: 'AlexandreBergel 1/26/2009 10:22'!subclass: t instanceVariableNames: ins ^ self subclass: t instanceVariableNames: ins classVariableNames: '' poolDictionaries: '' category: 'Unclassified' ! !!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'!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 (the receiver)." ^(ClassBuilder new) superclass: self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!Class methodsFor: 'subclass creation' stamp: 'Alexandre Bergel 5/22/2010 14:42'!subclass: t uses: aTraitComposition | cls | cls := self subclass: t instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified'. cls setTraitComposition: aTraitComposition asTraitComposition. ^ cls! !!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!subclass: t uses: aTraitCompositionOrArray instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass! !!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'!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 (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: s category: cat! !!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!variableByteSubclass: t uses: aTraitCompositionOrArray 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 indexable byte-sized nonpointer variables." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass! !!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'!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 (the receiver) in which the subclass is to have indexable pointer variables." ^(ClassBuilder new) superclass: self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:17'!variableSubclass: t uses: aTraitCompositionOrArray 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 indexable pointer variables." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass ! !!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'!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 (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: s category: cat! !!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!variableWordSubclass: t uses: aTraitCompositionOrArray 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 indexable word-sized nonpointer variables." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass ! !!Class methodsFor: 'subclass creation' stamp: 'tak 9/25/2008 15:00'!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." ^(ClassBuilder new) superclass: self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! !!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!weakSubclass: t uses: aTraitCompositionOrArray 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." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass ! !!Class methodsFor: 'testing'!hasMethods "Answer a Boolean according to whether any methods are defined for the receiver (includes whether there are methods defined in the receiver's metaclass)." ^super hasMethods or: [self class hasMethods]! !!Class methodsFor: 'testing' stamp: 'Alexandre Bergel 8/12/2010 18:51'!isAbstractClass ^ (self allMethods anySatisfy: [:cm | cm sendsSelector: #subclassResponsibility ]) or: [ self class allMethods anySatisfy: [:cm | cm sendsSelector: #subclassResponsibility ] ]! !!Class methodsFor: 'testing' stamp: 'al 6/5/2006 13:13'!isObsolete "Return true if the receiver is obsolete." ^(self environment at: name ifAbsent: [nil]) ~~ self! !!Class methodsFor: 'traits' stamp: 'NS 4/12/2004 16:48'!applyChangesOfNewTraitCompositionReplacing: oldComposition "See Trait>>applyChangesOfNewTraitCompositionReplacing:" | changedSelectors | changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. self classSide noteNewBaseTraitCompositionApplied: self traitComposition. ^ changedSelectors! !!Class methodsFor: 'viewer' stamp: 'sw 12/1/2000 20:39'!externalName "Answer a name by which the receiver can be known." ^ name! !!Class methodsFor: 'private' stamp: 'ar 7/15/1999 15:37'!setName: aSymbol "Private - set the name of the class" name := aSymbol.! !!Class methodsFor: 'private' stamp: 'sd 2/1/2004 15:18'!spaceUsed "Object spaceUsed" ^ super spaceUsed + self class spaceUsed! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!Class class uses: TBehaviorCategorization classTrait instanceVariableNames: ''!!Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 13:56'!allSuperclassesFor: aClass cache: cache ^ cache at: aClass ifAbsentPut: [aClass allSuperclasses asArray]! !!Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 15:07'!doesNotIncludeInstanceOrSuperclassesFor: aClass in: unprocessedClasses cache: cache | soleInstance | soleInstance := aClass soleInstance. ^ (unprocessedClasses includes: soleInstance) not and: [ self hasNoSuperclassesOf: soleInstance in: unprocessedClasses cache: cache]! !!Class class methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 00:53'!fileOutPool: aString "file out the global pool named aString" | internalStream | internalStream := (String new: 1000) writeStream. self new fileOutPool: (self environment at: aString asSymbol) onFileStream: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: aString isSt: true.! !!Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 15:09'!hasNoDependenciesForMetaclass: aClass in: unprocessedClasses cache: cache | soleInstance | soleInstance := aClass soleInstance. ^ (unprocessedClasses includes: soleInstance) not and: [ self hasNoSuperclassesOf: soleInstance in: unprocessedClasses cache: cache]! !!Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 14:37'!hasNoSuperclassesOf: aClass in: unprocessedClasses cache: cache ^ (unprocessedClasses includesAnyOf: (self allSuperclassesFor: aClass cache: cache)) not ! !!Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 15:55'!superclassOrder: classes "Arrange the classes in the collection, classes, in superclass order so the classes can be properly filed in. Do it in sets instead of ordered collections." | all unprocessedClasses cache | unprocessedClasses := classes asSet. cache := Dictionary new. all := OrderedCollection new: unprocessedClasses size. unprocessedClasses size timesRepeat: [ |nextClass| nextClass := unprocessedClasses detect: [:aClass | self hasNoDependenciesFor: aClass in: unprocessedClasses cache: cache]. all add: nextClass. unprocessedClasses remove: nextClass]. ^all! !!Class class methodsFor: 'inquiries' stamp: 'StephaneDucasse 3/24/2010 09:49'!rootsOfTheWorld "return all classes that have a nil superclass" ^(Smalltalk globals select: [:each | each isBehavior and: [each superclass isNil]]) asOrderedCollection! !!Class class methodsFor: 'instance creation' stamp: 'di 6/7/2000 22:01'!template: aSystemCategoryName "Answer an expression that can be edited and evaluated in order to define a new class." ^ self templateForSubclassOf: Object name category: aSystemCategoryName ! !!Class class methodsFor: 'instance creation' stamp: 'eem 5/7/2008 12:06'!templateForSubclassOf: priorClassName category: systemCategoryName "Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given" ^priorClassName asString, ' subclass: #NameOfSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , systemCategoryName asString , ''''! !!Class class methodsFor: 'private' stamp: 'SteveFreeman 7/17/2010 15:35'!hasNoDependenciesFor: aClass in: unprocessedClasses cache: cache ^ (self hasNoSuperclassesOf: aClass in: unprocessedClasses cache: cache) and: [ aClass isMeta not or: [ self hasNoDependenciesForMetaclass: aClass in: unprocessedClasses cache: cache]] ! ! ClassDescription subclass: #Metaclass uses: TApplyingOnClassSide instanceVariableNames: 'thisClass traitComposition localSelectors' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!Metaclass commentStamp: '<historical>' prior: 0!My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance. [Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus, Integer superclass == Number, and Integer class superclass == Number class.However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, Object superclass == nil, and Object class superclass == Class.[Subtle detail] A class is know by name to an environment. Typically this is the SystemDictionary named Smalltalk. If we ever make lightweight classes that are not in Smalltalk, they must be in some environment. Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.!!Metaclass methodsFor: '*System-Object Storage' stamp: 'Alexandre.Bergel 8/19/2009 11:16'!objectForDataStream: refStrm | dp | "I am about to be written on an object file. Write a reference to a class in Smalltalk instead." dp := DiskProxy global: self theNonMetaClass name selector: #class args: (Array new). refStrm replace: self with: dp. ^ dp! !!Metaclass methodsFor: '*System-Object Storage' stamp: 'Alexandre.Bergel 8/19/2009 11:16'!storeDataOn: aDataStream "I don't get stored. Use a DiskProxy" self error: 'use a DiskProxy to store a Class'! !!Metaclass methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 11:20'!addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." self deprecated: 'use addInstVarNamed: instead' on: '27 August 2010' in: 'Pharo1.2'. self addInstVarNamed: aString ! !!Metaclass methodsFor: '*deprecated12' stamp: 'StephaneDucasse 8/27/2010 11:21'!removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables." self deprecated: 'use removeInstVarName: instead' on: '27 August 2010' in: 'Pharo1.2'. self removeInstVarNamed: aString ! !!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!basicLocalSelectors "Direct accessor for the instance variable localSelectors. Since localSelectors is lazily initialized, this may return nil, which means that all selectors are local." ^ localSelectors! !!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!basicLocalSelectors: aSetOrNil localSelectors := aSetOrNil! !!Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:19'!environment ^thisClass environment! !!Metaclass methodsFor: 'accessing' stamp: 'al 3/26/2006 11:32'!hasTraitComposition ^traitComposition notNil! !!Metaclass methodsFor: 'accessing'!name "Answer a String that is the name of the receiver, either 'Metaclass' or the name of the receiver's class followed by ' class'." thisClass == nil ifTrue: [^'a Metaclass'] ifFalse: [^thisClass name , ' class']! !!Metaclass methodsFor: 'accessing'!soleInstance "The receiver has only one instance. Answer it." ^thisClass! !!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'!traitComposition traitComposition ifNil: [traitComposition := TraitComposition new]. ^traitComposition! !!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'!traitComposition: aTraitComposition traitComposition := aTraitComposition! !!Metaclass methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:51'!theMetaClass "Sent to a class or metaclass, always return the metaclass" ^self! !!Metaclass methodsFor: 'accessing parallel hierarchy'!theNonMetaClass "Sent to a class or metaclass, always return the class" ^thisClass! !!Metaclass methodsFor: 'as yet unclassified' stamp: 'adrian.lienhard 1/5/2009 23:04'!classVarNames "Answer a set of the names of the class variables defined in the receiver's instance." thisClass ifNil: [ ^ Set new ]. ^thisClass classVarNames! !!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'!addObsoleteSubclass: aClass "Do nothing."! !!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'!addSubclass: aClass "Do nothing."! !!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'!obsoleteSubclasses "Answer the receiver's subclasses." thisClass == nil ifTrue:[^#()]. ^thisClass obsoleteSubclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! !!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'!removeObsoleteSubclass: aClass "Do nothing."! !!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'!removeSubclass: aClass "Do nothing."! !!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/14/1999 11:19'!subclasses "Answer the receiver's subclasses." thisClass == nil ifTrue:[^#()]. ^thisClass subclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! !!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/9/1999 14:11'!subclassesDo: aBlock "Evaluate aBlock for each of the receiver's immediate subclasses." thisClass subclassesDo:[:aSubclass| "The following test is for Class class which has to exclude the Metaclasses being subclasses of Class." aSubclass isMeta ifFalse:[aBlock value: aSubclass class]].! !!Metaclass methodsFor: 'compiling'!acceptsLoggingOfCompilation "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" ^ thisClass acceptsLoggingOfCompilation! !!Metaclass methodsFor: 'compiling' stamp: 'ar 5/18/2003 18:13'!bindingOf: varName ^thisClass classBindingOf: varName! !!Metaclass methodsFor: 'compiling'!possibleVariablesFor: misspelled continuedFrom: oldResults ^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults! !!Metaclass methodsFor: 'compiling'!wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself. 7/12/96 sw" ^ thisClass wantsChangeSetLogging! !!Metaclass methodsFor: 'compiling' stamp: 'sw 7/31/2000 14:29'!wantsRecompilationProgressReported "The metaclass follows the rule of the class itself." ^ thisClass wantsRecompilationProgressReported! !!Metaclass methodsFor: 'composition'!assertConsistantCompositionsForNew: aTraitComposition "Applying or modifying a trait composition on the class side of a behavior has some restrictions." | baseTraits notAddable message | baseTraits := aTraitComposition traits select: [:each | each isBaseTrait]. baseTraits isEmpty ifFalse: [ notAddable := (baseTraits reject: [:each | each classSide methodDict isEmpty]). notAddable isEmpty ifFalse: [ message := String streamContents: [:stream | stream nextPutAll: 'You can not add the base trait(s)'; cr. notAddable do: [:each | stream nextPutAll: each name] separatedBy: [ stream nextPutAll: ', ']. stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.']. ^TraitCompositionException signal: message]]. (self instanceSide traitComposition traits asSet = (aTraitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]) asSet) ifFalse: [ ^TraitCompositionException signal: 'You can not add or remove class side traits on the class side of a composition. (But you can specify aliases or exclusions for existing traits or add a trait which does not have any methods on the class side.)']! !!Metaclass methodsFor: 'composition'!noteNewBaseTraitCompositionApplied: aTraitComposition "The argument is the new trait composition of my base trait - add the new traits or remove non existing traits on my class side composition. (Each class trait in my composition has its base trait on the instance side of the composition - manually added traits to the class side are always base traits.)" | newComposition traitsFromInstanceSide | traitsFromInstanceSide := self traitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]. newComposition := self traitComposition copyTraitExpression. (traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each | newComposition removeFromComposition: each classTrait]. (aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each | newComposition add: (each classTrait)]. self setTraitComposition: newComposition! !!Metaclass methodsFor: 'copying' stamp: 'tk 8/19/1998 16:16'!veryDeepCopyWith: deepCopier "Return self. Must be created, not copied. Do not record me."! !!Metaclass methodsFor: 'fileIn/Out' stamp: 'al 7/4/2009 17:45'!definition "Refer to the comment in ClassDescription|definition." ^ String streamContents: [:strm | strm print: self. (self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [ strm crtab; nextPutAll: 'uses: '; print: self traitComposition ]. strm crtab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString]! !!Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'!fileOutInitializerOn: aStream (self methodDict includesKey: #initialize) ifTrue: [aStream cr. aStream nextChunkPut: thisClass name , ' initialize'].! !!Metaclass methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:31'!fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! !!Metaclass methodsFor: 'fileIn/Out' stamp: 'al 7/19/2004 18:28'!fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. (aBool and:[moveSource not and: [self methodDict includesKey: #initialize]]) ifTrue: [aFileStream cr. aFileStream cr. aFileStream nextChunkPut: thisClass name , ' initialize'. aFileStream cr]! !!Metaclass methodsFor: 'fileIn/Out' stamp: 'jannik.laval 2/5/2010 21:40'!nonTrivial "Answer whether the receiver has any methods or instance variables." ^ self instVarNames notEmpty or: [self hasMethods or: [self hasTraitComposition]]! !!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/13/1999 04:52'!adoptInstance: oldInstance from: oldMetaClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary." thisClass class == self ifTrue:[^self error:'Metaclasses have only one instance']. oldMetaClass isMeta ifFalse:[^self error:'Argument must be Metaclass']. oldInstance class == oldMetaClass ifFalse:[^self error:'Not the class of argument']. ^thisClass := self newInstanceFrom: oldInstance variable: self isVariable size: self instSize map: (self instVarMappingFrom: oldMetaClass)! !!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 18:56'!instanceVariableNames: instVarString "Declare additional named variables for my instance." ^(ClassBuilder new) class: self instanceVariableNames: instVarString! !!Metaclass methodsFor: 'initialize-release' stamp: 'al 7/19/2004 20:49'!uses: aTraitCompositionOrArray instanceVariableNames: instVarString | newComposition newMetaClass copyOfOldMetaClass | copyOfOldMetaClass := self copy. newMetaClass := self instanceVariableNames: instVarString. newComposition := aTraitCompositionOrArray asTraitComposition. newMetaClass assertConsistantCompositionsForNew: newComposition. newMetaClass setTraitComposition: newComposition. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! !!Metaclass methodsFor: 'instance creation' stamp: 'nk 11/9/2003 10:00'!new "The receiver can only have one instance. Create it or complain that one already exists." thisClass class ~~ self ifTrue: [^thisClass := self basicNew] ifFalse: [self error: 'A Metaclass should only have one instance!!']! !!Metaclass methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:19'!addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." | fullString | fullString := String streamContents: [:strm | self instVarNames do: [:aString2 | strm nextPutAll: aString2; space]. strm nextPutAll: aString]. self instanceVariableNames: fullString! !!Metaclass methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:19'!removeInstVarNamed: aString "Remove the argument, aString, as one of the receiver's instance variables." | newArray newString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newArray := self instVarNames copyWithout: aString. newString := ''. newArray do: [:aString2 | newString := aString2 , ' ' , newString]. self instanceVariableNames: newString! !!Metaclass methodsFor: 'pool variables'!classPool "Answer the dictionary of class variables." ^thisClass classPool! !!Metaclass methodsFor: 'testing' stamp: 'ar 9/10/1999 17:41'!canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" thisClass == nil ifTrue:[^true] ifFalse:[^thisClass canZapMethodDictionary]! !!Metaclass methodsFor: 'testing' stamp: 'TestRunner 10/28/2009 11:15'!isAbstractClass ^ self theNonMetaClass isAbstractClass! !!Metaclass methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:59'!isMeta ^ true! !!Metaclass methodsFor: 'testing' stamp: 'ar 7/11/1999 07:27'!isObsolete "Return true if the receiver is obsolete" ^thisClass == nil "Either no thisClass" or:[thisClass class ~~ self "or I am not the class of thisClass" or:[thisClass isObsolete]] "or my instance is obsolete"! !!Metaclass methodsFor: 'testing' stamp: 'nice 11/5/2009 21:57'!isSelfEvaluating ^self isObsolete not! !!Metaclass methodsFor: 'private' stamp: 'ar 3/3/2001 00:20'!replaceObsoleteInstanceWith: newInstance thisClass class == self ifTrue:[^self error:'I am fine, thanks']. newInstance class == self ifFalse:[^self error:'Not an instance of me']. thisClass := newInstance.! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!"TODO Removed for load testMetaclass class uses: TApplyingOnClassSide classTrait instanceVariableNames: ''"! Object subclass: #Categorizer instanceVariableNames: 'categoryArray categoryStops elementArray' classVariableNames: 'Default NullCategory' poolDictionaries: '' category: 'Kernel-Classes'!!Categorizer commentStamp: 'StephaneDucasse 5/9/2010 20:11' prior: 0!A Categorizer is responsible to manage the class categories and method protocols. Instances consist of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories := Array with: 'firstCat' with: 'secondCat' with: 'thirdCat'. stops := Array with: 1 with: 4 with: 4. elements := Array with: #a with: #b with: #c with: #d. This means that category firstCat has only #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size. Instance Variables categoryArray: <SequenceableCollection of: Object> categoryStops: <SequenceableCollection of: Integer> elementArray: <SequenceableCollection of: Object>categoryArray - holds the list of categories. A category could be any Object but is generally a String or Symbol. Categories should be unique (categoryArray asSet size = categoryArray size)categoryStops - holds the index of last element belonging to each category. There should be a category stop for each category (categoryStops size = categoryArray size). The categoryStops should be sorted (categoryStops sorted = categoryStops). A category stop equal to its predecessor (= 0 for the first category stop) denotes an empty category.elementArray - holds the elements to be classified. The elements are sorted by category.Class variables Default is the default category used to classify yet unclassified methods of a class NullCategory is the category to be displayed in a Browser for a class having no method.!!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!addCategory: newCategory ^ self addCategory: newCategory before: nil ! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!addCategory: catString before: nextCategory "Add a new category named heading. If default category exists and is empty, remove it. If nextCategory is nil, then add the new one at the end, otherwise, insert it before nextCategory." | index newCategory | newCategory := catString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^self]. "heading already exists, so done" index := categoryArray indexOf: nextCategory ifAbsent: [categoryArray size + 1]. categoryArray := categoryArray copyReplaceFrom: index to: index-1 with: (Array with: newCategory). categoryStops := categoryStops copyReplaceFrom: index to: index-1 with: (Array with: (index = 1 ifTrue: [0] ifFalse: [categoryStops at: index-1])). "remove empty default category" (newCategory ~= Default and: [(self listAtCategoryNamed: Default) isEmpty]) ifTrue: [self removeCategory: Default]! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!allMethodSelectors "give a list of all method selectors." ^ elementArray copy sort! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:29'!categories "Answer an Array of categories (names)." categoryArray isNil ifTrue: [^ nil]. (categoryArray size = 1 and: [categoryArray first = Default & (elementArray size = 0)]) ifTrue: [^Array with: NullCategory]. ^categoryArray! !!Categorizer methodsFor: 'accessing' stamp: 'mtf 1/19/2009 15:00'!categories: anArray "Reorder my categories to be in order of the argument, anArray. If the resulting organization does not include all elements, then give an error." | newCategories newStops newElements catName list runningTotal | anArray size < 2 ifTrue: [ ^ self ]. newCategories := Array new: anArray size. newStops := Array new: anArray size. newElements := Array new: 0. runningTotal := 0. 1 to: anArray size do: [:i | catName := (anArray at: i) asSymbol. list := self listAtCategoryNamed: catName. newElements := newElements, list. newCategories at: i put: catName. newStops at: i put: (runningTotal := runningTotal + list size)]. elementArray do: [:element | "check to be sure all elements are included" (newElements includes: element) ifFalse: [^self error: 'New categories must match old ones']]. "Everything is good, now update my three arrays." categoryArray := newCategories. categoryStops := newStops. elementArray := newElements! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!categoryOfElement: element "Answer the category associated with the argument, element." | index | index := self numberOfCategoryOfElement: element. index = 0 ifTrue: [^nil] ifFalse: [^categoryArray at: index]! !!Categorizer methodsFor: 'accessing' stamp: 'nice 1/5/2010 20:01'!changeFromCategorySpecs: categorySpecs "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." | newCategories newStops temp cc currentStop oldElements newElements | oldElements := elementArray asSet. newCategories := Array new: categorySpecs size. newStops := Array new: categorySpecs size. currentStop := 0. newElements := (Array new: 16) writeStream. 1 to: categorySpecs size do: [:i | | selectors catSpec | catSpec := categorySpecs at: i. newCategories at: i put: catSpec first asSymbol. selectors := catSpec allButFirst collect: [:each | each isSymbol ifTrue: [each] ifFalse: [each printString asSymbol]]. selectors asSortedCollection do: [:elem | (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue: [newElements nextPut: elem. currentStop := currentStop+1]]. newStops at: i put: currentStop]. "Ignore extra elements but don't lose any existing elements!!" oldElements := oldElements collect: [:elem | Array with: (self categoryOfElement: elem) with: elem]. newElements := newElements contents. categoryArray := newCategories. (cc := categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element" temp := categoryArray asOrderedCollection. temp removeAll: categoryArray asSet asOrderedCollection. temp do: [:dup | | tmp ii | tmp := dup. ii := categoryArray indexOf: tmp. [tmp := (tmp,' #2') asSymbol. cc includes: tmp] whileTrue. cc add: tmp. categoryArray at: ii put: tmp]]. categoryStops := newStops. elementArray := newElements. oldElements do: [:pair | self classify: pair last under: pair first].! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs := Scanner new scanTokens: aString. "If nothing was scanned and I had no elements before, then default me" (categorySpecs isEmpty and: [elementArray isEmpty]) ifTrue: [^ self setDefaultList: Array new]. ^ self changeFromCategorySpecs: categorySpecs! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!classify: element under: heading self classify: element under: heading suppressIfDefault: true! !!Categorizer methodsFor: 'accessing' stamp: 'al 11/28/2005 22:05'!classify: element under: heading suppressIfDefault: aBoolean "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" | catName catIndex elemIndex realHeading | ((heading = NullCategory) or: [heading == nil]) ifTrue: [realHeading := Default] ifFalse: [realHeading := heading asSymbol]. (catName := self categoryOfElement: element) = realHeading ifTrue: [^ self]. "done if already under that category" catName ~~ nil ifTrue: [(aBoolean and: [realHeading = Default]) ifTrue: [^ self]. "return if non-Default category already assigned in memory" self basicRemoveElement: element]. "remove if in another category" (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. catIndex := categoryArray indexOf: realHeading. elemIndex := catIndex > 1 ifTrue: [categoryStops at: catIndex - 1] ifFalse: [0]. [(elemIndex := elemIndex + 1) <= (categoryStops at: catIndex) and: [element >= (elementArray at: elemIndex)]] whileTrue. "elemIndex is now the index for inserting the element. Do the insertion before it." elementArray := elementArray copyReplaceFrom: elemIndex to: elemIndex-1 with: (Array with: element). "add one to stops for this and later categories" catIndex to: categoryArray size do: [:i | categoryStops at: i put: (categoryStops at: i) + 1]. ((categoryArray includes: Default) and: [(self listAtCategoryNamed: Default) size = 0]) ifTrue: [self removeCategory: Default]. self assertInvariant.! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!classifyAll: aCollection under: heading aCollection do: [:element | self classify: element under: heading]! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:20'!elementCategoryDict | dict firstIndex lastIndex | elementArray isNil ifTrue: [^ nil]. dict := Dictionary new: elementArray size. 1to: categoryStops size do: [:cat | firstIndex := self firstIndexOfCategoryNumber: cat. lastIndex := self lastIndexOfCategoryNumber: cat. firstIndex to: lastIndex do: [:el | dict at: (elementArray at: el) put: (categoryArray at: cat)]. ]. ^ dict.! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'!isEmptyCategoryNamed: categoryName | i | i := categoryArray indexOf: categoryName ifAbsent: [^false]. ^self isEmptyCategoryNumber: i! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'!isEmptyCategoryNumber: anInteger | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ true]. firstIndex := self firstIndexOfCategoryNumber: anInteger. lastIndex := self lastIndexOfCategoryNumber: anInteger. ^ firstIndex > lastIndex! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!listAtCategoryNamed: categoryName "Answer the array of elements associated with the name, categoryName." | i | i := categoryArray indexOf: categoryName ifAbsent: [^Array new]. ^self listAtCategoryNumber: i! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 13:51'!listAtCategoryNumber: anInteger "Answer the array of elements stored at the position indexed by anInteger. Answer nil if anInteger is larger than the number of categories." | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ nil]. firstIndex := self firstIndexOfCategoryNumber: anInteger. lastIndex := self lastIndexOfCategoryNumber: anInteger. ^elementArray copyFrom: firstIndex to: lastIndex! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!numberOfCategoryOfElement: element "Answer the index of the category with which the argument, element, is associated." | categoryIndex elementIndex | categoryIndex := 1. elementIndex := 0. [(elementIndex := elementIndex + 1) <= elementArray size] whileTrue: ["point to correct category" [elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryIndex := categoryIndex + 1]. "see if this is element" element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. ^0! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!removeCategory: cat "Remove the category named, cat. Create an error notificiation if the category has any elements in it." | index lastStop | index := categoryArray indexOf: cat ifAbsent: [^self]. lastStop := index = 1 ifTrue: [0] ifFalse: [categoryStops at: index - 1]. (categoryStops at: index) - lastStop > 0 ifTrue: [^self error: 'cannot remove non-empty category']. categoryArray := categoryArray copyReplaceFrom: index to: index with: Array new. categoryStops := categoryStops copyReplaceFrom: index to: index with: Array new. categoryArray size = 0 ifTrue: [categoryArray := Array with: Default. categoryStops := Array with: 0]! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:50'!removeElement: element ^ self basicRemoveElement: element! !!Categorizer methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 00:16'!removeEmptyCategories "Remove empty categories." | categoryIndex currentStop keptCategories keptStops | keptCategories := (Array new: 16) writeStream. keptStops := (Array new: 16) writeStream. currentStop := categoryIndex := 0. [(categoryIndex := categoryIndex + 1) <= categoryArray size] whileTrue: [(categoryStops at: categoryIndex) > currentStop ifTrue: [keptCategories nextPut: (categoryArray at: categoryIndex). keptStops nextPut: (currentStop := categoryStops at: categoryIndex)]]. categoryArray := keptCategories contents. categoryStops := keptStops contents. categoryArray size = 0 ifTrue: [categoryArray := Array with: Default. categoryStops := Array with: 0] "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!renameCategory: oldCatString toBe: newCatString "Rename a category. No action if new name already exists, or if old name does not exist." | index oldCategory newCategory | oldCategory := oldCatString asSymbol. newCategory := newCatString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^ self]. "new name exists, so no action" (index := categoryArray indexOf: oldCategory) = 0 ifTrue: [^ self]. "old name not found, so no action" categoryArray := categoryArray copy. "need to change identity so smart list update will notice the change" categoryArray at: index put: newCategory! !!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!sortCategories | privateCategories publicCategories newCategories | privateCategories := self categories select: [:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1]. publicCategories := self categories copyWithoutAll: privateCategories. newCategories := publicCategories asSortedCollection asOrderedCollection addAll: privateCategories asSortedCollection; asArray. self categories: newCategories! !!Categorizer methodsFor: 'actions' stamp: 'StephaneDucasse 7/7/2010 18:58'!moveCategory: sourceCategory to: destinationCategory self classifyAll: (self listAtCategoryNamed: sourceCategory) under: destinationCategory. self removeCategory: sourceCategory.! !!Categorizer methodsFor: 'fileIn/Out' stamp: 'NS 4/5/2004 17:44'!scanFrom: aStream "Reads in the organization from the next chunk on aStream. Categories or elements not found in the definition are not affected. New elements are ignored." self changeFromString: aStream nextChunk. aStream skipStyleChunk.! !!Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'!printOn: aStream "Refer to the comment in Object|printOn:." | elementIndex | elementIndex := 1. 1 to: categoryArray size do: [:i | aStream nextPut: $(. (categoryArray at: i) asString printOn: aStream. [elementIndex <= (categoryStops at: i)] whileTrue: [aStream space; nextPutAll: (elementArray at: elementIndex). elementIndex := elementIndex + 1]. aStream nextPut: $); cr]! !!Categorizer methodsFor: 'printing' stamp: 'lr 6/22/2005 08:12'!printString ^ String streamContents: [ :stream | self printOn: stream ].! !!Categorizer methodsFor: 'private' stamp: 'jannik.laval 5/1/2010 16:01'!assertInvariant [elementArray size = categoryStops last] assert! !!Categorizer methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 00:15'!basicRemoveElement: element "Remove the selector, element, from all categories." | categoryIndex elementIndex nextStop newElements | categoryIndex := 1. elementIndex := 0. nextStop := 0. "nextStop keeps track of the stops in the new element array" newElements := (Array new: elementArray size) writeStream. [(elementIndex := elementIndex + 1) <= elementArray size] whileTrue: [[elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex := categoryIndex + 1]. (elementArray at: elementIndex) = element ifFalse: [nextStop := nextStop + 1. newElements nextPut: (elementArray at: elementIndex)]]. [categoryIndex <= categoryStops size] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex := categoryIndex + 1]. elementArray := newElements contents. self assertInvariant.! !!Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:51'!firstIndexOfCategoryNumber: anInteger anInteger < 1 ifTrue: [^ nil]. ^ (anInteger > 1 ifTrue: [(categoryStops at: anInteger - 1) + 1] ifFalse: [1]).! !!Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:52'!lastIndexOfCategoryNumber: anInteger anInteger > categoryStops size ifTrue: [^ nil]. ^ categoryStops at: anInteger! !!Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:50'!setDefaultList: aSortedCollection categoryArray := Array with: Default. categoryStops := Array with: aSortedCollection size. elementArray := aSortedCollection asArray! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!"TODO removed for load testCategorizer class instanceVariableNames: ''"!!Categorizer class methodsFor: 'class initialization' stamp: 'eem 1/7/2009 16:04'!allCategory "Return a symbol that represents the virtual all methods category." ^#'-- all --'! !!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'!default ^ Default! !!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/6/2004 11:48'!initialize " self initialize " Default := 'as yet unclassified' asSymbol. NullCategory := 'no messages' asSymbol.! !!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'!nullCategory ^ NullCategory! !!Categorizer class methodsFor: 'documentation' stamp: 'NS 4/5/2004 17:44'!documentation "Instances consist of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories := Array with: 'firstCat' with: 'secondCat' with: 'thirdCat'. stops := Array with: 1 with: 4 with: 4. elements := Array with: #a with: #b with: #c with: #d. This means that category firstCat has only #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size." ! !!Categorizer class methodsFor: 'housekeeping' stamp: 'NS 4/6/2004 11:48'!sortAllCategories self allSubInstances do: [:x | x sortCategories]! !!Categorizer class methodsFor: 'instance creation' stamp: 'NS 4/5/2004 17:44'!defaultList: aSortedCollection "Answer an instance of me with initial elements from the argument, aSortedCollection." ^self new setDefaultList: aSortedCollection! ! Categorizer subclass: #BasicClassOrganizer instanceVariableNames: 'subject classComment commentStamp' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!BasicClassOrganizer methodsFor: '*System-Object Storage' stamp: 'Alexandre.Bergel 8/19/2009 11:13'!objectForDataStream: refStrm | dp | "I am about to be written on an object file. Write a path to me in the other system instead." self hasSubject ifTrue: [ (self subject isKindOf: Class) ifTrue: [ dp := DiskProxy global: self subject name selector: #organization args: #(). refStrm replace: self with: dp. ^ dp]]. ^ self "in desparation"! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'Sd 1/28/2011 14:35'!classComment classComment ifNil: [^ '']. ^ classComment string ifNil: ['']! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'!classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [aString isEmptyOrNil ifTrue: [classComment := nil] ifFalse: [ self error: 'use aClass classComment:'. classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'!classComment: aString stamp: aStamp "Store the comment, aString, associated with the object that refers to the receiver." self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [aString isEmptyOrNil ifTrue: [classComment := nil] ifFalse: [self error: 'use aClass classComment:'. classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!commentRemoteStr ^ classComment! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!commentStamp "Answer the comment stamp for the class" ^ commentStamp! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!commentStamp: aStamp commentStamp := aStamp! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!dateCommentLastSubmitted "Answer a Date object indicating when my class comment was last submitted. If there is no date stamp, or one of the old-time <historical> guys, return nil" "RecentMessageSet organization dateCommentLastSubmitted" | aStamp tokens | (aStamp := self commentStamp) isEmptyOrNil ifTrue: [^ nil]. tokens := aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 7/29/2009 15:26'!hasComment "Answer whether the class classified by the receiver has a comment." ^classComment notNil! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'!hasSubject ^ self subject notNil! !!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'!subject ^ subject.! !!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'DamienCassou 5/14/2011 17:19'!fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | classComment ifNotNil: [aFileStream cr. fileComment := RemoteString newString: classComment string onFileNumber: fileIndex toFile: aFileStream. moveSource ifTrue: [classComment := fileComment]]! !!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'!putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass "Store the comment about the class onto file, aFileStream." | header | classComment ifNotNil: [aFileStream cr; nextPut: $!!. header := String streamContents: [:strm | strm nextPutAll: aClass name; nextPutAll: ' commentStamp: '. commentStamp ifNil: [commentStamp := '<historical>']. commentStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. aFileStream nextChunkPut: header. aClass organization fileOutCommentOn: aFileStream moveSource: moveSource toFile: sourceIndex. aFileStream cr]! !!BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'!setSubject: aClassDescription subject := aClassDescription! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!"TODO Removed for testBasicClassOrganizer class instanceVariableNames: ''"!!BasicClassOrganizer class methodsFor: 'constants' stamp: 'NS 4/19/2004 15:52'!ambiguous ^ #ambiguous! !!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'!class: aClassDescription ^ self new setSubject: aClassDescription! !!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'!class: aClassDescription defaultList: aSortedCollection | inst | inst := self defaultList: aSortedCollection. inst setSubject: aClassDescription. ^ inst! ! BasicClassOrganizer subclass: #ClassOrganizer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!ClassOrganizer commentStamp: 'NS 4/6/2004 16:13' prior: 0!I represent method categorization information for classes. The handling of class comments has gone through a tortuous evolution. Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted. Such grandfathered comments now go out on fileouts with '<historical>' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments. Everything in good time!!!!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!addCategory: catString before: nextCategory | oldCategories | oldCategories := self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super addCategory: catString before: nextCategory]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:28'!changeFromCategorySpecs: categorySpecs | oldDict oldCategories | oldDict := self elementCategoryDict. oldCategories := self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super changeFromCategorySpecs: categorySpecs]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!classify: element under: heading suppressIfDefault: aBoolean | oldCat newCat | oldCat := self categoryOfElement: element. SystemChangeNotifier uniqueInstance doSilently: [ super classify: element under: heading suppressIfDefault: aBoolean]. newCat := self categoryOfElement: element. self notifyOfChangedSelector: element from: oldCat to: newCat.! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!removeCategory: cat | oldCategories | oldCategories := self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super removeCategory: cat]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!removeElement: element | oldCat | oldCat := self categoryOfElement: element. SystemChangeNotifier uniqueInstance doSilently: [ super removeElement: element]. self notifyOfChangedSelector: element from: oldCat to: (self categoryOfElement: element).! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'!removeEmptyCategories | oldCategories | oldCategories := self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super removeEmptyCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'!renameCategory: oldCatString toBe: newCatString | oldCat newCat oldElementsBefore oldElementsAfter | oldCat := oldCatString asSymbol. newCat := newCatString asSymbol. oldElementsBefore := self listAtCategoryNamed: oldCat. SystemChangeNotifier uniqueInstance doSilently: [ super renameCategory: oldCatString toBe: newCatString]. oldElementsAfter := (self listAtCategoryNamed: oldCat) asSet. oldElementsBefore do: [:each | (oldElementsAfter includes: each) ifFalse: [self notifyOfChangedSelector: each from: oldCat to: newCat]. ]. self notifyOfChangedCategoryFrom: oldCat to: newCat.! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:57'!setDefaultList: aSortedCollection | oldDict oldCategories | oldDict := self elementCategoryDict. oldCategories := self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super setDefaultList: aSortedCollection]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'!sortCategories | oldCategories | oldCategories := self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super sortCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 10:15'!notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil (self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! !!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 23:02'!notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil (self hasSubject and: [oldNameOrNil ~= newNameOrNil]) ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! !!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/16/2004 10:47'!notifyOfChangedSelector: element from: oldCategory to: newCategory (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ self subject notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. ].! !!ClassOrganizer methodsFor: 'private' stamp: 'eem 6/11/2008 17:00'!notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) ifTrue: [^ self]. oldDictionaryOrNil isNil ifTrue: [ newDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: nil to: cat]. ^ self. ]. newDictionaryOrNil isNil ifTrue: [ oldDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: cat to: nil]. ^ self. ]. oldDictionaryOrNil keysAndValuesDo: [:el :cat | | newCat | newCat := newDictionaryOrNil at: el. self notifyOfChangedSelector: el from: cat to: newCat. ].! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!"TODO Removed for testsClassOrganizer class instanceVariableNames: ''"!!ClassOrganizer class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 22:21'!cleanUp: aggressive "Remove empty method categories when cleaning aggressively" aggressive ifTrue: [Smalltalk removeEmptyMessageCategories].! ! Object subclass: #ClassCategoryReader instanceVariableNames: 'class category changeStamp' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!ClassCategoryReader commentStamp: '<historical>' prior: 0!I represent a mechanism for retrieving class descriptions stored on a file.!!ClassCategoryReader methodsFor: '*System-Object Storage' stamp: 'RAA 6/22/2000 16:08'!scanFromNoCompile: aStream forSegment: anImageSegment ^self scanFromNoCompile: aStream "subclasses may care about the segment"! !!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'al 11/28/2005 22:10'!scanFrom: aStream "File in methods from the stream, aStream." | methodText | [methodText := aStream nextChunkText. methodText size > 0] whileTrue: [class compile: methodText classified: category withStamp: changeStamp notifying: nil]! !!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 23:24'!scanFromNoCompile: aStream "Just move the source code for the methods from aStream." | methodText selector | [methodText := aStream nextChunkText. methodText size > 0] whileTrue: [(SourceFiles at: 2) ifNotNil: [ selector := class parserClass new parseSelector: methodText. (class compiledMethodAt: selector) putSource: methodText fromParseNode: nil class: class category: category withStamp: changeStamp inFile: 2 priorMethod: nil]]! !!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!setClass: aClass category: aCategory ^ self setClass: aClass category: aCategory changeStamp: String new! !!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!setClass: aClass category: aCategory changeStamp: aString class := aClass. category := aCategory. changeStamp := aString! !!ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'!theClass ^ class! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!"TODO Removed for testsClassCategoryReader class instanceVariableNames: ''"! ClassCategoryReader subclass: #ClassCommentReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'!!ClassCommentReader methodsFor: 'fileIn/Out' stamp: 'sw 7/31/2002 10:40'!scanFrom: aStream "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." class theNonMetaClass classComment: (aStream nextChunkText) stamp: changeStamp "Writes it on the disk and saves a RemoteString ref"! !!ClassCommentReader methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 22:56'!scanFromNoCompile: aStream "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." self scanFrom: aStream. "for comments, the same as usual"! !"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!"TODO Removed for testClassCommentReader class instanceVariableNames: ''"!!ClassCommentReader class methodsFor: 'instance creation' stamp: 'AndrewBlack 9/1/2009 06:42'!forClass: aClass ^ self new setClass: aClass category: #Comment ! !"TODO Removed for testBehavior initialize"!"TODO Removed for testCategorizer initialize"!