"
 COPYRIGHT (c) 1988-93 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:''
       classVariableNames:''
       poolDictionaries:''
       category:'Kernel-Classes'
!

Metaclass comment:'

COPYRIGHT (c) 1988-93 by Claus Gittinger
              All Rights Reserved

every class-class is a subclass of Metaclass
- this adds support for creating new subclasses or changing the definition
of an already existing class.

%W% %E%
'!

!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

    |newClass newMetaclass nInstVars nameString classSymbol oldClass 
     allSubclasses classVarChange instVarChange superClassChange newComment
     upd|

    nInstVars := stringOfInstVarNames countWords.
    nameString := newName asString.
    classSymbol := nameString asSymbol.
    newComment := commentString.

    (aSystemDictionary includesKey:classSymbol) ifTrue:[
        oldClass := aSystemDictionary at:classSymbol.
        (newComment isNil and:[oldClass isBehavior "isKindOf:Class"]) ifTrue:[
            newComment := oldClass comment
        ]
    ].

    "create the metaclass first"
    newMetaclass := Metaclass new.
    newMetaclass setSuperclass:(aClass class).
    newMetaclass instSize:(aClass class instSize).
    newMetaclass flags:0.            "not indexed"
    newMetaclass setName:(nameString , 'class').
    newMetaclass classVariableString:'' "stringOfClassVarNames".
    newMetaclass setComment:newComment category:categoryString.

    newClass := newMetaclass new.
    newClass setSuperclass:aClass.
    newClass instSize:(aClass instSize + nInstVars).

    (variableBoolean == true) ifTrue:[
        pointersBoolean ifTrue:[
            newClass flags:4         "pointerarray"
        ] ifFalse:[
            wordsBoolean ifTrue:[
                newClass flags:2     "wordarray"
            ] ifFalse:[
                newClass flags:1     "bytearray"
            ]
        ]
    ] ifFalse:[
        "this is a backward compatible hack"

        (variableBoolean == #float) ifTrue:[
            newClass flags:6         "float array"
        ] ifFalse:[
            (variableBoolean == #double) ifTrue:[
                newClass flags:7     "double array"
            ] ifFalse:[
                (variableBoolean == #long) ifTrue:[
                    newClass flags:3     "long array"
                ] ifFalse:[
                    newClass flags:0   
                ]
            ]
        ].
    ].

    newClass setName:nameString.
    (nInstVars ~~ 0) ifTrue:[
        newClass instanceVariableString:stringOfInstVarNames
    ].
    oldClass notNil ifTrue:[
        "setting first will make new class clear obsolete classvars"
        newClass setClassVariableString:(oldClass classVariableString)
    ].
    newClass classVariableString:stringOfClassVarNames.

    oldClass notNil ifTrue:[
        "dont have to flush if class is brand-new"

        ObjectMemory flushCaches.
    ].

    aSystemDictionary at:classSymbol put:newClass.

    self addChangeRecordForClass:newClass.

    oldClass isNil ifTrue:[
        commentString notNil ifTrue:[
            newClass comment:commentString
        ]
    ] ifFalse:[
        "if only category/comment has changed, do not recompile .."

        (oldClass superclass == newClass superclass) ifTrue:[
          (oldClass instSize == newClass instSize) ifTrue:[
            (oldClass flags == newClass flags) ifTrue:[
              (oldClass name = newClass name) ifTrue:[
                (oldClass instanceVariableString = newClass instanceVariableString) ifTrue:[
                  (oldClass classVariableString = newClass classVariableString) ifTrue:[
                    (newComment ~= oldClass comment) ifTrue:[
                        oldClass comment:newComment
                    ]. 
                    oldClass category:categoryString. 
                    aSystemDictionary at:classSymbol put:oldClass.
                    oldClass changed.
                    ^ oldClass
                  ]
                ]
              ]
            ]
          ]
        ].

        (newComment ~= oldClass comment) ifTrue:[
            newClass comment:newComment
        ].

        upd := Class updateChanges:false.

        superClassChange := oldClass superclass ~~ newClass superclass.

        classVarChange := oldClass classVariableString ~= newClass classVariableString.

        classVarChange ifTrue:[
            " no need to recompile if classvars are added "
            classVarChange := (newClass classVariableString startsWith: oldClass classVariableString) not
        ].
        classVarChange := classVarChange or:[superClassChange].
        classVarChange := classVarChange or:[self anyInvalidatedMethodsIn: oldClass class].

        classVarChange ifTrue:[
            "must recompile class-methods"
            self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass.
            newMetaclass recompile
        ] ifFalse:[
            "class methods still work"
            self copyMethodsFrom:(oldClass class) for:newMetaclass
        ].

        instVarChange := oldClass instanceVariableString ~= newClass instanceVariableString.
        instVarChange ifTrue:[
            " no need to recompile if instvars are added "
            instVarChange := (newClass instanceVariableString startsWith: oldClass instanceVariableString) not
        ].
        instVarChange := instVarChange or:[superClassChange].
        instVarChange := instVarChange or:[self anyInvalidatedMethodsIn: oldClass].

        (instVarChange or:[classVarChange]) ifTrue:[
            "must recompile instance-methods"
            self copyInvalidatedMethodsFrom:oldClass for:newClass.
            newClass recompile
        ] ifFalse:[
            "instance methods still work"
            self copyMethodsFrom:oldClass for:newClass
        ].

        "get list of all subclasses - do before superclass is changed"

        allSubclasses := oldClass allSubclasses.

        "update superclass of immediate subclasses"

        oldClass subclassesDo:[:aClass |
            aClass superclass:newClass
        ].

        "update instSizes and recompile all subclasses if needed"

        "for subclasses we must be strict"
        classVarChange := oldClass classVariableString ~= newClass classVariableString.
        classVarChange := classVarChange or:[superClassChange].

        "for subclasses we must be strict since offsets change"
        instVarChange := oldClass instanceVariableString ~= newClass instanceVariableString.
        instVarChange := instVarChange or:[superClassChange].

        allSubclasses do:[:aClass |
            aClass instSize:(aClass instSize + (newClass instSize - oldClass instSize)).
            (classVarChange or:[self anyInvalidatedMethodsIn:aClass class]) ifTrue:[
                aClass class recompileAll
            ].
            (classVarChange or:[instVarChange or:[self anyInvalidatedMethodsIn: aClass]]) ifTrue:[
                aClass recompileAll
            ]
        ].

        ObjectMemory flushCaches.
        Class updateChanges:upd
    ].
    oldClass isNil ifTrue:[
        Smalltalk changed
    ] ifFalse:[
        oldClass setName:(oldClass name , '-old')
    ].
    ^ newClass
