"

 COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libbasic' }"

ClassDescription subclass:#Metaclass

	instanceVariableNames:'myClass'

	classVariableNames:'ConfirmationQuerySignal'

	poolDictionaries:''

	category:'Kernel-Classes'

!

!Metaclass class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    every classes class is a subclass of Metaclass.

    (i.e. every class is the sole instance of its Metaclass)

    Metaclass provides support for creating new (sub)classes and/or 

    changing the definition of an already existing class.

    [author:]

	Claus Gittinger

    [see also:]

	Behavior ClassDescription Class

"

! !

!Metaclass class methodsFor:'Signal constants'!

confirmationQuerySignal

    "return the query signal which is raised to ask if user

     confirmation dialogs should be opened.

     If unhandled, they are."

    ^ ConfirmationQuerySignal

    "Created: 31.7.1997 / 21:55:39 / cg"

! !

!Metaclass class methodsFor:'class initialization'!

initialize

    ConfirmationQuerySignal := QuerySignal new defaultAnswer:true

    "Modified: 31.7.1997 / 21:54:44 / cg"

! !

!Metaclass class methodsFor:'creating metaclasses'!

new

    "creating a new metaclass - have to set the new classes

     flags correctly to have it behave like a metaclass ...

     Not for normal applications - creating new metaclasses is a very

     tricky thing; should be left to the gurus ;-)"

    |newMetaclass|

    newMetaclass := super new.

    newMetaclass instSize:(Class instSize).

    newMetaclass setSuperclass:Class.

    ^ newMetaclass

    "

     Metaclass new           <- new metaclass

     Metaclass new new       <- new class

     Metaclass new new new   <- new instance

    "

! !

!Metaclass class methodsFor:'queries'!

isBuiltInClass

    "return true if this class is known by the run-time-system.

     Here, true is returned for myself, false for subclasses."

    ^ self == Metaclass class or:[self == Metaclass]

    "Modified: 23.4.1996 / 15:59:44 / cg"

! !

!Metaclass methodsFor:'Compatibility - ST80'!

comment:aString

    "ignored - sometimes found in ST-80 fileOut files.

     Comments are supposed to be defined via class messages."

    "Created: 9.10.1997 / 18:14:34 / cg"

!

sourceCodeTemplate

    "ST80 compatibility - return a definition message for myself.

     Same as #definition"

    ^ self soleInstance definition

    "Created: / 1.11.1997 / 13:16:45 / cg"

! !

!Metaclass methodsFor:'autoload check'!

isLoaded

    "return true, if the class has been loaded; 

     redefined in Autoload; see comment there"

    ^ myClass isLoaded

! !

!Metaclass methodsFor:'class instance variables'!

instanceVariableNames:aString

    "changing / adding class-inst vars -

     this actually creates a new metaclass and class, leaving the original

     classes around as obsolete classes. This may also be true for all subclasses,

     if class instance variables are added/removed.

     Existing instances continue to be defined by their original classes.

     Time will show, if this is an acceptable behavior or if we should migrate

     instances to become insts. of the new classes."

    |newClass newMetaclass nClassInstVars oldClass 

     allSubclasses oldVars

     oldNames newNames addedNames

     oldOffsets newOffsets offset changeSet delta

     oldToNew newSubMeta newSub oldSubMeta oldSuper

     commonClassInstVars t|

    "

     cleanup needed here: extract common things with name:inEnvironment:...

     and restructure things ... currently way too complex.

    "

    oldVars := self instanceVariableString.

    aString = oldVars ifTrue:[

"

        Transcript showCR:'no change (', oldVars , ') -> (', aString , ')'.

"

        ^ self

    ].

    oldNames := oldVars asCollectionOfWords.

    newNames := aString asCollectionOfWords.

    oldNames = newNames ifTrue:[

"

        Transcript showCR:'no real change'.

"

        "no real change (just formatting)"

        self setInstanceVariableString:aString.

        ^ self

    ]. 

"/    "

"/     let user confirm, if any name is no good (and was good before)

"/    "

"/    (oldNames inject:true

"/                into:[:okSoFar :word |

"/                         okSoFar and:[word first isUppercase]

"/                     ])

"/    ifTrue:[

"/        "was ok before"

"/        (newNames inject:true

"/                    into:[:okSoFar :word |

"/                             okSoFar and:[word first isUppercase]

"/                         ])

"/        ifFalse:[

"/            (self confirm:'class instance variable names should start with an uppercase letter

"/(by convention only)

"/

"/install anyway ?' withCRs)

