"

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

       classVariableNames:''

       poolDictionaries:''

       category:'Kernel-Classes'

!

Metaclass comment:'

COPYRIGHT (c) 1988 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.

$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.6 1993-12-11 00:50:35 claus Exp $

'!

!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 

     allSubclasses classVarChange instVarChange superClassChange newComment

     changeSet1 changeSet2 offset oldOffsets newOffsets addedNames

     anyChange oldInstVars newInstVars oldClassVars newClassVars upd|

    "this method is too complex and should be splitted into managable pieces ..."

    newName = aClass name ifTrue:[

        self error:'trying to create circular class definition'.

        ^ nil

    ].

    nInstVars := stringOfInstVarNames countWords.

    nameString := newName asString.

    classSymbol := newName asSymbol.

    newComment := commentString.

    "look, if it already exists as a class"

    (aSystemDictionary includesKey:classSymbol) ifTrue:[

        oldClass := aSystemDictionary at:classSymbol.

        (oldClass isBehavior not or:[oldClass name ~= newName]) ifTrue:[

            oldClass := nil.

        ] ifFalse:[

            oldClass allSuperclasses do:[:aClass |

                aClass name = newName ifTrue:[

                    self error:'trying to create circular class definition'.

                    ^ nil

                ]

            ].

            newComment isNil 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 isNil ifTrue:[

        self addChangeRecordForClass:newClass.

        commentString notNil ifTrue:[

            newClass comment:commentString

        ].

        aSystemDictionary at:classSymbol put:newClass.

        Smalltalk changed.

        ^ newClass

    ].

    oldInstVars := oldClass instanceVariableString asCollectionOfWords.

    newInstVars := newClass instanceVariableString asCollectionOfWords.

    oldClassVars := oldClass classVariableString asCollectionOfWords.

    newClassVars := newClass classVariableString asCollectionOfWords.

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

            (oldInstVars = newInstVars) ifTrue:[

              (oldClassVars = newClassVars) ifTrue:[

                anyChange := false.

                oldClass instanceVariableString:(newClass instanceVariableString).

                oldClass setClassVariableString:(newClass classVariableString).

                (newComment ~= oldClass comment) ifTrue:[

                    oldClass comment:newComment.        "already writes change-chunk"

                ]. 

                oldClass category ~= categoryString ifTrue:[

                    "notify change of organization"

                    oldClass category:categoryString. 

                    self addChangeRecordForClass:newClass.

                    Smalltalk changed

                ].

                "notify change of class"

                oldClass changed.

                ^ oldClass

              ]

            ]

          ]

        ]

      ]

    ].

    "tell dependents of class ..."

    oldClass changed.

    "catch special case, where superclass changed its layout and thus

     forced redefinition of this class - this will not be logged here"

    (newComment ~= oldClass comment) ifTrue:[

        newClass comment:newComment

    ].

    superClassChange := oldClass superclass ~~ newClass superclass.

    "dont allow built-in classes to be modified"

    (oldClass notNil and:[oldClass isBuiltInClass and:[superClassChange]]) ifTrue:[

        self error:'the inheritance of this class is fixed - you cannot change it'.

        ^ oldClass

    ].

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

    ].

    changeSet1 := Set new.

    changeSet2 := Set new.

    classVarChange := false.

    superClassChange ifTrue:[

        "superclass changed,

         must recompile all class methods accessing any classvar"

        oldClass allClassVarNames do:[:nm | changeSet1 add:nm].

        newClass allClassVarNames do:[:nm | changeSet1 add:nm].

" "

        Transcript showCr:'recompiling class methods accessing any classvar'.

" "

        self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.

        newMetaclass recompileInvalidatedMethods.

    ] 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

                ]

            ].

        ].

" "

        Transcript showCr:'recompiling class methods accessing ' , changeSet1 printString.

" "

        classVarChange ifTrue:[

            "must recompile class-methods"

            self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.

            newMetaclass recompileInvalidatedMethods.

        ] ifFalse:[

            "class methods still work"

            self copyMethodsFrom:(oldClass class) for:newMetaclass

        ].

    ].

    superClassChange ifTrue:[

        "superclass changed,

         must recompile all class methods accessing any class or instvar"

	"no, if number of instvars is the same, only the changed ones ..."

        "find set of changed instvars"

        offset := 0. oldOffsets := Dictionary new.

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

        offset := 0. newOffsets := Dictionary new.

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

        oldOffsets associationsDo:[:a |

            |k|

            k := a key.

            (newOffsets includesKey:k) ifFalse:[

                changeSet2 add:k

            ] ifTrue:[

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

                    changeSet2 add:k

                ]

            ]

        ].

        newOffsets associationsDo:[:a |

            |k|

            k := a key.

            (oldOffsets includesKey:k) ifFalse:[

                changeSet2 add:k

            ] ifTrue:[

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

                    changeSet2 add:k

                ]

            ]

        ].

        changeSet1 do:[:nm | changeSet2 add:nm].