!

new
    "returs a new class class"
    |newClass|

    newClass := self basicNew.
    newClass setSuperclass:(Object class)
                 selectors:(Array new:0)
                   methods:(Array new:0)
                  instSize:0
                     flags:0.
    newClass setComment:(self comment) category:(self category).
    ^ newClass
! !

!Metaclass methodsFor:'class instance variables'!

instanceVariableNames:aString
    "changing / adding class-inst vars -
     this actually creates a new metaclass and class"

    |newClass newMetaclass nClassInstVars oldClass 
     allSubclasses upd t oldVars sizeChange|

    oldVars := self instanceVariableString.
    aString = oldVars ifTrue:[^ self].

    nClassInstVars := aString countWords.
    sizeChange := nClassInstVars ~~ oldVars countWords.

    "create the new metaclass"
    newMetaclass := Metaclass new.
    newMetaclass setSuperclass:superclass.
    newMetaclass instSize:(superclass instSize + nClassInstVars).
    (nClassInstVars ~~ 0) ifTrue:[
        newMetaclass instanceVariableString:aString
    ].
    newMetaclass flags:0.            "not indexed"
    newMetaclass setName:name.
    newMetaclass classVariableString:classvars.
    newMetaclass category:category.
    newMetaclass setComment: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 a new class"
    newClass := newMetaclass new.
    newClass setSuperclass:(oldClass superclass).
    newClass instSize:(oldClass instSize).
    newClass flags:(oldClass flags).
    newClass setName:(oldClass name).
    newClass instanceVariableString:(oldClass instanceVariableString).
    newClass classVariableString:(oldClass classVariableString).
    newClass comment:(oldClass comment).
    newClass category:(oldClass category).

    ObjectMemory flushCaches.

    Smalltalk at:(oldClass name asSymbol) put:newClass.

    upd := Class updateChanges:false.

    (oldVars isBlank 
    or:[aString startsWith:oldVars]) ifTrue:[
        "there where none before or a new var has been added
         - methods still work"
        self copyMethodsFrom:self for:newMetaclass.
        self copyMethodsFrom:oldClass for:newClass
    ] ifFalse:[
        "recompile class-methods"
        self copyInvalidatedMethodsFrom:self for:newMetaclass.
        newMetaclass recompile.

        "recompile instance-methods"
        self copyInvalidatedMethodsFrom:oldClass for:newClass.
        newClass recompile
    ].

    "get list of all subclasses - do before superclass is changed"

    allSubclasses := oldClass allSubclasses.

    "update superclass of immediate subclasses"

    oldClass subclassesDo:[:aClass |
        aClass superclass:newClass
    ].

    "update instSizes and recompile all subclasses if needed"

    allSubclasses do:[:aClass |
        aClass class recompileAll.
        aClass recompileAll
    ].

    ObjectMemory flushCaches.
    Class updateChanges:upd.
    ^ newMetaclass
! !

!Metaclass methodsFor:'queries'!

isMeta
    "return true, if the receiver is some kind of metaclass;
     true is returned here. Redefines isMeta in Object"

    ^ true
! !

!Metaclass methodsFor:'private'!

copyMethodsFrom:oldClass for:newClass
    "when a class has changed, but metaclass is unaffected (i.e. classVars
     have not changed) there is no need to recompile them"

    newClass selectors:(oldClass selectors) methods:(oldClass methodDictionary)
!

copyInvalidatedMethodsFrom:oldClass for:newClass
    "when a class has been changed, copy all old methods into the new class
     - changing code to a trap method giving an error message;
     this allows us to keep the source while trapping uncompilable (due to
     now undefined instvars) methods"

    |trap trapCode trapByteCode|

    trap := Method compiledMethodAt:#invalidMethod.
    trapCode := trap code.
    trapByteCode := trap byteCode.

    newClass selectors:(oldClass selectors) methods:(oldClass methodDictionary).
    newClass methodDictionary do:[:aMethod |
        aMethod code:trapCode.
        aMethod literals:nil.
        aMethod byteCode:trapByteCode
    ]
!

anyInvalidatedMethodsIn:aClass
    "return true, if aClass has any invalidated methods in it"

    |trap trapCode trapByteCode|

    trap := Method compiledMethodAt:#invalidMethod.
    trapCode := trap code.
    trapByteCode := trap byteCode.

    aClass methodDictionary do:[:aMethod |
        trapCode notNil ifTrue:[
            (aMethod code == trapCode) ifTrue:[^ true]
        ].
        trapByteCode notNil ifTrue:[
            (aMethod byteCode == trapByteCode) ifTrue:[^ true]
        ]
    ].
    ^ false
! !