"

 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:[

        'METACLASS: oops - no name in my class' errorPrintNL.

        name notNil ifTrue:[

            ^ name

        ].

    ].

    ^ nm , 'class'

    "Modified: 7.3.1996 / 19:18:53 / 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

    "

    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 |

	|sels methods|

	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).

	].

	sels := aSubclass selectorArray copy.

	methods := aSubclass methodArray copy.

	newSub setSelectorArray:sels.

	newSub setMethodArray:methods.

	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

    ^ self

	name:newName 

	inEnvironment:aSystemDictionary

	subclassOf:aClass

	instanceVariableNames:stringOfInstVarNames

	variable:variableBoolean

	words:wordsBoolean

	pointers:pointersBoolean

	classVariableNames:stringOfClassVarNames

	poolDictionaries:stringOfPoolNames

	category:categoryString

	comment:commentString

	changed:changed

	classInstanceVariableNames:''

    "Modified: 22.1.1996 / 13:18:08 / 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

             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

     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