" "

        Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , '

 ...'.

" "

        self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.

        newClass recompileInvalidatedMethods.

false ifTrue:[

        oldClass allClassVarNames do:[:nm | changeSet1 add:nm].

        newClass allClassVarNames do:[:nm | changeSet1 add:nm].

        oldClass allInstVarNames do:[:nm | changeSet1 add:nm].

        newClass allInstVarNames do:[:nm | changeSet1 add:nm].

" "

        Transcript showCr:'recompiling instance methods accessing any class or instvar' .

" "

        self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.

        newClass recompileInvalidatedMethods.

]

    ] ifFalse:[

        instVarChange := oldInstVars ~= newInstVars.

        instVarChange ifFalse:[

            classVarChange ifTrue:[

                "recompile all inst methods accessing classvars"

" "

                Transcript showCr:'recompiling instance methods accessing ' , changeSet1 printString , ' ...'.

" "

                self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.

                newClass recompileInvalidatedMethods.

            ]

        ] ifTrue:[

            instVarChange := (oldInstVars ~= newInstVars).

            "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

            ].

            instVarChange ifTrue:[

                ((oldInstVars size == 0) 

                or:[newInstVars startsWith:oldInstVars]) ifTrue:[

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

                    Transcript showCr:'copying methods ...'.

                    self copyMethodsFrom:oldClass for:newClass.

                    "but have to recompile methods accessing stuff now defined

                     (it might have been a global before ...)"

                    addedNames := newInstVars select:[:nm | (oldInstVars includes:nm) not].

                    changeSet1 do:[:nm | addedNames add:nm].

" "

                    Transcript showCr:'recompiling instance methods accessing ' , addedNames printString ,  '...'.

" "

                    newClass recompileMethodsAccessingAny:addedNames.

                ] ifFalse:[

                    "find set of changed instvars"

                    offset := 0. oldOffsets := Dictionary new.

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

                    offset := 0. newOffsets := Dictionary new.

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

                    oldOffsets associationsDo:[:a |

                        |k|

                        k := a key.

                        (newOffsets includesKey:k) ifFalse:[

                            changeSet2 add:k

                        ] ifTrue:[

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

                                changeSet2 add:k

                            ]

                        ]

                    ].

                    newOffsets associationsDo:[:a |

                        |k|

                        k := a key.

                        (oldOffsets includesKey:k) ifFalse:[

                            changeSet2 add:k

                        ] ifTrue:[

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

                                changeSet2 add:k

                            ]

                        ]

                    ].

                    changeSet1 do:[:nm | changeSet2 add:nm].

" "

                    Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.

" "

                    self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.

                    newClass recompileInvalidatedMethods.

                ].

            ].

        ].

    ].

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

    allSubclasses := oldClass allSubclasses.

    "update superclass of immediate subclasses - this forces recompilation if needed"

    "dont update change file for the subclass changes"

    upd := Class updateChanges:false.

    [

        oldClass subclassesDo:[:aClass |

" "

            Transcript showCr:'changing superclass of:' , aClass name.

" "

            aClass superclass:newClass

        ]

    ] valueNowOrOnUnwindDo:[

        Class updateChanges:upd.

    ].

    aSystemDictionary at:classSymbol put:newClass.

    ObjectMemory flushCaches.

    ^ newClass

!

new

    "create & return a new metaclass (a classes 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 t oldVars

     oldNames newNames addedNames

     oldOffsets newOffsets offset changeSet delta

     oldToNew newSubMeta newSub oldSubMeta oldSuper|

    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 instanceVariableString:aString.

        ^ self

    ]. 

    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 instanceVariableString:aString

    ].

    newMetaclass flags:0.            "not indexed"

    newMetaclass setName:name.

    newMetaclass classVariableString:classvars.

    newMetaclass category:category.

    newMetaclass setComment:comment.