"/            ifFalse:[

"/                ^ nil

"/            ]

"/        ]

"/    ].

    nClassInstVars := newNames size.

"

    Transcript showCR:'create new class/metaclass'.

"

    "

     create the new metaclass

    "

    self isPrivate ifTrue:[

        newMetaclass := PrivateMetaclass new.

        newMetaclass setOwningClass:(self owningClass).

    ] ifFalse:[

        newMetaclass := Metaclass new.

    ].

    newMetaclass setSuperclass:superclass.

    newMetaclass instSize:(superclass instSize + nClassInstVars).

    (nClassInstVars ~~ 0) ifTrue:[

        newMetaclass setInstanceVariableString:aString

    ].

"/    newMetaclass flags:(Behavior flagBehavior "flagNotIndexed").

"/    newMetaclass setName:name.

"/    newMetaclass classVariableString:classvars.

"/    newMetaclass setComment:(self comment).

    "find the class which is my sole instance"

    oldClass := myClass.

    "

     create the new class

    "

    newClass := newMetaclass new.

    newClass setSuperclass:(oldClass superclass).

    newClass instSize:(oldClass instSize).

    newClass flags:(oldClass flags).

    newClass setName:(oldClass name).

    newClass setInstanceVariableString:(oldClass instanceVariableString).

    newClass classVariableString:(oldClass classVariableString).

    newClass setComment:(oldClass comment).

    newClass category:(oldClass category).

    (t := oldClass primitiveSpec) notNil ifTrue:[

        newClass primitiveSpec:t.

    ].        

    newClass setClassFilename:(oldClass classFilename).

    "/ set the new classes package

    "/ from the old package

    newClass package:(oldClass package).

    "/ and keep the binary revision

    newClass setBinaryRevision:(oldClass binaryRevision).

    changeSet := Set new.

    ((oldNames size == 0) 

    or:[newNames startsWith:oldNames]) ifTrue:[

        "new variable(s) has/have been added - old methods still work"

"/        Transcript showCR:'copying methods ...'.

"/        Transcript endEntry.

        self copyMethodsFrom:self for:newMetaclass.

        self copyMethodsFrom:oldClass for:newClass.

        "

         but have to recompile methods accessing stuff now defined

         (it might have been a global/undeclared before ...)

        "

        addedNames := newNames select:[:nm | (oldNames includes:nm) not].

"/        Smalltalk silentLoading ifFalse:[

"/            Transcript showCR:'recompiling class methods of ' , newMetaclass name ,

"/                              ' accessing any of ' , addedNames printString.

"/        ].

        "recompile class-methods"    

        newMetaclass recompileMethodsAccessingAny:addedNames.

    ] ifFalse:[

        "

         create the changeSet; thats the set of class instvar names

         which have changed their position or are new

        "

        offset := 0. oldOffsets := Dictionary new.

        oldNames do:[:nm | offset := offset + 1. oldOffsets at:nm put:offset].

        offset := 0. newOffsets := Dictionary new.

        newNames do:[:nm | offset := offset + 1. newOffsets at:nm put:offset].

        oldOffsets associationsDo:[:a |

            |k|

            k := a key.

            (newOffsets includesKey:k) ifFalse:[

                changeSet add:k

            ] ifTrue:[

                (a value ~~ (newOffsets at:k)) ifTrue:[

                    changeSet add:k

                ]

            ]

        ].

        newOffsets associationsDo:[:a |

            |k|

            k := a key.

            (oldOffsets includesKey:k) ifFalse:[

                changeSet add:k

            ] ifTrue:[

                (a value ~~ (oldOffsets at:k)) ifTrue:[

                    changeSet add:k

                ]

            ]

        ].

"/        Smalltalk silentLoading ifFalse:[

"/            Transcript showCR:'recompiling class methods of ' , newMetaclass name ,

"/                              ' accessing any of ' , changeSet printString.

"/        ].

        "

         recompile class-methods accessing any c-instvar with a changed position

        "

        self copyInvalidatedMethodsFrom:self for:newMetaclass accessingAny:changeSet.

        newMetaclass recompileInvalidatedMethods.

        self copyMethodsFrom:oldClass for:newClass.

    ].

    delta := newNames size - oldNames size.

    "/ preserve existing classInstVar values (but not those from Class)

    newMetaclass allInstVarNames do:[:nm |

        |v|

        (Class class allInstVarNames includes:nm) ifFalse:[

            v := oldClass instVarNamed:nm ifAbsent:nil.

            v notNil ifTrue:[

                newClass instVarNamed:nm put:v.    

            ].

        ].

    ].

    "

     get list of all subclasses - do before superclass is changed

    "

    allSubclasses := oldClass allSubclasses asOrderedCollection.

    "/ cg: wrong: allSubclasses := allSubclasses asSortedCollection:[:a :b | b isSubclassOf:a].

    allSubclasses := allSubclasses topologicalSort:[:a :b | b isSubclassOf:a]. 

    oldToNew := IdentityDictionary new.

    "

     create a new class tree, based on the new version

    "

    allSubclasses do:[:aSubclass |

        oldSuper := aSubclass superclass.

        oldSubMeta := aSubclass class.

        newSubMeta := Metaclass new.

        oldSuper == oldClass ifTrue:[

            newSubMeta setSuperclass:newMetaclass.

        ] ifFalse:[

            newSubMeta setSuperclass:(oldToNew at:oldSuper) class.

        ].

        newSubMeta instSize:(oldSubMeta instSize + delta).

        newSubMeta flags:(oldSubMeta flags).

"/        newSubMeta setName:(oldSubMeta name).

        newSubMeta setInstanceVariableString:(oldSubMeta instanceVariableString).

"/        newSubMeta setComment:(oldSubMeta comment).

        newSub := newSubMeta new.

        oldSuper == oldClass ifTrue:[

            newSub setSuperclass:newClass.

        ] ifFalse:[

            newSub setSuperclass:(oldToNew at:oldSuper).

        ].

"/        newSub setMethodDictionary:(aSubclass methodDictionary copy).

"/        newSub class setMethodDictionary:(aSubclass class methodDictionary copy).

        newSub setName:(aSubclass name).

        newSub classVariableString:(aSubclass classVariableString).

        newSub setInstanceVariableString:(aSubclass instanceVariableString).

        (t := aSubclass primitiveSpec) notNil ifTrue:[

            newSub primitiveSpec:t.

        ].

        newSub package:(aSubclass package).

        newSub setClassFilename:(oldClass classFilename).

        newSub setComment:(aSubclass comment).

        newSub category:(aSubclass category).

        newSub instSize:(aSubclass instSize).

        newSub setBinaryRevision:(aSubclass binaryRevision).

        oldToNew at:aSubclass put:newSub.

        aSubclass category:#'* obsolete *'.

        "/ preserve existing classInstVar values (but not those from Class)

        newSubMeta allInstVarNames do:[:nm |

            |v|

            (Class class allInstVarNames includes:nm) ifFalse:[

                v := aSubclass instVarNamed:nm ifAbsent:nil.

                v notNil ifTrue:[

                    newSub instVarNamed:nm put:v.    

                ].

            ].

        ].

    ].

    "recompile what needs to be"

    delta == 0 ifTrue:[

        "only have to recompile class methods accessing 

         class instvars from changeset

        "

        allSubclasses do:[:oldSubclass |

            |newSubclass|

            newSubclass := oldToNew at:oldSubclass.

"/            Smalltalk silentLoading ifFalse:[

"/                Transcript showCR:'recompiling class methods of ' , newSubclass class name ,

"/                                  ' accessing any of ' , changeSet printString.

"/            ].

            self 

                copyInvalidatedMethodsFrom:oldSubclass class for:newSubclass class 

                accessingAny:changeSet orSuper:true.

            self 

                copyInvalidatedMethodsFrom:oldSubclass for:newSubclass 

                accessingAny:#() orSuper:true.

            newSubclass class recompileInvalidatedMethods.

            newSubclass recompileInvalidatedMethods.

        ]

    ] ifFalse:[

        "

         have to recompile all class methods accessing class instvars

        "

        commonClassInstVars := oldClass class allInstVarNames.

        changeSet do:[:v |

            commonClassInstVars remove:v ifAbsent:[]

        ].

        allSubclasses do:[:oldSubclass |

            |newSubclass classInstVars|

            newSubclass := oldToNew at:oldSubclass.

            classInstVars := newSubclass class allInstVarNames asSet.

            classInstVars removeAll:commonClassInstVars.

            classInstVars addAll:changeSet.

"/            Smalltalk silentLoading ifFalse:[

"/                Transcript showCR:'recompiling class methods of ' , newSubclass class name ,

"/                                  ' accessing any of ' , classInstVars printString.

"/            ].

            self 

                copyInvalidatedMethodsFrom:oldSubclass class for:newSubclass class 

                accessingAny:classInstVars orSuper:true.

            self