Add SemaphoreSet.
"
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.
"
Class subclass:#Metaclass
instanceVariableNames:'myClass'
classVariableNames:''
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.
"
! !
!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 methodsFor:'accessing'!
name
"return my name - that is the name of my sole class, with 'class'
appended. Currently, this is incompatible to ST-80 (which appends ' class')
and will be changed (have to check for side effects first ...)"
|nm|
myClass isNil ifTrue:[
^ 'someMetaclass'
].
"/ ^ myClass name , ' class'
(nm := myClass name) isNil ifTrue:[
'oops - no name in my class' errorPrintNL.
name notNil ifTrue:[
^ name
].
].
^ nm , 'class'
! !
!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 currentProject 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
"
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 category:category.
newMetaclass setComment:(self comment).
"find the class which is my sole instance"
t := Smalltalk allClasses select:[:element | element class == self].
(t size ~~ 1) ifTrue:[
self error:'oops - I should have exactly one instance'.
^ nil
].
oldClass := t anElement.
"
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
t := oldClass package.
newMetaclass package:t.
newClass package:t.
"/ and keep the binary revision
newClass setBinaryRevision:(oldClass revision).
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 before ...)
"
addedNames := newNames select:[:nm | (oldNames includes:nm) not].
" "
Transcript showCr:'recompiling methods accessing ' , addedNames printString , '...'.
Transcript endEntry.
" "
"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
]
]
].
" "
Transcript showCr:'recompiling methods accessing ' , changeSet printString , ' ...'.
Transcript endEntry.
" "
"
recompile class-methods
"
self copyInvalidatedMethodsFrom:self for:newMetaclass accessingAny:changeSet.
newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
self copyMethodsFrom:oldClass for:newClass.
].
delta := newNames size - oldNames size.
"
get list of all subclasses - do before superclass is changed
"
allSubclasses := oldClass allSubclasses.
allSubclasses := allSubclasses asSortedCollection:[:a :b |
b isSubclassOf:a
].
oldToNew := IdentityDictionary new.
"
create a new class tree, based on 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 classVariableString:(oldSubMeta classVariableString).
newSubMeta setComment:(oldSubMeta comment).
newSubMeta category:(oldSubMeta category).
newSub := newSubMeta new.
oldSuper == oldClass ifTrue:[
newSub setSuperclass:newClass.
] ifFalse:[
newSub setSuperclass:(oldToNew at:oldSuper).
].
newSub setSelectorArray:(aSubclass selectorArray).
newSub setMethodArray:(aSubclass methodArray).
newSub setName:(aSubclass name).
newSub classVariableString:(aSubclass classVariableString).
newSub setComment:(aSubclass comment).
newSub category:(aSubclass category).
oldToNew at:aSubclass put:newSub.
aSubclass category:'obsolete'.
aSubclass class category:'obsolete'.
].
"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.
Transcript showCr:'recompiling class methods of ' , newSubclass class name ,
' accessing any of ' , changeSet printString.
newSubclass class recompileMethodsAccessingAny:changeSet.
]
] 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.
Transcript showCr:'recompiling class methods of ' , newSubclass class name ,
' accessing any of ' , classInstVars printString.
newSubclass class recompileMethodsAccessingAny:classInstVars.
]
].
self addChangeRecordForClassInstvars:newClass.
"install all new classes"
Smalltalk at:(oldClass name asSymbol) put:newClass.
ObjectMemory flushCachesFor:oldClass.
allSubclasses do:[:oldClass |
|newClass|
newClass := oldToNew at:oldClass.
"
Transcript showCr:'install ' , newClass name , '(' , newClass category , ')' ,
' as ' , newClass name.
"
Smalltalk at:newClass name asSymbol put:newClass.
ObjectMemory flushCachesFor:oldClass.
].
"tell dependents ..."
oldClass changed:#definition.
self changed:#definition.
^ newMetaclass
"Created: 29.10.1995 / 19:57:08 / cg"
"Modified: 9.12.1995 / 17:05:44 / cg"
! !
!Metaclass methodsFor:'copying'!
postCopy
"redefined - a copy may have a new instance"
myClass := nil
! !
!Metaclass methodsFor:'creating classes'!
name:newName inEnvironment:aSystemDictionary
subclassOf:aClass
instanceVariableNames:stringOfInstVarNames
variable:variableBoolean
words:wordsBoolean
pointers:pointersBoolean
classVariableNames:stringOfClassVarNames
poolDictionaries:stringOfPoolNames
category:categoryString
comment:commentString
changed:changed
"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 oldClass
classVarChange instVarChange superClassChange newComment
changeSet1 changeSet2 addedNames
anyChange oldInstVars newInstVars oldClassVars newClassVars superFlags newFlags
project currentProject t|
"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 ...
"
project := Project. "/ have to fetch this before, in case its autoloaded
newName = aClass name ifTrue:[
self error:'trying to create circular class definition'.
^ nil
].
"check for invalid subclassing of UndefinedObject and SmallInteger"
aClass canBeSubclassed ifFalse:[
self error:('it is not possible to subclass ' , aClass name).
^ nil
].
nInstVars := stringOfInstVarNames countWords.
nameString := newName asString.
classSymbol := newName asSymbol.
newComment := commentString.
"look, if it already exists as a class"
oldClass := aSystemDictionary at:classSymbol ifAbsent:[nil].
oldClass isBehavior ifFalse:[
oldClass := nil.
] ifTrue:[
oldClass name ~= classSymbol ifTrue:[
(self confirm:(classSymbol , ' is an alias for ' , oldClass name , '\\continue ?') withCRs)
ifFalse:[^ self].
oldClass := nil
] ifFalse:[
"/
"/ some consisteny checks
"/
oldClass superclass notNil ifTrue:[
oldClass allSuperclasses do:[:cls |
cls name = nameString ifTrue:[
self error:'trying to create circular class definition'.
^ nil
]
]
].
aClass superclass notNil ifTrue:[
aClass allSuperclasses do:[:cls |
cls name = nameString 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).
"
oldClass isNil ifTrue:[
(self checkConventionsFor:newName
instVarNames:stringOfInstVarNames
classVarNames:stringOfClassVarNames) ifFalse:[
^ nil
]
].
"create the metaclass first"
newMetaclass := Metaclass new.
newMetaclass setSuperclass:(aClass class).
newMetaclass instSize:(aClass class instSize).
newMetaclass setName:(nameString , 'class') asSymbol.
newMetaclass classVariableString:'' "stringOfClassVarNames".
"/ newMetaclass setComment:newComment category:categoryString.
"then let the new meta create the class"
newClass := newMetaclass new.
newClass setSuperclass:aClass.
newClass instSize:(aClass instSize + nInstVars).
newClass setName:classSymbol.
newClass setComment:newComment category:categoryString.
"/ set the new classes package
"/ but prefer the old package
oldClass notNil ifTrue:[
t := oldClass package.
newClass setBinaryRevision:(oldClass revision).
] ifFalse:[
project notNil ifTrue:[
currentProject := project current.
currentProject notNil ifTrue:[
t := currentProject packageName.
]
].
].
t notNil ifTrue:[
newMetaclass package:t.
newClass package:t.
].
"
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:[
(variableBoolean == #float) ifTrue:[
newFlags := Behavior flagFloats
] ifFalse:[
(variableBoolean == #double) ifTrue:[
newFlags := Behavior flagDoubles
] ifFalse:[
(variableBoolean == #long) ifTrue:[
newFlags := Behavior flagLongs
] ifFalse:[
newFlags := Behavior flagNotIndexed
]
]
].
].
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).
(t := oldClass primitiveSpec) notNil ifTrue:[
newClass primitiveSpec:t.
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 ifTrue:[
self addChangeRecordForClass:newClass.
].
commentString notNil ifTrue:[
newClass comment:commentString
].
aSystemDictionary at:classSymbol put:newClass.
oldClass isNil ifTrue:[
project notNil ifTrue:[
currentProject := project current.
currentProject notNil ifTrue:[
"
new classes get the package assigned
"
newClass package:(currentProject packageName asSymbol)
]
].
].
aSystemDictionary changed:#newClass with: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.
"
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.
"
(oldClass superclass == newClass superclass) ifTrue:[
(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.
self addChangeRecordForClassComment:oldClass.
].
(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.
self addChangeRecordForClass:newClass.
"notify change of organization"
aSystemDictionary 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.
"notify change of organization"
aSystemDictionary 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:[
changeSet1 add:nm
]
].
newClassVars do:[:nm |
(oldClassVars includes:nm) ifFalse:[
changeSet1 add:nm
]
].
"
recompile all methods accessing set of changed classvars
here and also in all subclasses ...
"
"
dont update change file for the recompilation
"
Class withoutUpdatingChangesDo:[
" "
Transcript showCr:'recompiling class & inst methods accessing ' , changeSet1 printString.
Transcript endEntry.
" "
oldClass withAllSubclasses do:[:aClass |
aClass class recompileMethodsAccessingAny:changeSet1.
aClass recompileMethodsAccessingAny:changeSet1.
].
].
"notify change of class"
self addChangeRecordForClass:oldClass.
oldClass changed:#definition.
^ oldClass
]
]
]
]
].
"
here we enter the darkness of mordor ...
since instance variable layout and/or inheritance has changed.
"
(newComment ~= oldClass comment) ifTrue:[
newClass comment:newComment
].
superClassChange := oldClass superclass ~~ newClass superclass.
"
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
].
"
catch special case, where superclass changed its layout and thus
forced redefinition of this class;
only log if this is not the case.
"
(superClassChange
and:[(oldClass superclass isNil or:[oldClass superclass name = newClass superclass name])
and:[(oldClassVars = newClassVars)
and:[(oldInstVars = newInstVars)
and:[newComment = oldClass comment]]]]) ifFalse:[
self addChangeRecordForClass:newClass.
].
"
care for class methods ...
"
changeSet1 := Set new.
classVarChange := false.
superClassChange ifTrue:[
"
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].
" "
Transcript showCr:'recompiling class methods accessing any classvar'.
Transcript endEntry.
" "
self copyInvalidatedMethodsFrom:(oldClass class)
for:newMetaclass
accessingAny:changeSet1
orSuper:true.
newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
] 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
]
].
].
classVarChange ifTrue:[
"
must recompile some class-methods
"
" "
Transcript showCr:'recompiling class methods accessing ' , changeSet1 printString.
Transcript endEntry.
" "
self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
] 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].
" "
Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
Transcript endEntry.
" "
self copyInvalidatedMethodsFrom:oldClass
for:newClass
accessingAny:changeSet2
orSuper:true.
newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
] ifFalse:[
"
same inheritance ...
"
instVarChange := oldInstVars ~= newInstVars.
instVarChange ifFalse:[
"
same instance variables ...
"
classVarChange ifTrue:[
"recompile all inst methods accessing changed classvars"
" "
Transcript showCr:'recompiling instance methods accessing ' , changeSet1 printString , ' ...'.
Transcript endEntry.
" "
self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.
newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
]
] 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].
" "
Transcript showCr:'recompiling instance methods accessing ' , addedNames printString , '...'.
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].
" "
Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
Transcript endEntry.
" "
self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
].
].
].
"
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 withoutUpdatingChangesDo:[
oldClass subclassesDo:[:aClass |
" "
Transcript showCr:'changing superclass of:' , aClass name.
Transcript endEntry.
" "
aClass superclass:newClass
]
].
"
change category in oldClass - so we see immediately what it is ...
"
oldClass category:'obsolete'.
oldClass class category:'obsolete'.
"
and make the new class globally known
"
aSystemDictionary at:classSymbol put:newClass.
oldClass category ~= categoryString ifTrue:[
"notify change of organization"
aSystemDictionary 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.
ObjectMemory flushCaches.
^ newClass
"Created: 9.12.1995 / 17:06:26 / 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
selectors:(Array new:0)
methods:(Array new:0)
instSize:0
flags:(Behavior flagBehavior).
newClass setName:'someClass'.
myClass := newClass.
^ newClass
! !
!Metaclass methodsFor:'private'!
setSoleInstance:aClass
myClass := aClass
"Created: 12.12.1995 / 13:46:22 / cg"
!
anyInvalidatedMethodsIn:aClass
"return true, if aClass has any invalidated methods in it"
|trap trapCode trapByteCode|
trap := Metaclass compiledMethodAt:#invalidCodeObject.
trapCode := trap code.
trapByteCode := trap byteCode.
aClass methodArray do:[:aMethod |
trapCode notNil ifTrue:[
(aMethod code = trapCode) ifTrue:[^ true]
].
trapByteCode notNil ifTrue:[
(aMethod byteCode == trapByteCode) ifTrue:[^ true]
]
].
^ false
!
checkConventionsFor:className 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).
"
"let user confirm, if the classname is no good"
className first isUppercase ifFalse:[
(self confirm:'classename ''' , className , ''' should start with an uppercase letter
(by convention only)
install anyway ?' withCRs)
ifFalse:[
^ false
]
].
"let user confirm, if any instvarname is no good"
(instVarNameString asCollectionOfWords
findFirst:[:word | word first isUppercase]) ~~ 0 ifTrue:[
(self confirm:'instance variable names should start with a lowercase letter
(by convention only)
install anyway ?' withCRs)
ifFalse:[
^ false
]
].
"let user confirm, if any classvarname is no good"
(classVarNameString asCollectionOfWords
findFirst:[:word | word first isLowercase]) ~~ 0 ifTrue:[
(self confirm:'class variable names should start with an uppercase letter
(by convention only)
install anyway ?' withCRs)
ifFalse:[
^ false
].
].
^ true
!
copyInvalidatedMethodsFrom:oldClass for:newClass
"copy all methods from oldClass to newClass and change their code
to a trap method reporting an error.
This is used when a class has been changed its layout or inheritance,
for all methods; before recompilation is attempted.
This allows us to keep the source while trapping uncompilable (due to
now undefined instvars) methods. Compilation of these methods will show
an error on the transcript and lead to the debugger once called."
|trap trapCode trapByteCode oldMethod newMethod oldMethodArray newMethodArray|
trap := Metaclass compiledMethodAt:#invalidCodeObject.
trapCode := trap code.
trapByteCode := trap byteCode.
oldMethodArray := oldClass methodArray.
newMethodArray := Array new:(oldMethodArray size).
newClass selectors:(oldClass selectorArray copy)
methods:newMethodArray.
1 to:oldMethodArray size do:[:i |
oldMethod := oldMethodArray at:i.
oldMethod isWrapped ifTrue:[
oldMethod := oldMethod originalMethod
].
newMethod := oldMethod copy.
newMethod code:trapCode.
newMethod literals:nil.
newMethod byteCode:trapByteCode.
newMethodArray at:i put:newMethod
]
!
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."
|trap trapCode trapByteCode p source mustInvalidate
oldMethod newMethod oldMethodArray newMethodArray|
trap := Metaclass compiledMethodAt:#invalidCodeObject.
trapCode := trap code.
trapByteCode := trap byteCode.
oldMethodArray := oldClass methodArray.
newMethodArray := Array new:(oldMethodArray size).
newClass selectors:(oldClass selectorArray copy)
methods:newMethodArray.
1 to:oldMethodArray size do:[:i |
oldMethod := oldMethodArray at:i.
oldMethod isWrapped ifTrue:[
oldMethod := oldMethod originalMethod
].
"before parsing (which may take some time),
do a string search if its only one variable,
we are looking for."
source := oldMethod source.
((setOfNames size == 1) and:[superBoolean not]) ifTrue:[
mustInvalidate := (source findString:(setOfNames first)) ~~ 0.
] ifFalse:[
((setOfNames size == 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 notNil and:[p usedVars includesAny:setOfNames])
or:[superBoolean and:[p usesSuper]]]) ifFalse:[
mustInvalidate := false
]
].
mustInvalidate ifTrue:[
newMethod := oldMethod copy.
newMethod code:trapCode.
newMethod literals:nil.
newMethod byteCode:trapByteCode
] ifFalse:[
newMethod := oldMethod.
].
newMethodArray at:i put:newMethod
]
!
copyMethodsFrom:oldClass for:newClass
"copy all methods from oldClass to newClass.
This is used for class-methods when a class has changed, but metaclass is
unaffected (i.e. classVars/inheritance have not changed) so there is no need
to recompile the class methods."
newClass selectors:(oldClass selectorArray copy)
methods:(oldClass methodArray copy)
!
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 variables."
|offsets1 offsets2 changeSet|
changeSet := Set new.
"
collect the instvar-indices in the old and new class
"
offsets1 := class1 instanceVariableOffsets.
offsets2 := class2 instanceVariableOffsets.
"
the changeset consists of instance variables,
with 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
"
!
invalidCodeObject
"When recompiling classes after a definition-change, all
uncompilable methods will be bound to this method here,
so that evaluating such an uncompilable method will trigger an error.
Can also happen when Compiler/runtime system is broken."
self error:'invalid method - this method failed to compile when the class was changed'
! !
!Metaclass methodsFor:'queries'!
isMeta
"return true, if the receiver is some kind of metaclass;
true is returned here. Redefines isMeta in Object"
^ true
!
soleInstance
"return my sole class."
^ myClass
! !
!Metaclass class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.41 1995-12-12 12:55:31 cg Exp $'
! !