"

 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.

    [author:]

        Claus Gittinger

    [see also:]

	Behavior ClassDescription 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 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:'accessing'!

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.

        name notNil ifTrue:[

            ^ name

        ].

    ].

    ^ nm , ' class'

    "Modified: 19.6.1996 / 14:30:58 / stefan"

    "Modified: 10.1.1997 / 17:55:08 / 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 category:category.

    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

    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.

        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 setMethodDictionary:(aSubclass methodDictionary copy).

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

    ].

    "tell dependents ..."

    oldClass changed:#definition.

    self changed:#definition.

    ^ newMetaclass

    "Created: 29.10.1995 / 19:57:08 / cg"

    "Modified: 7.6.1996 / 08:43:19 / stefan"

    "Modified: 4.11.1996 / 22:12:20 / 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: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 nameKey oldClass 

     classVarChange instVarChange superClassChange newComment

     changeSet1 changeSet2 addedNames

     anyChange oldInstVars newInstVars oldClassVars newClassVars superFlags newFlags

     pkg idx spec nClassInstVars superInstVars

     realNewName thisIsPrivate oldCIVNames newCIVNames msg nsName namespace

     oldSuperClass newSuperClass globalExistedBefore oldCategory

     recompileGlobalAccessTo|

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