--- a/Metaclass.st Wed May 28 15:45:01 1997 +0200
+++ b/Metaclass.st Wed May 28 16:28:24 1997 +0200
@@ -10,8 +10,6 @@
hereby transferred.
"
-'From Smalltalk/X, Version:3.1.5 on 3-apr-1997 at 18:08:03' !
-
ClassDescription subclass:#Metaclass
instanceVariableNames:'myClass'
classVariableNames:''
@@ -175,7 +173,6 @@
"/ newMetaclass flags:(Behavior flagBehavior "flagNotIndexed").
"/ newMetaclass setName:name.
"/ newMetaclass classVariableString:classvars.
-"/ newMetaclass category:category.
"/ newMetaclass setComment:(self comment).
"find the class which is my sole instance"
@@ -308,9 +305,7 @@
newSubMeta flags:(oldSubMeta flags).
newSubMeta setName:(oldSubMeta name).
newSubMeta setInstanceVariableString:(oldSubMeta instanceVariableString).
- "/newSubMeta classVariableString:(oldSubMeta classVariableString).
newSubMeta setComment:(oldSubMeta comment).
- newSubMeta category:(oldSubMeta category).
newSub := newSubMeta new.
oldSuper == oldClass ifTrue:[
@@ -327,7 +322,6 @@
oldToNew at:aSubclass put:newSub.
aSubclass category:#'* obsolete *'.
- aSubclass class category:#'* obsolete *'.
].
"recompile what needs to be"
@@ -412,8 +406,8 @@
^ newMetaclass
"Created: 29.10.1995 / 19:57:08 / cg"
- "Modified: 4.11.1996 / 22:12:20 / cg"
"Modified: 1.4.1997 / 15:44:09 / stefan"
+ "Modified: 28.5.1997 / 16:27:37 / cg"
! !
!Metaclass methodsFor:'copying'!
@@ -427,17 +421,17 @@
!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:stringOfClassInstVarNames
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ variable:variableBoolean
+ words:wordsBoolean
+ pointers:pointersBoolean
+ classVariableNames:stringOfClassVarNames
+ poolDictionaries:stringOfPoolNames
+ category:categoryString
+ comment:commentString
+ changed:changed
+ classInstanceVariableNames:stringOfClassInstVarNames
"this is the main workhorse for installing new classes - special care
has to be taken, when changing an existing classes definition. In this
@@ -470,32 +464,32 @@
(newName isSymbol not
or:[newName size == 0]) ifTrue:[
- self error:'invalid class name (must be a nonEmpty symbol)'.
- ^ nil
+ self error:'invalid class name (must be a nonEmpty symbol)'.
+ ^ nil
].
newName first isLetter ifFalse:[
- self error:'invalid class name (must start with a letter)'.
- ^ nil
+ self error:'invalid class name (must start with a letter)'.
+ ^ nil
].
"check for invalid subclassing of UndefinedObject and SmallInteger"
aClass notNil ifTrue:[
- aClass canBeSubclassed ifFalse:[
- self error:('it is not possible to subclass ' , aClass name).
- ^ nil
- ]
+ aClass canBeSubclassed ifFalse:[
+ self error:('it is not possible to subclass ' , aClass name).
+ ^ nil
+ ]
].
"
Check for invalid variable names (duplicates)
"
(self
- checkValidVarNamesFor:newName
- subClassOf:aClass
- instVarNames:stringOfInstVarNames
- classVarNames:stringOfClassVarNames)
+ checkValidVarNamesFor:newName
+ subClassOf:aClass
+ instVarNames:stringOfInstVarNames
+ classVarNames:stringOfClassVarNames)
ifFalse:[
- ^ nil
+ ^ nil
].
nInstVars := stringOfInstVarNames countWords.
@@ -508,136 +502,136 @@
(namespace notNil
and:[namespace isNamespace not]) ifTrue:[
- thisIsPrivate := true.
- realNewName := (namespace name , '::' , classSymbol) asSymbol.
+ thisIsPrivate := true.
+ realNewName := (namespace name , '::' , classSymbol) asSymbol.
] ifFalse:[
- thisIsPrivate := false.
- realNewName := classSymbol.
+ 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
- ].
+ "/ 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 raise
- 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.
- ]
- ]
+ namespace := Smalltalk at:nsName ifAbsent:nil.
+ namespace isNamespace ifFalse:[
+ namespace isNil ifTrue:[
+ (Class createNameSpaceQuerySignal raise
+ 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
+ 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.
- ]
+ thisIsPrivate ifFalse:[
+ oldClass := namespace at:nameKey ifAbsent:[nil].
+ ] ifTrue:[
+ oldClass := namespace privateClassesAt:classSymbol.
+ ]
].
(oldClass isBehavior and:[oldClass isLoaded]) ifFalse:[
- oldClass := nil.
+ oldClass := nil.
- thisIsPrivate ifTrue:[
- Compiler warnSTXSpecials ifTrue:[
- (self confirm:('support for private classes is an ST/X extension.\\continue ?') withCRs)
- ifFalse:[^ 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 superclass notNil ifTrue:[
- oldClass allSuperclasses do:[:cls |
- cls name = realNewName ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
- ]
- ]
- ].
+ oldClass name ~= realNewName ifTrue:[
+ (self confirm:(classSymbol , ' is an alias for ' , oldClass name , '\\continue ?') withCRs)
+ ifFalse:[^ nil].
+ oldClass := nil
+ ] ifFalse:[
+ "/
+ "/ some consisteny checks
+ "/
+ oldClass superclass notNil ifTrue:[
+ oldClass allSuperclasses do:[:cls |
+ cls name = realNewName ifTrue:[
+ self error:'trying to create circular class definition'.
+ ^ nil
+ ]
+ ]
+ ].
- aClass notNil ifTrue:[
- aClass superclass notNil ifTrue:[
- aClass allSuperclasses do:[:cls |
- cls name = realNewName ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
- ]
- ].
- ].
- ].
+ aClass notNil ifTrue:[
+ aClass superclass 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
- ].
+ 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
- ]
- ]
- ]
- ].
+ "
+ 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
- ]
- ]
- ]
- ]
+ "/
+ "/ 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.
@@ -651,36 +645,36 @@
"/ - or use upQueries in future versions.
oldClass isNil ifTrue:[
- (self
- checkConventionsFor:newName
- subClassOf:aClass
- instVarNames:stringOfInstVarNames
- classVarNames:stringOfClassVarNames)
- ifFalse:[
- ^ nil
- ]
+ (self
+ checkConventionsFor:newName
+ subClassOf:aClass
+ instVarNames:stringOfInstVarNames
+ classVarNames:stringOfClassVarNames)
+ ifFalse:[
+ ^ nil
+ ]
].
(self
- checkInstvarRedefsWith:stringOfInstVarNames
- subclassOf:aClass
- old:oldClass
- name:newName) ifFalse:[^ nil].
+ checkInstvarRedefsWith:stringOfInstVarNames
+ subclassOf:aClass
+ old:oldClass
+ name:newName) ifFalse:[^ nil].
nClassInstVars := stringOfClassInstVarNames countWords.
"create the metaclass first"
thisIsPrivate ifTrue:[
- newMetaclass := PrivateMetaclass new
+ newMetaclass := PrivateMetaclass new
] ifFalse:[
- newMetaclass := Metaclass new.
+ newMetaclass := Metaclass new.
].
aClass isNil ifTrue:[
- newMetaclass setSuperclass:Class.
- newMetaclass instSize:(Class instSize + nClassInstVars).
+ newMetaclass setSuperclass:Class.
+ newMetaclass instSize:(Class instSize + nClassInstVars).
] ifFalse:[
- newMetaclass setSuperclass:(aClass class).
- newMetaclass instSize:(aClass class instSize + nClassInstVars).
+ newMetaclass setSuperclass:(aClass class).
+ newMetaclass instSize:(aClass class instSize + nClassInstVars).
].
"/ newMetaclass classVariableString:''.
newMetaclass setInstanceVariableString:stringOfClassInstVarNames.
@@ -689,64 +683,64 @@
newClass := newMetaclass new.
newClass setSuperclass:aClass.
aClass isNil ifTrue:[
- newClass instSize:nInstVars.
+ newClass instSize:nInstVars.
] ifFalse:[
- newClass instSize:(aClass instSize + nInstVars).
+ newClass instSize:(aClass instSize + nInstVars).
].
thisIsPrivate ifTrue:[
- "/ some private class
- newMetaclass setOwningClass:namespace.
+ "/ some private class
+ newMetaclass setOwningClass:namespace.
].
(namespace notNil
and:[namespace ~~ Smalltalk]) ifTrue:[
- newClass setName:(namespace name , '::' , nameKey) asSymbol.
- "/
- "/ if that key exists in smalltalk,
- "/ must recompile everything in that nameSpace,
- "/ which referes to the global.
- "/
- recompileGlobalAccessTo := nameKey.
+ newClass setName:(namespace name , '::' , nameKey) asSymbol.
+ "/
+ "/ if that key exists in smalltalk,
+ "/ must recompile everything in that nameSpace,
+ "/ which referes to the global.
+ "/
+ recompileGlobalAccessTo := nameKey.
] ifFalse:[
- newClass setName:classSymbol.
- recompileGlobalAccessTo := nil.
+ newClass setName:classSymbol.
+ recompileGlobalAccessTo := nil.
].
newClass setComment:newComment category:categoryString.
oldClass notNil ifTrue:[
- "/ copy over classInstanceVariables
- "/ but not those inherited from class
+ "/ 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.
- ].
+ 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:[
- Transcript show:'preserving classInstVar values: '; showCR:newCIVNames.
- newCIVNames do:[:n |
- (oldCIVNames includes:n) ifTrue:[
- newClass instVarNamed:n put:(oldClass instVarNamed:n)
- ]
- ]
- ].
+ newCIVNames size > 0 ifTrue:[
+ 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 prefer the old package
oldClass notNil ifTrue:[
- pkg := oldClass package.
- newClass setBinaryRevision:(oldClass binaryRevision).
+ pkg := oldClass package.
+ newClass setBinaryRevision:(oldClass binaryRevision).
] ifFalse:[
- pkg := Class packageQuerySignal raise
+ pkg := Class packageQuerySignal raise
].
pkg notNil ifTrue:[
- "/ newMetaclass package:pkg.
- newClass package:pkg.
+ "/ newMetaclass package:pkg.
+ newClass package:pkg.
].
"/ Allowing non-booleans as variableBoolean
@@ -755,49 +749,49 @@
"/ 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
- ]
- ]
+ pointersBoolean ifTrue:[
+ newFlags := Behavior flagPointers
+ ] ifFalse:[
+ wordsBoolean ifTrue:[
+ newFlags := Behavior flagWords
+ ] ifFalse:[
+ newFlags := Behavior flagBytes
+ ]
+ ]
] ifFalse:[
- "/ false or symbol.
- newFlags := Behavior flagForSymbolic:variableBoolean.
+ "/ false or symbol.
+ newFlags := Behavior flagForSymbolic:variableBoolean.
].
aClass isNil ifTrue:[
- superFlags := 0
+ superFlags := 0
] ifFalse:[
- superFlags := aClass flags bitAnd:(Behavior maskIndexType bitInvert). "preserve other bits"
+ 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 ...
- "
+ 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))
- ]
+ newFlags := newFlags bitOr:(oldClass flags bitAnd:(Behavior maskIndexType bitInvert))
+ ]
].
newClass flags:(newFlags bitOr:superFlags). "preserve inherited special bits"
(nInstVars ~~ 0) ifTrue:[
- newClass setInstanceVariableString:stringOfInstVarNames
+ newClass setInstanceVariableString:stringOfInstVarNames
].
oldClass notNil ifTrue:[
- "/ setting first will make new class clear obsolete classvars
+ "/ 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 setClassVariableString:(oldClass classVariableString).
+ (spec := oldClass primitiveSpec) notNil ifTrue:[
+ newClass primitiveSpec:spec.
+ newClass setClassFilename:(oldClass classFilename).
+ ]
].
newClass classVariableString:stringOfClassVarNames.
@@ -811,56 +805,56 @@
]
].
- commentString notNil ifTrue:[
- newClass comment:commentString
- ].
- namespace notNil ifTrue:[
- thisIsPrivate ifTrue:[
- namespace privateClassesAt:classSymbol put:newClass.
- ] ifFalse:[
- namespace at:nameKey put: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 raise)
- ].
+ oldClass isNil ifTrue:[
+ newClass package:(Class packageQuerySignal raise)
+ ].
- oldClass notNil ifTrue:[
- "/ since we changed the classes inheritance (from Autoloaded)
+ oldClass notNil ifTrue:[
+ "/ since we changed the classes inheritance (from Autoloaded)
- "/ actually, could optimize to:
- "/ Behavior updateSuperclassInfoFor:oldClass superclass.
- "/ Behavior updateSuperclassInfoFor:newClass superclass.
+ "/ actually, could optimize to:
+ "/ Behavior updateSuperclassInfoFor:oldClass superclass.
+ "/ Behavior updateSuperclassInfoFor:newClass superclass.
- Behavior flushSubclassInfo.
- ].
+ Behavior flushSubclassInfo.
+ ].
- namespace notNil ifTrue:[
- thisIsPrivate ifTrue:[
- namespace changed.
- ] ifFalse:[
- namespace changed:#newClass with:newClass.
- namespace ~~ Smalltalk ifTrue:[
- Smalltalk changed:#newClass with:newClass.
- ]
- ]
- ].
+ namespace notNil ifTrue:[
+ thisIsPrivate ifTrue:[
+ namespace changed.
+ ] ifFalse:[
+ namespace changed:#newClass with:newClass.
+ namespace ~~ Smalltalk ifTrue:[
+ Smalltalk changed:#newClass with:newClass.
+ ]
+ ]
+ ].
- namespace isNamespace ifTrue:[
- "/ be very careful, when adding classes
- "/ to a namespace. When adding, all methods within the
- "/ same namespace which access the unprefixed-global
- "/ must be recompiled (so they access the new class)
+ namespace isNamespace ifTrue:[
+ "/ be very careful, when adding classes
+ "/ to a namespace. When adding, all methods within the
+ "/ same namespace which access the unprefixed-global
+ "/ must be recompiled (so they access the new class)
- recompileGlobalAccessTo notNil ifTrue:[
- self recompileGlobalAccessorsTo:recompileGlobalAccessTo
- in:namespace
- except:newClass
- ].
- ].
+ recompileGlobalAccessTo notNil ifTrue:[
+ self recompileGlobalAccessorsTo:recompileGlobalAccessTo
+ in:namespace
+ except:newClass
+ ].
+ ].
- ^ newClass
+ ^ newClass
].
"/ here comes the hard part - we are actually changing the
@@ -884,123 +878,123 @@
superClassChange ifFalse:[
(oldClass instSize == newClass instSize) ifTrue:[
- (oldClass flags == newClass flags) ifTrue:[
- (oldClass name = newClass name) ifTrue:[
- (oldInstVars = newInstVars) 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.
- ]
- ].
+ (newComment ~= oldClass comment) ifTrue:[
+ oldClass setComment:newComment. "writes a change-chunk"
+ oldClass changed:#comment with:oldClass comment.
+ changed ifTrue:[
+ oldClass addChangeRecordForClassComment:oldClass.
+ ]
+ ].
- (oldClassVars = newClassVars) ifTrue:[
+ (oldClassVars = newClassVars) ifTrue:[
- "/ really no change (just comment and/or category)
+ "/ really no change (just comment and/or category)
- anyChange := false.
+ anyChange := false.
- oldClass setInstanceVariableString:(newClass instanceVariableString).
- oldClass setClassVariableString:(newClass classVariableString).
+ 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 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
- ].
+ ^ oldClass
+ ].
- "/ when we arrive here, class variables have changed
+ "/ 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.
- ]
- ]
- ].
- ].
+ 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.
+ "/ set class variable string;
+ "/ this also updates the set of class variables
+ "/ by creating new / deleting obsolete ones.
- oldClass classVariableString:stringOfClassVarNames.
+ 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)
- (Smalltalk includesKey:nm asSymbol) ifTrue:[
- changeSet1 add:nm
- ]
- ]
- ].
+ "
+ 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)
+ (Smalltalk includesKey:nm asSymbol) ifTrue:[
+ changeSet1 add:nm
+ ]
+ ]
+ ].
- changeSet1 isEmpty ifFalse:[
+ changeSet1 isEmpty ifFalse:[
- "/ recompile all methods accessing set of changed classvars
- "/ here and also in all subclasses ...
+ "/ recompile all methods accessing set of changed classvars
+ "/ here and also in all subclasses ...
- "/ dont update change file for the recompilation
+ "/ dont update change file for the recompilation
- Class withoutUpdatingChangesDo:[
+ Class withoutUpdatingChangesDo:[
" "
- Transcript showCR:'recompiling class & inst methods accessing ' , changeSet1 printString.
- Transcript endEntry.
+ Transcript showCR:'recompiling class & inst methods accessing ' , changeSet1 printString.
+ Transcript endEntry.
" "
- oldClass withAllSubclasses do:[:aClass |
- aClass class recompileMethodsAccessingAny:changeSet1.
- aClass recompileMethodsAccessingAny:changeSet1.
- ].
- ].
- ].
+ oldClass withAllSubclasses do:[:aClass |
+ aClass class recompileMethodsAccessingAny:changeSet1.
+ aClass recompileMethodsAccessingAny:changeSet1.
+ ].
+ ].
+ ].
- "notify change of class"
- changed ifTrue:[
- oldClass addChangeRecordForClass:oldClass.
- ].
- oldClass changed:#definition.
+ "notify change of class"
+ changed ifTrue:[
+ oldClass addChangeRecordForClass:oldClass.
+ ].
+ oldClass changed:#definition.
- ^ oldClass
- ]
- ]
- ]
+ ^ oldClass
+ ]
+ ]
+ ]
]
].
@@ -1008,14 +1002,14 @@
"/ since instance variable layout and/or inheritance has changed.
(newComment ~= oldClass comment) ifTrue:[
- newClass comment:newComment
+ 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
+ self error:'the inheritance of this class is fixed - you cannot change it'.
+ ^ oldClass
].
"/ since we will change the inheritance of some class(es)
@@ -1026,13 +1020,13 @@
"/ only log if this is not the case.
changed ifTrue:[
- (superClassChange
- and:[(oldSuperClass isNil or:[oldSuperClass name = newSuperClass name])
- and:[(oldClassVars = newClassVars)
- and:[(oldInstVars = newInstVars)
- and:[newComment = oldClass comment]]]]) ifFalse:[
- newClass addChangeRecordForClass:newClass.
- ]
+ (superClassChange
+ and:[(oldSuperClass isNil or:[oldSuperClass name = newSuperClass name])
+ and:[(oldClassVars = newClassVars)
+ and:[(oldInstVars = newInstVars)
+ and:[newComment = oldClass comment]]]]) ifFalse:[
+ newClass addChangeRecordForClass:newClass.
+ ]
].
"/ care for class methods ...
@@ -1042,170 +1036,170 @@
classVarChange := false.
superClassChange ifTrue:[
- (oldSuperClass notNil
- and:[newSuperClass notNil
- and:[oldSuperClass allClassVarNames = newSuperClass allClassVarNames
- and:[oldSuperClass name = newSuperClass name
- and:[oldClassVars = newClassVars]]]])
- 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.
+ Transcript showCR:'keep class methods (same classvars)'.
+ Transcript endEntry.
" "
- "/ class methods still work
+ "/ class methods still work
- self copyMethodsFrom:(oldClass class) for:newMetaclass
- ] 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.)
+ self copyMethodsFrom:(oldClass class) for:newMetaclass
+ ] 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].
+ oldClass allClassVarNames do:[:nm | changeSet1 add:nm].
+ newClass allClassVarNames do:[:nm | changeSet1 add:nm].
" "
- Transcript showCR:'recompiling class methods accessing any classvar'.
- Transcript endEntry.
+ Transcript showCR:'recompiling class methods accessing any classvar'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:(oldClass class)
- for:newMetaclass
- accessingAny:changeSet1
- orSuper:true.
- newMetaclass recompileInvalidatedMethods.
- ]
+ self copyInvalidatedMethodsFrom:(oldClass class)
+ for:newMetaclass
+ accessingAny:changeSet1
+ orSuper:true.
+ newMetaclass recompileInvalidatedMethods.
+ ]
]ifFalse:[
- "/ same superclass, find out which classvars have changed
+ "/ 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
- ]
- ].
+ 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
+ "/ must recompile some class-methods
" "
- Transcript showCR:'recompiling class methods accessing ' , changeSet1 printString.
- Transcript endEntry.
+ Transcript showCR:'recompiling class methods accessing ' , changeSet1 printString.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
- newMetaclass recompileInvalidatedMethods.
- ] ifFalse:[
+ self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
+ newMetaclass recompileInvalidatedMethods.
+ ] ifFalse:[
- "/ class methods still work
+ "/ class methods still work
- self copyMethodsFrom:(oldClass class) for:newMetaclass
- ].
+ 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
+ "/ 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
+ "/ the changeset consists of instance variables,
+ "/ with a different position
- changeSet2 := self differentInstanceVariableOffsetsIn:oldClass and:newClass.
+ changeSet2 := self differentInstanceVariableOffsetsIn:oldClass and:newClass.
- "/ merge in the changed class variables
+ "/ merge in the changed class variables
- changeSet1 do:[:nm | changeSet2 add:nm].
+ changeSet1 do:[:nm | changeSet2 add:nm].
" "
- Transcript showCR:'recompiling instance methods accessing ' , changeSet2 printString , ' [superclass change]...'.
- Transcript endEntry.
+ Transcript showCR:'recompiling instance methods accessing ' , changeSet2 printString , ' [superclass change]...'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:oldClass
- for:newClass
- accessingAny:changeSet2
- orSuper:true.
- newClass recompileInvalidatedMethods.
+ self copyInvalidatedMethodsFrom:oldClass
+ for:newClass
+ accessingAny:changeSet2
+ orSuper:true.
+ newClass recompileInvalidatedMethods.
] ifFalse:[
- "/ same inheritance ...
+ "/ same inheritance ...
- instVarChange := oldInstVars ~= newInstVars.
- instVarChange ifFalse:[
+ instVarChange := oldInstVars ~= newInstVars.
+ instVarChange ifFalse:[
- "/ same instance variables ...
+ "/ same instance variables ...
- classVarChange ifTrue:[
- "recompile all inst methods accessing changed classvars"
+ classVarChange ifTrue:[
+ "recompile all inst methods accessing changed classvars"
" "
- Transcript showCR:'recompiling instance methods accessing classvars ' , changeSet1 printString , ' ...'.
- Transcript endEntry.
+ Transcript showCR:'recompiling instance methods accessing classvars ' , changeSet1 printString , ' ...'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.
- newClass recompileInvalidatedMethods.
- ]
- ] ifTrue:[
+ self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.
+ newClass recompileInvalidatedMethods.
+ ]
+ ] ifTrue:[
- "/ dont allow built-in classes to be modified
+ "/ 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
- ].
+ (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:[
+ ((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)
+ "/ 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.
+ Transcript showCR:'copying methods ...'.
+ Transcript endEntry.
" "
- self copyMethodsFrom:oldClass for:newClass.
+ self copyMethodsFrom:oldClass for:newClass.
- "/ but: we have to recompile all methods accessing new instars
- "/ (it might have been a classVar/global before ...)
+ "/ 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].
+ addedNames := newInstVars select:[:nm | (oldInstVars includes:nm) not].
+ "merge in class variables"
+ changeSet1 do:[:nm | addedNames add:nm].
" "
- Transcript showCR:'recompiling instance methods accessing ' , addedNames printString , '...'.
- Transcript endEntry.
+ Transcript showCR:'recompiling instance methods accessing ' , addedNames printString , '...'.
+ Transcript endEntry.
" "
- newClass recompileMethodsAccessingAny:addedNames.
- ] ifFalse:[
+ newClass recompileMethodsAccessingAny:addedNames.
+ ] ifFalse:[
- "/ the changeset consists of instance variables,
- "/ with a different position
+ "/ the changeset consists of instance variables,
+ "/ with a different position
- changeSet2 := self differentInstanceVariableOffsetsIn:oldClass and:newClass.
+ changeSet2 := self differentInstanceVariableOffsetsIn:oldClass and:newClass.
- "merge in the class variables"
- changeSet1 do:[:nm | changeSet2 add:nm].
+ "merge in the class variables"
+ changeSet1 do:[:nm | changeSet2 add:nm].
" "
- Transcript showCR:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
- Transcript endEntry.
+ Transcript showCR:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
- newClass recompileInvalidatedMethods.
- ].
- ].
+ self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
+ newClass recompileInvalidatedMethods.
+ ].
+ ].
].
"/ WOW, everything done for this class
@@ -1216,46 +1210,45 @@
"/ (dont update change file for the subclass changes)
Class withoutUpdatingChangesDo:[
- oldClass subclasses copy do:[:aClass |
+ oldClass subclasses copy do:[:aClass |
" "
- Transcript showCR:'changing superclass of:' , aClass name.
- Transcript endEntry.
+ Transcript showCR:'changing superclass of:' , aClass name.
+ Transcript endEntry.
" "
- aClass superclass:newClass
- ]
+ aClass superclass:newClass
+ ]
].
"/ change any private subclasses' owners
oldClass privateClassesDo:[:aClass |
- aClass class setOwningClass:newClass
+ aClass class setOwningClass:newClass
].
"/ change category in oldClass - so we see immediately what it is ...
oldCategory := oldClass category.
oldClass category:#'* obsolete *'.
- oldClass class 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.
- ].
+ 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.
- ]
- ]
- ].
+ 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;
@@ -1277,7 +1270,7 @@
"Created: 26.5.1996 / 11:55:26 / cg"
"Modified: 18.6.1996 / 14:19:39 / stefan"
- "Modified: 23.4.1997 / 17:14:17 / cg"
+ "Modified: 28.5.1997 / 16:25:47 / cg"
!
name:newName inEnvironment:aSystemDictionary
@@ -1826,5 +1819,5 @@
!Metaclass class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.111 1997-05-27 08:36:04 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.112 1997-05-28 14:28:24 cg Exp $'
! !