--- a/Metaclass.st Mon Oct 08 11:17:34 2001 +0200
+++ b/Metaclass.st Mon Oct 08 11:18:15 2001 +0200
@@ -714,997 +714,12 @@
^ newClass
"Modified: 1.4.1997 / 15:44:50 / stefan"
-!
-
-xx_name:newName in:aSystemDictionaryOrClass
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- variable:variableBoolean
- words:wordsBoolean
- pointers:pointersBoolean
- classVariableNames:stringOfClassVarNames
- poolDictionaries:stringOfPoolNames
- category:categoryString
- comment:commentString
- changed:changed
- classInstanceVariableNames:stringOfClassInstVarNamesOrNil
-
- "this is the main workhorse for installing new classes - special care
- has to be taken, when changing an existing classes definition. In this
- case, some or all of the methods and subclasses methods have to be
- recompiled.
- Also, the old class(es) are still kept (but not accessable as a global),
- to allow existing instances some life.
- This might change in the future.
- "
-
- |newClass newMetaclass nInstVars nameString classSymbol nameKey oldClass
- classVarChange instVarChange superClassChange newComment
- changeSet1 changeSet2 addedNames
- anyChange oldInstVars newInstVars oldClassVars newClassVars superFlags newFlags
- pkg oldPkg idx spec nClassInstVars
- realNewName thisIsPrivate oldCIVNames newCIVNames nsName namespace
- oldSuperClass newSuperClass oldCategory
- recompileGlobalAccessTo stringOfClassInstVarNames answer
- oldClassToBecomeNew|
-
- "NOTICE:
- this method is too complex and should be splitted into managable pieces ...
- I dont like it anymore :-)
- (well, at least, its a good test for the compilers ability
- to handle big, complex methods ;-)
- take it as an example of bad coding style ...
-
- ST-80 uses a ClassBuilder object to collect the work and perform all updates;
- this method may be changed to do something similar in the future ...
- "
-
- (newName isSymbol not
- or:[newName size == 0]) ifTrue:[
- self error:'invalid class name (must be a nonEmpty symbol)'.
- ].
- newName first isLetter ifFalse:[
- self error:'invalid class name (must start with a letter)'.
- ].
-
- "check for invalid subclassing of UndefinedObject and SmallInteger"
- aClass notNil ifTrue:[
- aClass canBeSubclassed ifFalse:[
- self error:('it is not possible to subclass ' , aClass name).
- ]
- ].
-
- "/ owner must be loaded
- (aSystemDictionaryOrClass notNil and:[aSystemDictionaryOrClass isLoaded not]) ifTrue:[
- aSystemDictionaryOrClass autoload
- ].
-
- (stringOfInstVarNames size > 0
- or:[stringOfClassVarNames size > 0]) ifTrue:[
- "
- Check for invalid variable names (duplicates)
- "
- (self
- checkValidVarNamesFor:newName
- subClassOf:aClass
- instVarNames:stringOfInstVarNames
- classVarNames:stringOfClassVarNames)
- ifFalse:[
- ^ nil
- ].
- nInstVars := stringOfInstVarNames countWords.
- ] ifFalse:[
- nInstVars := 0.
- ].
-
- nameString := newName asString.
- classSymbol := newName asSymbol.
- newComment := commentString.
-
- namespace := aSystemDictionaryOrClass.
- nameKey := classSymbol.
-
- (namespace notNil
- and:[namespace isNameSpace not]) ifTrue:[
- thisIsPrivate := true.
- realNewName := (namespace name , '::' , classSymbol) asSymbol.
- ] ifFalse:[
- thisIsPrivate := false.
- realNewName := classSymbol.
-
- "/ does the name imply a nameSpace ?
- ((idx := realNewName indexOf:$:)) ~~ 0 ifTrue:[
- "/ check for this namespace to exist
- nsName := realNewName copyTo:(idx - 1).
- nsName := nsName asSymbol.
- (realNewName indexOf:$: startingAt:(idx+2)) ~~ 0 ifTrue:[
- self warn:('nested namespaces are not (yet) implemented.') withCRs.
- ^ nil
- ].
-
- namespace := Smalltalk at:nsName ifAbsent:nil.
- namespace isNameSpace ifFalse:[
- namespace isNil ifTrue:[
- (Class createNameSpaceQuerySignal query
- or:[(self
- confirm:('nonexistent namespace: `' , nsName , '''.\\Create ?') withCRs)])
- ifFalse:[^ nil].
- namespace := NameSpace name:nsName.
- ] ifFalse:[
- self warn:('a global named ' , nsName , ' exists, but is no namespace.') withCRs.
- ^ nil
- ]
- ].
- namespace isNameSpace ifTrue:[
- nameKey := (classSymbol copyFrom:(nsName size + 3)) asSymbol.
- ]
- ] ifFalse:[
- (namespace notNil and:[namespace ~~ Smalltalk]) ifTrue:[
- realNewName := (namespace name , '::' , classSymbol) asSymbol.
- ]
- ]
- ].
-
- (aClass notNil and:[realNewName = aClass name]) ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
- ].
-
- "look, if it already exists as a class"
- namespace notNil ifTrue:[
- thisIsPrivate ifFalse:[
- oldClass := namespace at:nameKey ifAbsent:[nil].
- ] ifTrue:[
- oldClass := namespace privateClassesAt:classSymbol.
- ]
- ].
-
- (oldClass isBehavior and:[oldClass isLoaded not]) ifTrue:[
- oldClassToBecomeNew := oldClass
- ].
-
- (oldClass isBehavior and:[oldClass isLoaded]) ifFalse:[
- oldClass := nil.
-
- thisIsPrivate ifTrue:[
- Compiler warnSTXSpecials ifTrue:[
- (self confirm:('support for private classes is an ST/X extension.\\continue ?') withCRs)
- ifFalse:[^ nil].
- ]
- ].
- ] ifTrue:[
- oldClass name ~= realNewName ifTrue:[
- (self confirm:(classSymbol , ' is an alias for ' , oldClass name , '\\continue ?') withCRs)
- ifFalse:[^ nil].
- oldClass := nil
- ] ifFalse:[
- "/
- "/ some consisteny checks
- "/
- oldClass allSuperclasses do:[:cls |
- cls name = realNewName ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
- ]
- ].
-
- aClass notNil ifTrue:[
- aClass allSuperclasses do:[:cls |
- cls name = realNewName ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
- ]
- ].
- ].
-
- newComment isNil ifTrue:[
- newComment := oldClass comment
- ].
-
- "
- warn, if it exists with different category and different instvars,
- and the existing is not an autoload class.
- Usually, this indicates that someone wants to create a new class with
- a name, which already exists (it happened a few times to myself, while
- I wanted to create a new class called ReturnNode ...).
- This will be much less of a problem, once multiple name spaces are
- implemented and classes can be put into separate packages.
- "
- oldClass isLoaded ifTrue:[
- oldClass category ~= categoryString ifTrue:[
- oldClass instanceVariableString asCollectionOfWords
- ~= stringOfInstVarNames asCollectionOfWords ifTrue:[
- (self confirm:'a class named ' , oldClass name ,
- ' already exists -\\create (i.e. change) anyway ?' withCRs)
- ifFalse:[
- ^ nil
- ]
- ]
- ]
- ].
-
- "/
- "/ hints - warn, if creating a variableSubclass of a Set
- "/ (common error - containers in ST/X do not use variable-slots)
- "/
- ((variableBoolean == true) and:[pointersBoolean]) ifTrue:[
- (oldClass isKindOf:Set class) ifTrue:[
- (self confirm:'ST/X Set & Dictionary are not variable-classes\create anyway ?' withCRs)
- ifFalse:[
- ^ nil
- ]
- ]
- ]
- ]
- ].
-
- "/ Check for some 'considered bad-style' things, like lower case names.
- "/ But only do these checks for new classes -
- "/ - thus, once confirmed, the warnings will not come again and again.
-
- "/ NOTICE:
- "/ I dont like the confirmers there - we need a notifying: argument, to give
- "/ the outer codeview a chance to highlight the error.
- "/ (but thats how its defined in the book - maybe I will change anyway).
- "/ - or use upQueries in future versions.
-
- oldClass isNil ifTrue:[
- (stringOfInstVarNames size > 0
- or:[stringOfClassVarNames size > 0]) ifTrue:[
- (self
- checkConventionsFor:newName
- subClassOf:aClass
- instVarNames:stringOfInstVarNames
- classVarNames:stringOfClassVarNames)
- ifFalse:[
- ^ nil
- ]
- ].
-
- (self
- checkInstvarRedefsWith:stringOfInstVarNames
- subclassOf:aClass
- old:oldClass
- name:newName) ifFalse:[^ nil].
- ].
-
- stringOfClassInstVarNamesOrNil isNil ifTrue:[
- oldClass isNil ifTrue:[
- stringOfClassInstVarNames := ''
- ] ifFalse:[
- stringOfClassInstVarNames := oldClass class instanceVariableString
- ]
- ] ifFalse:[
- stringOfClassInstVarNames := stringOfClassInstVarNamesOrNil
- ].
-
- nClassInstVars := stringOfClassInstVarNames countWords.
-
- "create the metaclass first"
- thisIsPrivate ifTrue:[
- newMetaclass := PrivateMetaclass new
- ] ifFalse:[
- newMetaclass := Metaclass new.
- ].
- aClass isNil ifTrue:[
- newMetaclass setSuperclass:Class.
- newMetaclass instSize:(Class instSize + nClassInstVars).
- ] ifFalse:[
- newMetaclass setSuperclass:(aClass class).
- newMetaclass instSize:(aClass class instSize + nClassInstVars).
- ].
-"/ newMetaclass classVariableString:''.
- newMetaclass setInstanceVariableString:stringOfClassInstVarNames.
-
- "then let the new meta create the class"
- newClass := newMetaclass new.
- newClass setSuperclass:aClass.
- aClass isNil ifTrue:[
- newClass instSize:nInstVars.
- ] ifFalse:[
- newClass instSize:(aClass instSize + nInstVars).
- ].
-
- thisIsPrivate ifTrue:[
- "/ some private class
- newMetaclass setOwningClass:namespace.
- ].
-
- (namespace notNil
- and:[namespace ~~ Smalltalk]) ifTrue:[
- newClass setName:realNewName.
- "/
- "/ if that key exists in smalltalk,
- "/ must recompile everything in that nameSpace,
- "/ which refers to the unprefixed global.
- "/
- recompileGlobalAccessTo := nameKey.
- ] ifFalse:[
- newClass setName:classSymbol.
- recompileGlobalAccessTo := nil.
- ].
-
- newClass setComment:newComment category:categoryString.
-
- oldClass notNil ifTrue:[
- "/ copy over classInstanceVariables
- "/ but not those inherited from class
-
- oldCIVNames := oldClass class allInstVarNames asSet.
- newCIVNames := newClass class allInstVarNames asSet.
- Class class allInstVarNames do:[:n |
- oldCIVNames remove:n ifAbsent:nil.
- newCIVNames remove:n ifAbsent:nil.
- ].
-
- newCIVNames size > 0 ifTrue:[
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript show:'preserving classInstVar values: '; showCR:newCIVNames.
-"/ ].
- newCIVNames do:[:n |
- (oldCIVNames includes:n) ifTrue:[
- newClass instVarNamed:n put:(oldClass instVarNamed:n)
- ]
- ]
- ].
- ].
-
- "/ set the new classes package
- "/ but be careful here ...
-
- oldClass isNil ifTrue:[
- "/ new classes get the current package ...
- pkg := Class packageQuerySignal query.
- ] ifFalse:[
- newClass setClassFilename:(oldClass classFilename).
-
- oldPkg := oldClass package.
- oldClass isLoaded ifFalse:[
- "/ autoloaded classes get the package of the autoload stub ...
- pkg := oldPkg
- ] ifTrue:[
- "/ not autoloading, check for packageRedef ...
-
- pkg := Class packageQuerySignal query.
- oldPkg ~= pkg ifTrue:[
- newClass package:pkg.
- answer := Class classRedefinitionSignal
- raiseRequestWith:(oldClass -> newClass)
- errorString:('redefinition of class: ' , oldClass name).
- answer == #keep ifTrue:[
- "/ keep old package
- pkg := oldPkg.
- ] ifFalse:[
- answer ~~ #continue ifTrue:[
- "/ cancel
- ^ nil
- ].
- "/ take new package
- ].
- ].
- newClass setBinaryRevision:(oldClass binaryRevision).
- ].
- ].
- pkg notNil ifTrue:[
-"/ Transcript showCR:('set package of class: ' , newClass name , ' to ' , pkg printString).
- newClass package:pkg.
- ].
-
- "/ Allowing non-booleans as variableBoolean
- "/ is a hack for backward (ST-80) compatibility:
- "/ ST-80 code will pass true or false as variableBoolean,
- "/ while ST/X also calls it with symbols such as #float, #double etc.
-
- (variableBoolean == true) ifTrue:[
- pointersBoolean ifTrue:[
- newFlags := Behavior flagPointers
- ] ifFalse:[
- wordsBoolean ifTrue:[
- newFlags := Behavior flagWords
- ] ifFalse:[
- newFlags := Behavior flagBytes
- ]
- ]
- ] ifFalse:[
- "/ false or symbol.
- newFlags := Behavior flagForSymbolic:variableBoolean.
- ].
- aClass isNil ifTrue:[
- superFlags := 0
- ] ifFalse:[
- superFlags := aClass flags bitAnd:(Behavior maskIndexType bitInvert). "preserve other bits"
- ].
-
- oldClass notNil ifTrue:[
- oldClass isBuiltInClass ifTrue:[
- "
- special care when redefining Method, Block and other built-in classes,
- which might have other flag bits ...
- "
-
- newFlags := newFlags bitOr:(oldClass flags bitAnd:(Behavior maskIndexType bitInvert))
- ]
- ].
- newClass flags:(newFlags bitOr:superFlags). "preserve inherited special bits"
-
- (nInstVars ~~ 0) ifTrue:[
- newClass setInstanceVariableString:stringOfInstVarNames
- ].
- oldClass notNil ifTrue:[
-
- "/ setting first will make new class clear obsolete classvars
-
- newClass setClassVariableString:(oldClass classVariableString).
- (spec := oldClass primitiveSpec) notNil ifTrue:[
- newClass primitiveSpec:spec.
- newClass setClassFilename:(oldClass classFilename).
- ]
- ].
- newClass classVariableString:stringOfClassVarNames.
-
- "/ for new classes, we are almost done here
- "/ (also for autoloaded classes)
-
- (oldClass isNil or:[oldClass isLoaded not]) ifTrue:[
- (oldClass isNil and:[changed]) ifTrue:[
- aClass ~~ Autoload ifTrue:[
- newClass addChangeRecordForClass:newClass.
- ]
- ].
-
- commentString notNil ifTrue:[
- newClass comment:commentString
- ].
- namespace notNil ifTrue:[
- thisIsPrivate ifTrue:[
- namespace privateClassesAt:classSymbol put:newClass.
- ] ifFalse:[
- namespace at:nameKey put:newClass.
- ]
- ].
-
-"/ oldClass isNil ifTrue:[
-"/ newClass package:(Class packageQuerySignal query)
-"/ ].
-
- oldClass notNil ifTrue:[
- "/ since we changed the classes inheritance (from Autoloaded)
-
- "/ actually, could optimize to:
- "/ Behavior updateSuperclassInfoFor:oldClass superclass.
- "/ Behavior updateSuperclassInfoFor:newClass superclass.
-
- Behavior flushSubclassInfo.
- ].
-
- oldClassToBecomeNew notNil ifTrue:[
- "/ old was an autoloaded class - make it the new one
- "/ and flush ...
- oldClassToBecomeNew class becomeSameAs:newClass class.
- oldClassToBecomeNew becomeSameAs:newClass.
- ObjectMemory flushCaches.
- ].
-
- Smalltalk changed:#newClass with:newClass.
- namespace notNil ifTrue:[
- thisIsPrivate ifTrue:[
- namespace changed.
- ] ifFalse:[
- namespace ~~ Smalltalk ifTrue:[
- namespace changed:#newClass with:newClass.
- ]
- ]
- ].
-
- "/ be very careful, when adding classes
- "/ to a namespace or adding a privateClass.
- "/ When adding, all methods within that namespace/owning class
- "/ which access the unprefixed-global,
- "/ must be recompiled (so they access the new class)
-
- recompileGlobalAccessTo notNil ifTrue:[
- self recompileGlobalAccessorsTo:recompileGlobalAccessTo
- in:namespace
- except:newClass.
- ].
-
- (thisIsPrivate
- and:[newClass owningClass nameSpace notNil]) ifTrue:[
- "/ namespace is a class;
- "/ if this owner is itself in a namespace,
- "/ must recompile all from owners namespace
- "/ accessing the new class (without namespace prefix)
- self recompileGlobalAccessorsTo:(newClass nameWithoutNameSpacePrefix asSymbol)
- in:(newClass owningClass nameSpace)
- except:newClass.
- ].
-
- ^ newClass
- ].
-
- "/ here comes the hard part - we are actually changing the
- "/ definition of an existing class ....
- "/ Try hard to get away WITHOUT recompiling, since it makes all
- "/ compiled code into interpreted ...
-
- oldInstVars := oldClass instanceVariableString asCollectionOfWords.
- newInstVars := newClass instanceVariableString asCollectionOfWords.
- oldClassVars := oldClass classVariableString asCollectionOfWords.
- newClassVars := newClass classVariableString asCollectionOfWords.
-
- oldSuperClass := oldClass superclass.
- newSuperClass := newClass superclass.
- superClassChange := oldSuperClass ~~ newSuperClass.
-
- "/ we are on the bright side of life, if the instance layout and
- "/ inheritance do not change.
- "/ In this case, we can go ahead and patch the class object.
- "/ (only comment and/or classVars have changed)
-
- superClassChange ifFalse:[
- (oldClass instSize == newClass instSize) ifTrue:[
- (oldClass flags == newClass flags) ifTrue:[
- (oldClass name = newClass name) ifTrue:[
- (oldInstVars = newInstVars) ifTrue:[
-
- (newComment ~= oldClass comment) ifTrue:[
- oldClass setComment:newComment. "writes a change-chunk"
- oldClass changed:#comment with:oldClass comment.
- changed ifTrue:[
- oldClass addChangeRecordForClassComment:oldClass.
- ]
- ].
- "/ mhmh - dont do this here ...
- "/ ... otherwise, we have to change all methods package info
- "/ to belong to the old package.
-"/ oldClass package:pkg.
-
- (oldClassVars = newClassVars) ifTrue:[
- "/ really no change (just comment and/or category)
-
- anyChange := false.
-
- oldClass setInstanceVariableString:(newClass instanceVariableString).
- oldClass setClassVariableString:(newClass classVariableString).
-
- oldClass category ~= categoryString ifTrue:[
- oldClass category:categoryString.
- changed ifTrue:[
- newClass addChangeRecordForClass:newClass.
- ].
- namespace notNil ifTrue:[
- thisIsPrivate ifFalse:[
- "notify change of category"
- namespace changed:#organization.
- namespace ~~ Smalltalk ifTrue:[
- Smalltalk changed:#organization.
- ]
- ]
- ]
- ].
- "notify change of class"
-"/ oldClass changed.
- ^ oldClass
- ].
-
- "/ when we arrive here, class variables have changed
-
- oldClass category ~= categoryString ifTrue:[
- "notify change of organization"
- oldClass category:categoryString.
- namespace notNil ifTrue:[
- thisIsPrivate ifFalse:[
- "notify change of organization"
- namespace changed:#organization.
- namespace ~~ Smalltalk ifTrue:[
- Smalltalk changed:#organization.
- ]
- ]
- ].
- ].
-
- "/ set class variable string;
- "/ this also updates the set of class variables
- "/ by creating new / deleting obsolete ones.
-
- oldClass classVariableString:stringOfClassVarNames.
-
- "
- get the set of changed class variables
- "
- changeSet1 := Set new.
- oldClassVars do:[:nm |
- (newClassVars includes:nm) ifFalse:[
- "/ a removed classVar;
- "/ must recompile methods accessing that one:
- "/ access was: classVar; now: global.
- changeSet1 add:nm
- ]
- ].
- newClassVars do:[:nm |
- (oldClassVars includes:nm) ifFalse:[
- "/ an added classVar;
- "/ must recompile methods accessing that one:
- "/ access was: global; now: classVar.
- "/ but only, if such a global existed in the first
- "/ place. (otherwise, it is a brand-new name)
-"/ cg: no, this is not a good check.
-"/ (Smalltalk includesKey:nm asSymbol) ifTrue:[
- changeSet1 add:nm
-"/ ]
- ]
- ].
-
- changeSet1 notEmpty ifTrue:[
-
- "/ recompile all methods accessing set of changed classvars
- "/ here and also in all subclasses ...
-
- "/ dont update change file for the recompilation
-
- Class withoutUpdatingChangesDo:[
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling class & inst methods accessing ' , changeSet1 printString.
-"/ Transcript endEntry.
-"/ ].
- oldClass withAllSubclasses do:[:aClass |
- aClass class recompileMethodsAccessingAnyClassvarOrGlobal:changeSet1.
- aClass recompileMethodsAccessingAnyClassvarOrGlobal:changeSet1.
- ].
- ].
- ].
-
- "notify change of class"
- changed ifTrue:[
- oldClass addChangeRecordForClass:oldClass.
- ].
- oldClass changed:#definition.
-
- namespace changed:#classDefinition with:oldClass.
- namespace ~~ Smalltalk ifTrue:[
- Smalltalk changed:#classDefinition with:oldClass.
- ].
-
- ^ oldClass
- ]
- ]
- ]
- ]
- ].
-
- "/ here we enter the darkness of mordor ...
- "/ since instance variable layout and/or inheritance has changed.
-
- (newComment ~= oldClass comment) ifTrue:[
- newClass comment:newComment
- ].
-
- "/ dont allow built-in classes to be modified this way
-
- (oldClass notNil and:[oldClass isBuiltInClass and:[superClassChange]]) ifTrue:[
- self error:'the inheritance of this class is fixed - you cannot change it'.
- ^ oldClass
- ].
-
- "/ since we will change the inheritance of some class(es)
- Behavior flushSubclassInfo.
-
- "/ catch special case, where superclass changed its layout and thus
- "/ forced redefinition of this class;
- "/ only log if this is not the case.
-
- changed ifTrue:[
- (superClassChange
- and:[(oldSuperClass isNil or:[newSuperClass notNil and:[oldSuperClass name = newSuperClass name]])
- and:[(oldClassVars = newClassVars)
- and:[(oldInstVars = newInstVars)
- and:[newComment = oldClass comment]]]]) ifFalse:[
- newClass addChangeRecordForClass:newClass.
- ]
- ].
-
- "/ care for class methods ...
-
- changeSet1 := Set new.
-
- classVarChange := false.
-
- superClassChange ifTrue:[
- (oldSuperClass notNil
- and:[newSuperClass notNil
- and:[oldSuperClass allClassVarNames = newSuperClass allClassVarNames
- and:[oldSuperClass name = newSuperClass name
- and:[oldClassVars = newClassVars]]]])
- ifTrue:[
-
-"/ Transcript showCR:'keep class methods (same classvars)'.
-"/ Transcript endEntry.
-
- "/ class methods still work
-
- self copyMethodsFrom:(oldClass class) for:newMetaclass.
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling class methods accessing super ...'.
-"/ Transcript endEntry.
-"/ ].
-
- "/ however, those accessing super must be recompiled
-
- self copyInvalidatedMethodsFrom:(oldClass class)
- for:newMetaclass
- accessingAny:#()
- orSuper:true.
- ] ifFalse:[
- "/ superclass changed:
- "/ must recompile all class methods accessing ANY classvar
- "/ (actually, we could be less strict and handle the case where
- "/ both the old and the new superclass have a common ancestor,
- "/ and both have no new classvariables in between.
- "/ This would speedup the case when a class is inserted into
- "/ the inheritance chain.)
-
- oldClass allClassVarNames do:[:nm | changeSet1 add:nm].
- newClass allClassVarNames do:[:nm | changeSet1 add:nm].
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling class methods accessing any classvar or super ...'.
-"/ Transcript endEntry.
-"/ ].
-
- self copyInvalidatedMethodsFrom:(oldClass class)
- for:newMetaclass
- accessingAny:changeSet1
- orSuper:true.
- ].
- newMetaclass recompileInvalidatedMethods.
- ] ifFalse:[
- "/ same superclass, find out which classvars have changed
-
- classVarChange := oldClassVars ~= newClassVars.
- classVarChange ifTrue:[
- oldClassVars do:[:nm |
- (newClassVars includes:nm) ifFalse:[
- changeSet1 add:nm
- ]
- ].
- newClassVars do:[:nm |
- (oldClassVars includes:nm) ifFalse:[
- changeSet1 add:nm
- ]
- ].
-
- "/ must recompile some class-methods
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling class methods accessing ' , changeSet1 printString.
-"/ Transcript endEntry.
-"/ ].
-
- self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
- newMetaclass recompileInvalidatedMethods.
- ] ifFalse:[
-
- "/ class methods still work
-
- self copyMethodsFrom:(oldClass class) for:newMetaclass
- ].
- ].
-
- "/ care for instance methods ...
-
- superClassChange ifTrue:[
- "/ superclass changed,
- "/ must recompile all methods accessing any class or instvar.
- "/ If number of instvars (i.e. the instances instSize) is the same,
- "/ we can limit the set of recompiled instance methods to those methods,
- "/ which refer to an instvar with a different inst-index
-
- "/ the changeset consists of instance variables,
- "/ with a different position
-
- changeSet2 := self differentInstanceVariableOffsetsIn:oldClass and:newClass.
-
- "/ merge in the changed class variables
-
- changeSet1 do:[:nm | changeSet2 add:nm].
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling instance methods accessing ' , changeSet2 printString , ' [superclass change]...'.
-"/ Transcript endEntry.
-"/ ].
-
- self copyInvalidatedMethodsFrom:oldClass
- for:newClass
- accessingAny:changeSet2
- orSuper:true.
- newClass recompileInvalidatedMethods.
-
- ] ifFalse:[
-
- "/ same inheritance ...
-
- instVarChange := oldInstVars ~= newInstVars.
- instVarChange ifFalse:[
-
- "/ same instance variables ...
-
- classVarChange ifTrue:[
- "recompile all inst methods accessing changed classvars"
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling instance methods accessing classvars ' , changeSet1 printString , ' ...'.
-"/ Transcript endEntry.
-"/ ].
- self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.
- newClass recompileInvalidatedMethods.
- ] ifFalse:[
- "/ instance methods still work
-
- self copyMethodsFrom:oldClass for:newClass
- ]
- ] ifTrue:[
-
- "/ dont allow built-in classes to be modified
-
- (oldClass notNil and:[oldClass isBuiltInClass and:[instVarChange]]) ifTrue:[
- self error:'the layout of this class is fixed - you cannot change it'.
- ^ oldClass
- ].
-
- ((oldInstVars size == 0)
- or:[newInstVars startsWith:oldInstVars]) ifTrue:[
-
- "/ only new inst variable(s) has/have been added -
- "/ old methods still work (the existing inst-indices are still valid)
-
-"/ Transcript showCR:'copying methods ...'.
-"/ Transcript endEntry.
-
- self copyMethodsFrom:oldClass for:newClass.
-
- "/ but: we have to recompile all methods accessing new instars
- "/ (it might have been a classVar/global before ...)
-
- addedNames := newInstVars select:[:nm | (oldInstVars includes:nm) not].
- "merge in class variables"
- changeSet1 do:[:nm | addedNames add:nm].
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling instance methods accessing ' , addedNames printString , '... [added instvars]'.
-"/ Transcript endEntry.
-"/ ].
-
- newClass recompileMethodsAccessingAny:addedNames.
- ] ifFalse:[
-
- "/ the changeset consists of instance variables,
- "/ with a different position
-
- changeSet2 := self differentInstanceVariableOffsetsIn:oldClass and:newClass.
-
- "merge in the class variables"
- changeSet1 do:[:nm | changeSet2 add:nm].
-
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling instance methods accessing ' , changeSet2 printString , ' ... [changed instvars]'.
-"/ Transcript endEntry.
-"/ ].
-
- self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
- newClass recompileInvalidatedMethods.
- ].
- ].
- ].
-
- "/ finally, if the oldClass came from a dynamically loaded
- "/ classLibrary, we must recompile the methods in the newClass.
- "/ otherwise, the methods code will vanish when the old (obsolete)
- "/ class eventually vanishes ...
- self recompileMachineCodeMethodsIn:newClass.
-
- (oldPkg notNil and:[oldPkg ~= pkg]) ifTrue:[
- "/ we have to change all methods package info
- "/ to belong to the old package.
- newClass allSelectorsAndMethodsDo:[:sel :mthd |
- mthd setPackage:oldPkg
- ].
- ].
-
- "/ WOW, everything done for this class
- "/ what about subclasses ?
-
- "/ update superclass of immediate subclasses -
- "/ this forces recompilation (recursively) if needed
- "/ (dont update change file for the subclass changes)
-
- Class classRedefinitionSignal answer:#keep do:[
- Class withoutUpdatingChangesDo:[
- oldClass subclasses copy do:[:aClass |
-
-"/ Transcript showCR:'changing superclass of:' , aClass name.
-"/ Transcript endEntry.
-
- aClass superclass:newClass
- ]
- ]
- ].
-
- "/ change any private subclasses' owners
-
- oldClass privateClassesDo:[:aClass |
- aClass isLoaded ifTrue:[
- aClass class setOwningClass:newClass
- ]
- ].
-
- "/ change category in oldClass - so we see immediately what it is ...
-
- oldCategory := oldClass category.
- oldClass category:#'* obsolete *'.
- oldClass wasAutoloaded ifTrue:[ Autoload removeClass:oldClass ].
- Smalltalk flushCachedClass:oldClass.
-
- "/ and make the new class globally known
-
- namespace notNil ifTrue:[
- thisIsPrivate ifTrue:[
- namespace privateClassesAt:classSymbol put:newClass.
- ] ifFalse:[
- namespace at:nameKey put:newClass.
-
- oldCategory ~= categoryString ifTrue:[
- "notify change of organization"
- namespace changed:#organization.
- namespace ~~ Smalltalk ifTrue:[
- Smalltalk changed:#organization.
- ]
- ]
- ].
- ].
-
- "/ Not becoming the old class creates some update problems;
- "/ the browsers must check carefully - a simple identity compare is
- "/ not enough ...
- "/ QUESTION: is this a good idea ?
-
-
- newClass dependents:(oldClass dependents).
- newClass changed:#definition.
-
- "just to make certain ... - tell dependents of oldClass, that something changed
- (systemBrowsers will react on this, and update their views)"
- oldClass changed:#definition with:newClass.
-
- namespace changed:#classDefinition with:newClass.
- namespace ~~ Smalltalk ifTrue:[
- Smalltalk changed:#classDefinition with:newClass.
- ].
-
- ObjectMemory flushCaches.
-
- oldClass ~~ newClass ifTrue:[
- namespace notNil ifTrue:[
- thisIsPrivate ifFalse:[
- namespace == Smalltalk ifTrue:[
- self checkForAliasesOf:oldClass with:newClass.
- ].
- ]
- ]
- ].
-
- ^ newClass
-
- "Created: / 26.5.1996 / 11:55:26 / cg"
- "Modified: / 18.3.1999 / 18:23:31 / stefan"
- "Modified: / 13.2.2000 / 22:59:57 / cg"
! !
!Metaclass methodsFor:'enumerating'!
-allSelectorsAndMethodsDo:aTwoArgBlock
- myClass allSelectorsAndMethodsDo:aTwoArgBlock
+instAndClassSelectorsAndMethodsDo:aTwoArgBlock
+ myClass instAndClassSelectorsAndMethodsDo:aTwoArgBlock
! !
!Metaclass methodsFor:'fileOut'!
@@ -2270,6 +1285,6 @@
!Metaclass class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.179 2001-09-10 14:15:21 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.180 2001-10-08 09:17:50 cg Exp $'
! !
Metaclass initialize!