"
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
"{ Package: 'stx:libbasic' }"
ClassDescription subclass:#Metaclass
instanceVariableNames:'myClass'
classVariableNames:'ConfirmationQuerySignal'
poolDictionaries:''
category:'Kernel-Classes'
!
!Metaclass class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
every classes class is a subclass of Metaclass.
(i.e. every class is the sole instance of its Metaclass)
Metaclass provides support for creating new (sub)classes and/or
changing the definition of an already existing class.
[author:]
Claus Gittinger
[see also:]
Behavior ClassDescription Class
"
! !
!Metaclass class methodsFor:'Signal constants'!
confirmationQuerySignal
"return the query signal which is raised to ask if user
confirmation dialogs should be opened.
If unhandled, they are."
^ ConfirmationQuerySignal
"Created: 31.7.1997 / 21:55:39 / cg"
! !
!Metaclass class methodsFor:'class initialization'!
initialize
ConfirmationQuerySignal := QuerySignal new defaultAnswer:true
"Modified: 31.7.1997 / 21:54:44 / cg"
! !
!Metaclass class methodsFor:'creating metaclasses'!
new
"creating a new metaclass - have to set the new classes
flags correctly to have it behave like a metaclass ...
Not for normal applications - creating new metaclasses is a very
tricky thing; should be left to the gurus ;-)"
|newMetaclass|
newMetaclass := super new.
newMetaclass instSize:(Class instSize).
newMetaclass setSuperclass:Class.
^ newMetaclass
"
Metaclass new <- new metaclass
Metaclass new new <- new class
Metaclass new new new <- new instance
"
! !
!Metaclass class methodsFor:'queries'!
isBuiltInClass
"return true if this class is known by the run-time-system.
Here, true is returned for myself, false for subclasses."
^ self == Metaclass class or:[self == Metaclass]
"Modified: 23.4.1996 / 15:59:44 / cg"
! !
!Metaclass methodsFor:'Compatibility ST80'!
comment:aString
"ignored - sometimes found in ST-80 fileOut files.
Comments are supposed to be defined via class messages."
"Created: 9.10.1997 / 18:14:34 / cg"
!
sourceCodeTemplate
"ST80 compatibility - return a definition message for myself.
Same as #definition"
^ self soleInstance definition
"Created: / 1.11.1997 / 13:16:45 / cg"
! !
!Metaclass methodsFor:'class instance variables'!
instanceVariableNames:aString
"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|
"
cleanup needed here: extract common things with name:inEnvironment:...
and restructure things ... currently way too complex.
"
oldVars := self instanceVariableString.
aString = oldVars ifTrue:[
"
Transcript showCR:'no change (', oldVars , ') -> (', aString , ')'.
"
^ self
].
oldNames := oldVars asCollectionOfWords.
newNames := aString asCollectionOfWords.
oldNames = newNames ifTrue:[
"
Transcript showCR:'no real change'.
"
"no real change (just formatting)"
self setInstanceVariableString:aString.
^ 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
"
self isPrivate ifTrue:[
newMetaclass := PrivateMetaclass new.
newMetaclass setOwningClass:(self owningClass).
] ifFalse:[
newMetaclass := Metaclass new.
].
newMetaclass setSuperclass:superclass.
newMetaclass instSize:(superclass instSize + nClassInstVars).
(nClassInstVars ~~ 0) ifTrue:[
newMetaclass setInstanceVariableString:aString
].
"/ newMetaclass flags:(Behavior flagBehavior "flagNotIndexed").
"/ newMetaclass setName:name.
"/ newMetaclass classVariableString:classvars.
"/ newMetaclass setComment:(self comment).
"find the class which is my sole instance"
oldClass := myClass.
"
create the new class
"
newClass := newMetaclass new.
newClass setSuperclass:(oldClass superclass).
newClass 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.
self copyMethodsFrom:self for:newMetaclass.
self 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
"
self copyInvalidatedMethodsFrom:self for:newMetaclass accessingAny:changeSet.
newMetaclass recompileInvalidatedMethods.
self 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
"
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.
"/ ].
self
copyInvalidatedMethodsFrom:oldSubclass class for:newSubclass class
accessingAny:changeSet orSuper:true.
self
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.
"/ ].
self
copyInvalidatedMethodsFrom:oldSubclass class for:newSubclass class
accessingAny:classInstVars orSuper:true.
self
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.
self 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.
self checkForAliasesOf:oldSubClass with:newSubClass.
].
ObjectMemory flushCachesFor:oldSubClass.
oldSubClass privateClassesDo:[:aClass |
aClass class setOwningClass:newSubClass
].
].
"tell dependents ..."
oldClass changed:#definition.
self changed:#definition.
^ 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"
! !
!Metaclass methodsFor:'copying'!
postCopy
"redefined - a copy may have a new instance"
myClass := nil
! !
!Metaclass methodsFor:'creating classes'!
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 package: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 *'.
"/ and make the new class globally known
namespace notNil ifTrue:[
thisIsPrivate ifTrue:[
namespace privateClassesAt:classSymbol put:newClass.
] ifFalse:[
namespace at:nameKey put:newClass.
namespace == Smalltalk ifTrue:[
self checkForAliasesOf:oldClass with: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.
^ 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"
!
name:newName inEnvironment:aSystemDictionary
subclassOf:aClass
instanceVariableNames:stringOfInstVarNames
variable:variableBoolean
words:wordsBoolean
pointers:pointersBoolean
classVariableNames:stringOfClassVarNames
poolDictionaries:stringOfPoolNames
category:categoryString
comment:commentString
changed:changed
^ self
name:newName
in:aSystemDictionary
subclassOf:aClass
instanceVariableNames:stringOfInstVarNames
variable:variableBoolean
words:wordsBoolean
pointers:pointersBoolean
classVariableNames:stringOfClassVarNames
poolDictionaries:stringOfPoolNames
category:categoryString
comment:commentString
changed:changed
classInstanceVariableNames:nil
"Modified: 16.6.1997 / 11:53:58 / cg"
!
new
"create & return a new metaclass (a classes class).
Since metaclasses only have one instance (the class),
complain if there is already one.
You get a new class by sending #new to the returned metaclass
(confusing - isn't it ?)"
|newClass|
myClass notNil ifTrue:[
self error:'Each metaclass may only have one instance'.
].
newClass := self basicNew.
newClass setSuperclass:Object
methodDictionary:MethodDictionary new
instSize:0
flags:(Behavior flagBehavior).
myClass := newClass.
^ newClass
"Modified: 1.4.1997 / 15:44:50 / stefan"
! !
!Metaclass methodsFor:'fileOut'!
fileOutDefinitionOn:aStream
myClass fileOutClassInstVarDefinitionOn:aStream
"Modified: / 21.6.1998 / 04:10:02 / cg"
! !
!Metaclass methodsFor:'private'!
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 := 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) asText 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) asText 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"
!
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 `' , nm , ''' is an alias for ' , oldClass name , '.\\Change it to the new class ?') withCRs)
ifTrue:[
Smalltalk at:nm put:newClass
]
]
]
].
"Created: 22.10.1996 / 15:20:59 / cg"
"Modified: 22.10.1996 / 15:25:50 / cg"
!
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"
!
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"
!
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.
].
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).
"Modified: 7.6.1996 / 08:34:43 / stefan"
!
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
"
!
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
]
]
]
"Modified: 31.1.1997 / 11:22:57 / cg"
!
recompileMachineCodeMethodsIn:aClass
"recompile all machine-code methods in aClass."
aClass recompileMethodsWithMachineCode.
aClass class recompileMethodsWithMachineCode.
!
setSoleInstance:aClass
myClass := aClass
"Created: 12.12.1995 / 13:46:22 / cg"
! !
!Metaclass methodsFor:'queries'!
category
"return my category"
^ myClass category
"Created: 2.4.1997 / 00:46:11 / stefan"
!
comment
"return my comment"
^ myClass comment
"Created: 2.4.1997 / 00:51:35 / stefan"
!
isBuiltInClass
"return true if this class is known by the run-time-system.
Here, true is returned for myself, false for subclasses."
^ self == Metaclass class or:[self == Metaclass]
"Created: 15.4.1996 / 17:17:34 / cg"
"Modified: 23.4.1996 / 15:59:37 / cg"
!
isMeta
"return true, if the receiver is some kind of metaclass;
true is returned here. Redefines isMeta in Object"
^ true
!
name
"return my name - that is the name of my sole class, with ' class'
appended."
|nm|
myClass isNil ifTrue:[
^ #someMetaclass
].
(nm := myClass name) isNil ifTrue:[
'Metaclass [warning]: no name in my class' errorPrintCR.
^ #'unnamed class'
].
^ nm , ' class'
"Modified: 10.1.1997 / 17:55:08 / cg"
"Modified: 1.4.1997 / 15:53:11 / stefan"
!
nameSpace
"return the nameSpace I am contained in.
Due to the implementation of nameSpaces (as classVariables),
a class can only be contained in one nameSpace (which is the desired)"
"/ this information is in the class
^ myClass nameSpace
"Created: 7.11.1996 / 13:18:52 / cg"
!
owningClass
"return nil here - regular metaclasses are never private"
^ nil
"Created: 12.10.1996 / 20:12:16 / cg"
!
package
"return my package-id"
^ myClass package
"Created: 15.10.1996 / 19:44:51 / cg"
!
soleInstance
"return my sole class."
^ myClass
!
theMetaclass
"return myself; also implemented in my class object, which also returns me."
^ self
"Created: / 30.1.2000 / 23:08:15 / cg"
"Modified: / 31.1.2000 / 16:15:00 / cg"
!
theNonMetaclass
"return my class object, also implemented in my class object, which also returns iteself."
^ self soleInstance
"Created: / 30.1.2000 / 23:08:11 / cg"
"Modified: / 31.1.2000 / 16:17:02 / cg"
!
topOwningClass
"return nil here - regular metaclasses are never private"
^ nil
"Created: 3.1.1997 / 19:18:06 / cg"
! !
!Metaclass methodsFor:'source management'!
binaryRevision
^ myClass binaryRevision
"
Object binaryRevision
Object class binaryRevision
"
"Modified: 2.4.1997 / 01:17:04 / stefan"
!
sourceStream
"return the classes source stream"
^ myClass sourceStream
"Modified: 1.4.1997 / 14:36:31 / stefan"
!
sourceStreamFor:sourceFileName
"return the sourceStream for a sourceFileName"
^ myClass sourceStreamFor:sourceFileName
"Modified: 1.4.1997 / 14:36:38 / stefan"
! !
!Metaclass class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.166 2000-04-13 10:54:34 cg Exp $'
! !
Metaclass initialize!