"{ Package: 'stx:libbasic' }"
Object subclass:#ClassBuilder
instanceVariableNames:'className environment superClass instanceVariableNames variable
words pointers classVariableNames poolDictionaries category
comment changed classInstanceVariableNames oldMetaClass
realNewName buildPrivateClass'
classVariableNames:''
poolDictionaries:''
category:'Kernel-Support'
!
!ClassBuilder class methodsFor:'checks'!
checkForAliasesOf:oldClass with:newClass
"oldClass changed its identity (now use newClass).
check if there are any global aliases, which should also be changed"
Smalltalk keysAndValuesDo:[:nm :o |
o == oldClass ifTrue:[
nm ~~ oldClass name ifTrue:[
(self confirm:('The global/classVar `' , nm , ''' is an alias for ' , oldClass name , '.\\Change it to the new class ?') withCRs)
ifTrue:[
Smalltalk at:nm put:newClass
]
]
]
].
!
differentInstanceVariableOffsetsIn:class1 and:class2
"return a set of instance variable names which have different
positions in class1 and class2.
Also, variables which are only present in one class are returned.
This is used to find methods which need recompilation after a
change in the instance variable layout."
|offsets1 offsets2 changeSet|
changeSet := Set new.
"
collect the instvar-indices in the old and new class
"
offsets1 := class1 instanceVariableOffsets.
offsets2 := class2 instanceVariableOffsets.
"
compute the changeset as a set of instance variables,
which have a different position
"
offsets1 keysAndValuesDo:[:varName :varIndex |
(offsets2 includesKey:varName) ifFalse:[
changeSet add:varName
] ifTrue:[
(varIndex ~~ (offsets2 at:varName)) ifTrue:[
changeSet add:varName
]
]
].
offsets2 keysAndValuesDo:[:varName :varIndex |
(offsets1 includesKey:varName) ifFalse:[
changeSet add:varName
] ifTrue:[
(varIndex ~~ (offsets1 at:varName)) ifTrue:[
changeSet add:varName
]
]
].
^ changeSet
"
View class
differentInstanceVariableOffsetsIn:View
and:StandardSystemView
View class
differentInstanceVariableOffsetsIn:Object
and:Point
"
! !
!ClassBuilder class methodsFor:'recompiling'!
copyInvalidatedMethodsFrom:oldClass for:newClass
"copy all methods from oldClass to newClass and change their code
to a trap method reporting an error.
This is done when a class has changed its layout or inheritance,
before recompilation is attempted.
This allows us to keep the source while trapping uncompilable (due to
now undefined instvars) methods. Later compilation of these methods will show
an error on the transcript and lead to the debugger once called."
|trap trapCode trapByteCode oldMethod newMethod
oldDict newDict|
oldDict := oldClass methodDictionary.
newDict := MethodDictionary new:oldDict size.
oldDict keysAndValuesDo:[ :sel :mthd |
trap := mthd trapMethodForNumArgs:(mthd numArgs).
trapCode := trap code.
trapByteCode := trap byteCode.
mthd isWrapped ifTrue:[
oldMethod := mthd originalMethod
] ifFalse:[
oldMethod := mthd.
].
newMethod := oldMethod copy.
newMethod makeInvalid.
newDict at:sel put:newMethod
].
newClass methodDictionary:newDict.
"Modified: 12.6.1996 / 10:44:27 / stefan"
"Modified: 4.11.1996 / 22:55:57 / cg"
!
copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:setOfNames
"copy all methods from oldClass to newClass. Those methods accessing
a variable in setOfNames will be copied as invalid method, leading to
a trap when its executed. This is used when a class has changed its
layout for all methods which are affected by the change."
self copyInvalidatedMethodsFrom:oldClass
for:newClass
accessingAny:setOfNames
orSuper:false
!
copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:setOfNames orSuper:superBoolean
"copy all methods from oldClass to newClass.
Those methods accessing a variable in setOfNames will be copied as invalid method,
leading to a trap when its executed. If superBoolean is true, this is also done
for methods accessing super. This is used when a class has changed its
layout for all methods which are affected by the change."
|p source mustInvalidate
oldMethod newMethod methodDict newMethodDict nNames|
methodDict := oldClass methodDictionary.
newMethodDict := methodDict copy.
nNames := setOfNames size.
methodDict keysAndValuesDo:[:selector :method |
method isWrapped ifTrue:[
oldMethod := method originalMethod
] ifFalse:[
oldMethod := method
].
"before parsing (which may take some time),
do a string search if its only one variable,
we are looking for.
Could look for more than one variable by string compare, but then
parsing it right away may be faster ..."
source := oldMethod source.
((nNames == 1) and:[superBoolean not]) ifTrue:[
mustInvalidate := (source findString:(setOfNames first)) ~~ 0.
] ifFalse:[
((nNames == 0) and:[superBoolean]) ifTrue:[
mustInvalidate := (source findString:'super') ~~ 0.
] ifFalse:[
mustInvalidate := true
].
].
mustInvalidate ifTrue:[
"we have to parse it ..."
p := Parser parseMethod:source in:newClass.
(p isNil
or:[(p usedVars includesAny:setOfNames)
or:[superBoolean and:[p usesSuper]]]) ifFalse:[
mustInvalidate := false
]
].
mustInvalidate ifTrue:[
newMethod := oldMethod copy.
"/ Smalltalk silentLoading ifFalse:[
"/ Transcript showCR:'invalidating ' , selector , '...'.
"/ ].
newMethod makeInvalid.
] ifFalse:[
newMethod := oldMethod.
newMethod mclass:nil.
].
newMethodDict at:selector put:newMethod
].
newClass methodDictionary:newMethodDict.
"Modified: 7.6.1996 / 08:33:52 / stefan"
"Modified: 19.6.1997 / 18:27:09 / cg"
!
copyMethodsFrom:oldClass for:newClass
"copy all methods from oldClass to newClass.
This is used for class-methods when a class has changed, but its metaclass is
unaffected (i.e. classVars/inheritance have not changed) so there is no need
to recompile the class methods."
newClass methodDictionary:(oldClass methodDictionary copy).
newClass methodDictionary keysAndValuesDo:[:sel :mthd | mthd mclass:nil.].
"Modified: 7.6.1996 / 08:34:43 / stefan"
!
recompileGlobalAccessorsTo:aGlobalKey in:aNamespace except:someClass
"when a new class enters a namespace, all accessors to the same-named
class in that namespace must be recompiled"
aNamespace allPrivateClassesDo:[:aClass |
aClass ~~ someClass ifTrue:[
aClass isLoaded ifTrue:[
"/ Smalltalk silentLoading ifFalse:[
"/ Transcript showCR:'recompiling methods in ''' , aClass name , ''' accessing ''' , aGlobalKey , ''''.
"/ Transcript endEntry.
"/ ].
aClass recompileMethodsAccessingGlobal:aGlobalKey.
aClass class recompileMethodsAccessingGlobal:aGlobalKey.
"/ actually - must eventually recompile USERS of this namespace too
]
]
].
aNamespace isNameSpace ifFalse:[
aNamespace recompileMethodsAccessingGlobal:aGlobalKey.
aNamespace class recompileMethodsAccessingGlobal:aGlobalKey.
].
"Modified: 31.1.1997 / 11:22:57 / cg"
!
recompileMachineCodeMethodsIn:aClass
"recompile all machine-code methods in aClass."
aClass recompileMethodsWithMachineCode.
aClass class recompileMethodsWithMachineCode.
! !
!ClassBuilder methodsFor:'accessing'!
name:newName inEnvironment:aSystemDictionaryOrClass subclassOf:aClass instanceVariableNames:stringOfInstVarNames variable:variableBoolean words:wordsBoolean pointers:pointersBoolean classVariableNames:stringOfClassVarNames poolDictionaries:stringOfPoolNames category:categoryString comment:commentString changed:changedBoolean classInstanceVariableNames:stringOfClassInstVarNamesOrNil
className := newName.
environment := aSystemDictionaryOrClass.
superClass := aClass.
instanceVariableNames := stringOfInstVarNames.
variable := variableBoolean.
words := wordsBoolean.
pointers := pointersBoolean.
classVariableNames := stringOfClassVarNames.
poolDictionaries := stringOfPoolNames.
category := categoryString.
comment := commentString.
changed := changedBoolean.
classInstanceVariableNames := stringOfClassInstVarNamesOrNil
!
oldMetaclass:aMetaclass instanceVariableNames:stringOfInstVarNames
oldMetaClass := aMetaclass.
instanceVariableNames := stringOfInstVarNames.
! !
!ClassBuilder methodsFor:'building'!
buildClass
"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
oldCIVNames newCIVNames nsName namespace
oldSuperClass newSuperClass oldCategory
recompileGlobalAccessTo answer
oldClassToBecomeNew newInstSize doCreate|
"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 ...
"
self checkClassName.
self checkValidSubclassing.
"/ owner must be loaded
(environment notNil and:[environment isLoaded not]) ifTrue:[
environment autoload
].
(instanceVariableNames size > 0
or:[classVariableNames size > 0]) ifTrue:[
"
Check for invalid variable names (duplicates)
"
(self
checkValidVarNamesFor:className
subClassOf:superClass
instVarNames:instanceVariableNames
classVarNames:classVariableNames)
ifFalse:[
^ nil
].
nInstVars := instanceVariableNames countWords.
] ifFalse:[
nInstVars := 0.
].
nameString := className asString.
classSymbol := className asSymbol.
newComment := comment.
namespace := environment.
nameKey := classSymbol.
(namespace notNil
and:[namespace isNameSpace not]) ifTrue:[
buildPrivateClass := true.
realNewName := (namespace name , '::' , classSymbol) asSymbol.
] ifFalse:[
buildPrivateClass := 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:[
doCreate := Class createNameSpaceQuerySignal query.
doCreate ifFalse:[
doCreate := Dialog
confirmWithCancel:('Nonexistent Namespace: `' , nsName , '''.\\Create ?') withCRs.
doCreate isNil ifTrue:[
"/ cancelled
AbortSignal raise.
]
].
doCreate ifFalse:[^ nil].
namespace := NameSpace name:nsName.
] ifFalse:[
(namespace isBehavior
and:[namespace isMeta not])
ifTrue:[
buildPrivateClass := true.
realNewName := classSymbol asSymbol.
] 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.
]
]
].
(superClass notNil and:[realNewName = superClass name]) ifTrue:[
self error:'trying to create circular class definition'.
^ nil
].
"look, if it already exists as a class"
namespace notNil ifTrue:[
buildPrivateClass ifFalse:[
oldClass := namespace at:nameKey ifAbsent:[nil].
] ifTrue:[
oldClass := namespace privateClassesAt:classSymbol.
]
].
(oldClass notNil and:[oldClass isNameSpace]) ifTrue:[
self error:'class exists as namespace'.
^ nil
].
(oldClass isBehavior and:[oldClass isLoaded not]) ifTrue:[
oldClassToBecomeNew := oldClass
].
(oldClass isBehavior and:[oldClass isLoaded]) ifFalse:[
oldClass := nil.
buildPrivateClass 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
"/
(self checkForCircularDefinitionFrom:oldClass) 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 ~= category ifTrue:[
oldClass instanceVariableString asCollectionOfWords
~= instanceVariableNames 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)
"/
((variable == true) and:[pointers]) ifTrue:[
(oldClass isKindOf:Set class) ifTrue:[
(self confirm:('ST/X Set & Dictionary are not variable-classes.\Create %1 anyway ?' bindWith:nameString) 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:[
(instanceVariableNames size > 0
or:[classVariableNames size > 0]) ifTrue:[
(self
checkConventionsFor:className
subClassOf:superClass
instVarNames:instanceVariableNames
classVarNames:classVariableNames)
ifFalse:[
^ nil
]
].
(self
checkInstvarRedefsWith:instanceVariableNames
subclassOf:superClass
old:oldClass
name:className) ifFalse:[^ nil].
].
classInstanceVariableNames isNil ifTrue:[
oldClass isNil ifTrue:[
classInstanceVariableNames := ''
] ifFalse:[
classInstanceVariableNames := oldClass class instanceVariableString
]
].
"create the metaclass first"
newMetaclass := self instantiateMetaclass.
"then let the new meta create the class"
newClass := newMetaclass new.
superClass isNil ifTrue:[
newInstSize := nInstVars.
] ifFalse:[
newInstSize := superClass instSize + nInstVars.
].
newClass setSuperclass:superClass instSize:newInstSize.
buildPrivateClass 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:category.
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 ...
buildPrivateClass ifTrue:[
pkg := namespace package.
] ifFalse:[
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.
(variable == true) ifTrue:[
pointers ifTrue:[
newFlags := Behavior flagPointers
] ifFalse:[
words ifTrue:[
newFlags := Behavior flagWords
] ifFalse:[
newFlags := Behavior flagBytes
]
]
] ifFalse:[
"/ false or symbol.
newFlags := Behavior flagForSymbolic:variable.
].
superClass isNil ifTrue:[
superFlags := 0
] ifFalse:[
superFlags := superClass 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:instanceVariableNames
].
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:classVariableNames.
"/ for new classes, we are almost done here
"/ (also for autoloaded classes)
(oldClass isNil or:[oldClass isLoaded not]) ifTrue:[
(oldClass isNil and:[changed]) ifTrue:[
superClass ~~ Autoload ifTrue:[
newClass addChangeRecordForClass:newClass.
]
].
comment notNil ifTrue:[
newClass comment:comment
].
namespace notNil ifTrue:[
buildPrivateClass 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:[
buildPrivateClass 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 class
recompileGlobalAccessorsTo:recompileGlobalAccessTo
in:namespace except:newClass.
].
(buildPrivateClass
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 class
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 ~= category ifTrue:[
oldClass category:category.
changed ifTrue:[
newClass addChangeRecordForClass:newClass.
].
namespace notNil ifTrue:[
buildPrivateClass 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 ~= category ifTrue:[
"notify change of organization"
oldClass category:category.
namespace notNil ifTrue:[
buildPrivateClass 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:classVariableNames.
"
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 class 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 class
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 class
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 class
copyInvalidatedMethodsFrom:(oldClass class)
for:newMetaclass
accessingAny:changeSet1.
newMetaclass recompileInvalidatedMethods.
] ifFalse:[
"/ class methods still work
self class 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 class 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 class
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 class
copyInvalidatedMethodsFrom:oldClass
for:newClass
accessingAny:changeSet1.
newClass recompileInvalidatedMethods.
] ifFalse:[
"/ instance methods still work
self class 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 class 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 class 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 class
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 class recompileMachineCodeMethodsIn:newClass.
(oldPkg notNil and:[oldPkg ~= pkg]) ifTrue:[
"/ we have to change all methods package info
"/ to belong to the old package.
newClass instAndClassSelectorsAndMethodsDo:[: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:[
buildPrivateClass ifTrue:[
namespace privateClassesAt:classSymbol put:newClass.
] ifFalse:[
namespace at:nameKey put:newClass.
oldCategory ~= category 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:[
buildPrivateClass ifFalse:[
namespace == Smalltalk ifTrue:[
ClassBuilder checkForAliasesOf:oldClass with:newClass.
].
]
]
].
(instVarChange or:[classVarChange]) ifTrue:[
self changeReferencesFrom:oldClass to:newClass.
].
Behavior flushSubclassInfo.
^ 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"
!
changeReferencesFrom:oldClass to:newClass
| refs|
refs := OrderedCollection new.
ObjectMemory allObjectsDo:[:obj |
(obj referencesObject:oldClass) ifTrue:[
obj isContext ifFalse:[
refs add:obj
].
].
].
refs isEmpty ifTrue:[
^ self
].
"/ answer := OptionBox
"/ request:('Update References (from old class to new class) ?') withCRs
"/ label:'Confirm'
"/ buttonLabels:#('no' 'browse references' 'update')
"/ values:#(false #browse true)
"/ default:#true
"/ onCancel:false.
"/
"/ answer == #browse ifTrue:[
"/ refs inspect.
"/ answer := self confirm:('Update References (from old class to new class) ?') withCRs.
"/ ].
"/ answer == false ifTrue:[^ self].
refs do:[:obj |
|skip|
skip := false.
obj isBehavior ifTrue:[
skip := true.
obj isObsolete ifFalse:[
obj isMeta ifTrue:[
"/ the owner-slot ?
obj owningClass == oldClass ifTrue:[
"/ self halt.
].
obj theNonMetaclass == oldClass ifTrue:[
"/ self halt.
]
]
]
].
skip ifFalse:[
obj replaceReferencesTo:oldClass with:newClass.
].
].
!
instantiateMetaclass
"create the metaclass proper"
|newMetaclass classesSuperclass|
buildPrivateClass ifTrue:[
newMetaclass := PrivateMetaclass new
] ifFalse:[
newMetaclass := Metaclass new.
].
superClass isNil ifTrue:[
classesSuperclass := Class.
] ifFalse:[
classesSuperclass := superClass class.
].
newMetaclass setSuperclass:classesSuperclass instSize:(classesSuperclass instSize + classInstanceVariableNames countWords).
newMetaclass setInstanceVariableString:classInstanceVariableNames.
^ newMetaclass
!
rebuildForChangedInstanceVariables
"changing / adding class-inst vars -
this actually creates a new metaclass and class, leaving the original
classes around as obsolete classes. This may also be true for all subclasses,
if class instance variables are added/removed.
Existing instances continue to be defined by their original classes.
Time will show, if this is an acceptable behavior or if we should migrate
instances to become insts. of the new classes."
|newClass newMetaclass nClassInstVars oldClass
allSubclasses oldVars
oldNames newNames addedNames
oldOffsets newOffsets offset changeSet delta
oldToNew newSubMeta newSub oldSubMeta oldSuper
commonClassInstVars t superclass|
"
cleanup needed here: extract common things with name:inEnvironment:...
and restructure things ... currently way too complex.
"
oldVars := oldMetaClass instanceVariableString.
instanceVariableNames = oldVars ifTrue:[
"
Transcript showCR:'no change (', oldVars , ') -> (', instanceVariableNames , ')'.
"
^ self
].
oldNames := oldVars asCollectionOfWords.
newNames := instanceVariableNames asCollectionOfWords.
oldNames = newNames ifTrue:[
"
Transcript showCR:'no real change'.
"
"no real change (just formatting)"
oldMetaClass setInstanceVariableString:instanceVariableNames.
^ self
].
"/ "
"/ let user confirm, if any name is no good (and was good before)
"/ "
"/ (oldNames inject:true
"/ into:[:okSoFar :word |
"/ okSoFar and:[word first isUppercase]
"/ ])
"/ ifTrue:[
"/ "was ok before"
"/ (newNames inject:true
"/ into:[:okSoFar :word |
"/ okSoFar and:[word first isUppercase]
"/ ])
"/ ifFalse:[
"/ (self confirm:'class instance variable names should start with an uppercase letter
"/(by convention only)
"/
"/install anyway ?' withCRs)
"/ ifFalse:[
"/ ^ nil
"/ ]
"/ ]
"/ ].
nClassInstVars := newNames size.
"
Transcript showCR:'create new class/metaclass'.
"
"
create the new metaclass
"
oldMetaClass isPrivate ifTrue:[
newMetaclass := oldMetaClass class "PrivateMetaclass" new.
newMetaclass setOwningClass:(oldMetaClass owningClass).
] ifFalse:[
newMetaclass := oldMetaClass class "Metaclass" new.
].
superclass := oldMetaClass superclass.
newMetaclass setSuperclass:superclass.
newMetaclass instSize:(superclass instSize + nClassInstVars).
(nClassInstVars ~~ 0) ifTrue:[
newMetaclass setInstanceVariableString:instanceVariableNames
].
"/ newMetaclass flags:(Behavior flagBehavior "flagNotIndexed").
"/ newMetaclass setName:name.
"/ newMetaclass classVariableString:classvars.
"/ newMetaclass setComment:(self comment).
"find the class which is my sole instance"
oldClass := oldMetaClass theNonMetaclass.
"
create the new class
"
newClass := newMetaclass new.
newClass setSuperclass:(oldClass superclass) instSize:(oldClass instSize).
newClass flags:(oldClass flags).
newClass setName:(oldClass name).
newClass setInstanceVariableString:(oldClass instanceVariableString).
newClass classVariableString:(oldClass classVariableString).
newClass setComment:(oldClass comment).
newClass category:(oldClass category).
(t := oldClass primitiveSpec) notNil ifTrue:[
newClass primitiveSpec:t.
].
newClass setClassFilename:(oldClass classFilename).
"/ set the new classes package
"/ from the old package
newClass package:(oldClass package).
"/ and keep the binary revision
newClass setBinaryRevision:(oldClass binaryRevision).
changeSet := Set new.
((oldNames size == 0)
or:[newNames startsWith:oldNames]) ifTrue:[
"new variable(s) has/have been added - old methods still work"
"/ Transcript showCR:'copying methods ...'.
"/ Transcript endEntry.
ClassBuilder copyMethodsFrom:oldMetaClass for:newMetaclass.
ClassBuilder copyMethodsFrom:oldClass for:newClass.
"
but have to recompile methods accessing stuff now defined
(it might have been a global/undeclared before ...)
"
addedNames := newNames select:[:nm | (oldNames includes:nm) not].
"/ Smalltalk silentLoading ifFalse:[
"/ Transcript showCR:'recompiling class methods of ' , newMetaclass name ,
"/ ' accessing any of ' , addedNames printString.
"/ ].
"recompile class-methods"
newMetaclass recompileMethodsAccessingAny:addedNames.
] ifFalse:[
"
create the changeSet; thats the set of class instvar names
which have changed their position or are new
"
offset := 0. oldOffsets := Dictionary new.
oldNames do:[:nm | offset := offset + 1. oldOffsets at:nm put:offset].
offset := 0. newOffsets := Dictionary new.
newNames do:[:nm | offset := offset + 1. newOffsets at:nm put:offset].
oldOffsets associationsDo:[:a |
|k|
k := a key.
(newOffsets includesKey:k) ifFalse:[
changeSet add:k
] ifTrue:[
(a value ~~ (newOffsets at:k)) ifTrue:[
changeSet add:k
]
]
].
newOffsets associationsDo:[:a |
|k|
k := a key.
(oldOffsets includesKey:k) ifFalse:[
changeSet add:k
] ifTrue:[
(a value ~~ (oldOffsets at:k)) ifTrue:[
changeSet add:k
]
]
].
"/ Smalltalk silentLoading ifFalse:[
"/ Transcript showCR:'recompiling class methods of ' , newMetaclass name ,
"/ ' accessing any of ' , changeSet printString.
"/ ].
"
recompile class-methods accessing any c-instvar with a changed position
"
ClassBuilder copyInvalidatedMethodsFrom:oldMetaClass for:newMetaclass accessingAny:changeSet.
newMetaclass recompileInvalidatedMethods.
ClassBuilder copyMethodsFrom:oldClass for:newClass.
].
delta := newNames size - oldNames size.
"/ preserve existing classInstVar values (but not those from Class)
newMetaclass allInstVarNames do:[:nm |
|v|
(Class class allInstVarNames includes:nm) ifFalse:[
v := oldClass instVarNamed:nm ifAbsent:nil.
v notNil ifTrue:[
newClass instVarNamed:nm put:v.
].
].
].
"
get list of all subclasses - do before superclass is changed
"
allSubclasses := oldClass allSubclasses asOrderedCollection.
"/ cg: wrong: allSubclasses := allSubclasses asSortedCollection:[:a :b | b isSubclassOf:a].
allSubclasses := allSubclasses topologicalSort:[:a :b | b isSubclassOf:a].
oldToNew := IdentityDictionary new.
"
create a new class tree, based on the new version
"
Smalltalk flushCachedClasses.
Class flushSubclassInfo.
allSubclasses do:[:aSubclass |
oldSuper := aSubclass superclass.
oldSubMeta := aSubclass class.
newSubMeta := Metaclass new.
oldSuper == oldClass ifTrue:[
newSubMeta setSuperclass:newMetaclass.
] ifFalse:[
newSubMeta setSuperclass:(oldToNew at:oldSuper) class.
].
newSubMeta instSize:(oldSubMeta instSize + delta).
newSubMeta flags:(oldSubMeta flags).
"/ newSubMeta setName:(oldSubMeta name).
newSubMeta setInstanceVariableString:(oldSubMeta instanceVariableString).
"/ newSubMeta setComment:(oldSubMeta comment).
newSub := newSubMeta new.
oldSuper == oldClass ifTrue:[
newSub setSuperclass:newClass.
] ifFalse:[
newSub setSuperclass:(oldToNew at:oldSuper).
].
"/ newSub setMethodDictionary:(aSubclass methodDictionary copy).
"/ newSub class setMethodDictionary:(aSubclass class methodDictionary copy).
newSub setName:(aSubclass name).
newSub classVariableString:(aSubclass classVariableString).
newSub setInstanceVariableString:(aSubclass instanceVariableString).
(t := aSubclass primitiveSpec) notNil ifTrue:[
newSub primitiveSpec:t.
].
newSub package:(aSubclass package).
newSub setClassFilename:(oldClass classFilename).
newSub setComment:(aSubclass comment).
newSub category:(aSubclass category).
newSub instSize:(aSubclass instSize).
newSub setBinaryRevision:(aSubclass binaryRevision).
oldToNew at:aSubclass put:newSub.
aSubclass category:#'* obsolete *'.
"/ preserve existing classInstVar values (but not those from Class)
newSubMeta allInstVarNames do:[:nm |
|v|
(Class class allInstVarNames includes:nm) ifFalse:[
v := aSubclass instVarNamed:nm ifAbsent:nil.
v notNil ifTrue:[
newSub instVarNamed:nm put:v.
].
].
].
].
"recompile what needs to be"
delta == 0 ifTrue:[
"only have to recompile class methods accessing
class instvars from changeset
"
allSubclasses do:[:oldSubclass |
|newSubclass|
newSubclass := oldToNew at:oldSubclass.
"/ Smalltalk silentLoading ifFalse:[
"/ Transcript showCR:'recompiling class methods of ' , newSubclass class name ,
"/ ' accessing any of ' , changeSet printString.
"/ ].
ClassBuilder
copyInvalidatedMethodsFrom:oldSubclass class for:newSubclass class
accessingAny:changeSet orSuper:true.
ClassBuilder
copyInvalidatedMethodsFrom:oldSubclass for:newSubclass
accessingAny:#() orSuper:true.
newSubclass class recompileInvalidatedMethods.
newSubclass recompileInvalidatedMethods.
]
] ifFalse:[
"
have to recompile all class methods accessing class instvars
"
commonClassInstVars := oldClass class allInstVarNames.
changeSet do:[:v |
commonClassInstVars remove:v ifAbsent:[]
].
allSubclasses do:[:oldSubclass |
|newSubclass classInstVars|
newSubclass := oldToNew at:oldSubclass.
classInstVars := newSubclass class allInstVarNames asSet.
classInstVars removeAll:commonClassInstVars.
classInstVars addAll:changeSet.
"/ Smalltalk silentLoading ifFalse:[
"/ Transcript showCR:'recompiling class methods of ' , newSubclass class name ,
"/ ' accessing any of ' , classInstVars printString.
"/ ].
ClassBuilder
copyInvalidatedMethodsFrom:oldSubclass class for:newSubclass class
accessingAny:classInstVars orSuper:true.
ClassBuilder
copyInvalidatedMethodsFrom:oldSubclass for:newSubclass
accessingAny:#() orSuper:true.
newSubclass class recompileInvalidatedMethods.
newSubclass recompileInvalidatedMethods.
]
].
newClass addChangeRecordForClassInstvars:newClass.
"install all new classes"
(Smalltalk at:(oldClass name asSymbol) ifAbsent:nil) == oldClass ifTrue:[
Smalltalk at:(oldClass name asSymbol) put:newClass.
ClassBuilder checkForAliasesOf:oldClass with:newClass.
"
change any private subclasses' owners
"
oldClass privateClassesDo:[:aClass |
aClass class setOwningClass:newClass
].
].
ObjectMemory flushCachesFor:oldClass.
allSubclasses do:[:oldSubClass |
|newSubClass|
newSubClass := oldToNew at:oldSubClass.
"/ Transcript showCR:'install ' , newSubClass name , '(' , newSubClass category , ')' ,
"/ ' as ' , newSubClass name.
(Smalltalk at:(oldSubClass name asSymbol) ifAbsent:nil) == oldSubClass ifTrue:[
Smalltalk at:oldSubClass name asSymbol put:newSubClass.
ClassBuilder checkForAliasesOf:oldSubClass with:newSubClass.
].
ObjectMemory flushCachesFor:oldSubClass.
oldSubClass privateClassesDo:[:aClass |
aClass class setOwningClass:newSubClass
].
].
"tell dependents ..."
oldClass changed:#definition.
oldMetaClass changed:#definition.
oldMetaClass nameSpace changed:#classDefinition with:oldMetaClass.
oldMetaClass nameSpace ~~ Smalltalk ifTrue:[
Smalltalk changed:#classDefinition with:oldMetaClass.
].
^ newMetaclass
"Created: / 29.10.1995 / 19:57:08 / cg"
"Modified: / 1.4.1997 / 15:44:09 / stefan"
"Modified: / 31.7.1998 / 18:02:00 / cg"
! !
!ClassBuilder methodsFor:'checks'!
checkClassName
(className isSymbol not
or:[className size == 0]) ifTrue:[
self error:'invalid class name (must be a nonEmpty symbol)'.
].
className first isLetter ifFalse:[
self error:'invalid class name (must start with a letter)'.
].
!
checkConventionsFor:className subClassOf:aClass instVarNames:instVarNameString classVarNames:classVarNameString
"Check for some 'considered bad-style' things, like lower case names.
NOTICE:
I dont like the confirmers below - 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 it anyway).
"
|names idx what doChecks answ|
doChecks := Metaclass confirmationQuerySignal query.
doChecks == false ifTrue:[^ true].
"let user confirm, if the classname is no good"
className first isUppercase ifFalse:[
aClass == NameSpace ifTrue:[
what := 'namespace'
] ifFalse:[
what := 'class'
].
answ := Class classConventionViolationConfirmationQuerySignal query.
answ notNil ifTrue:[^ answ].
(self confirm:(what , ' name ''' , className ,
''' should start with an uppercase letter
(by convention only)
install anyway ?') withCRs)
ifFalse:[
^ false
]
].
names := instVarNameString asCollectionOfWords.
"let user confirm, if any instvarname is no good"
(idx := names findFirst:[:word | word first isUppercase]) ~~ 0 ifTrue:[
answ := Class classConventionViolationConfirmationQuerySignal query.
answ notNil ifTrue:[^ answ].
(self confirm:className , ': instance variable named ''' , (names at:idx) allBold , '''
should start with a lowercase letter (by convention only).
Install anyway ?' withCRs)
ifFalse:[
^ false
]
].
names := classVarNameString asCollectionOfWords.
"let user confirm, if any classvarname is no good"
(idx := names findFirst:[:word | word first isLowercase]) ~~ 0 ifTrue:[
answ := Class classConventionViolationConfirmationQuerySignal query.
answ notNil ifTrue:[^ answ].
(self confirm:className , ': class variable named ''' , (names at:idx) allBold , '''
should start with an uppercase letter (by convention only).
Install anyway ?' withCRs)
ifFalse:[
^ false
].
].
^ true
"Created: / 15.10.1996 / 11:56:38 / cg"
"Modified: / 3.2.1999 / 11:24:52 / cg"
"Modified: / 18.3.1999 / 18:22:47 / stefan"
!
checkForCircularDefinitionFrom:oldClass
oldClass allSuperclasses do:[:cls |
cls name = realNewName ifTrue:[
^ true
]
].
superClass notNil ifTrue:[
superClass allSuperclasses do:[:cls |
cls name = realNewName ifTrue:[
^ true
]
].
].
^ false
!
checkInstvarRedefsWith:stringOfInstVarNames subclassOf:aClass old:oldClass name:newName
|superInstVars msg|
aClass notNil ifTrue:[
"
check for instVar redef of superClass instVars
"
superInstVars := aClass allInstVarNames.
stringOfInstVarNames asCollectionOfWords do:[:nm |
(superInstVars includes:nm) ifTrue:[
(oldClass notNil
and:[stringOfInstVarNames = oldClass instanceVariableString])
ifTrue:[
Transcript showCR:('instVar conflict in `' , newName , ''' for `' , nm , ''' due to superclass change.').
msg := 'instVar conflict in `' , newName , ''' for `' , nm , ''' due to superclass change.\You now have two different instVar slots with the same name.\\Dont forget to fix this later.'.
self warn:msg withCRs.
] ifFalse:[
Transcript showCR:('instVar `' , nm , ''' is already defined in a superclass of `' , newName , '''.').
msg := 'instVar `' , nm , ''' is already defined in a superclass.\Change the definition of `' , newName , ''' anyway ?\\Notice: you must fix the superclass later.'.
^ self confirm:msg withCRs
].
]
].
].
oldClass notNil ifTrue:[
"
check for instVar redefs in subclass instVars
"
oldClass allSubclassesDo:[:sub |
|vars|
vars := sub instVarNames.
stringOfInstVarNames asCollectionOfWords do:[:nm |
(vars includes:nm) ifTrue:[
^ self confirm:('subclass '
, sub name
, ' already defines an instVar named `'
, nm
, '''.\\Change the definition of `'
, newName
, ''' anyway ?\Notice: you must fix the subclass later.'
) withCRs
]
]
]
].
^ true
"Created: 29.1.1997 / 17:42:11 / cg"
!
checkValidSubclassing
"check for invalid subclassing of UndefinedObject and SmallInteger"
superClass notNil ifTrue:[
superClass canBeSubclassed ifFalse:[
self error:('it is not possible to subclass ' , superClass name).
]
].
!
checkValidVarNamesFor:className subClassOf:aClass instVarNames:instVarNameString classVarNames:classVarNameString
"Check for some 'considered bad-style' things, like lower case names.
NOTICE:
I dont like the confirmers below - 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 it anyway).
"
|names|
names := instVarNameString asCollectionOfWords.
"check for instvar redefs within local instvars"
names keysAndValuesDo:[:index :aName |
(names indexOf:aName startingAt:index+1) ~~ 0 ifTrue:[
self warn:'instance variable ''' , aName , '''\occurs multiple times in instVarString.\\Class not installed.' withCRs.
^ false.
]
].
names := classVarNameString asCollectionOfWords.
"check for classvar redefs within local instvars"
names keysAndValuesDo:[:index :aName |
(names indexOf:aName startingAt:index+1) ~~ 0 ifTrue:[
self warn:'class variable ''' , aName , '''\occurs multiple times in classVarString.\\Class not installed.' withCRs.
^ false.
]
].
^ true
"Created: 8.1.1997 / 21:09:14 / cg"
"Modified: 9.1.1997 / 02:10:02 / cg"
! !
!ClassBuilder class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/ClassBuilder.st,v 1.19 2003-03-24 17:49:04 cg Exp $'
! !