"{ Package: 'stx:libbasic' }"

Object subclass:#ClassBuilder

	instanceVariableNames:'className environment superClass instanceVariableNames variable

		words pointers classVariableNames poolDictionaries category

		comment changed classInstanceVariableNames oldMetaClass

		realNewName buildPrivateClass'

	classVariableNames:''

	poolDictionaries:''

	category:'Kernel-Support'

!

!ClassBuilder class methodsFor:'checks'!

checkForAliasesOf:oldClass with:newClass

    "oldClass changed its identity (now use newClass).

     check if there are any global aliases, which should also be changed"

    Smalltalk keysAndValuesDo:[:nm :o |

        o == oldClass ifTrue:[

            nm ~~ oldClass name ifTrue:[

                (self confirm:('The global/classVar `' , nm , ''' is an alias for ' , oldClass name , '.\\Change it to the new class ?') withCRs)

                ifTrue:[

                    Smalltalk at:nm put:newClass

                ]

            ]

        ]

    ].

!

differentInstanceVariableOffsetsIn:class1 and:class2

    "return a set of instance variable names which have different

     positions in class1 and class2.

     Also, variables which are only present in one class are returned.

     This is used to find methods which need recompilation after a

     change in the instance variable layout."

    |offsets1 offsets2 changeSet|

    changeSet := Set new.

    "

     collect the instvar-indices in the old and new class

    "

    offsets1 := class1 instanceVariableOffsets.

    offsets2 := class2 instanceVariableOffsets.

    "

     compute the changeset as a set of instance variables, 

     which have a different position

    "

    offsets1 keysAndValuesDo:[:varName :varIndex |

        (offsets2 includesKey:varName) ifFalse:[

            changeSet add:varName 

        ] ifTrue:[

            (varIndex ~~ (offsets2 at:varName)) ifTrue:[

                changeSet add:varName 

            ]

        ]

    ].

    offsets2 keysAndValuesDo:[:varName :varIndex |

        (offsets1 includesKey:varName) ifFalse:[

            changeSet add:varName

        ] ifTrue:[

            (varIndex ~~ (offsets1 at:varName)) ifTrue:[

                changeSet add:varName

            ]

        ]

    ].

    ^ changeSet

    "

     View class 

        differentInstanceVariableOffsetsIn:View

                                       and:StandardSystemView

     View class 

        differentInstanceVariableOffsetsIn:Object 

                                       and:Point 

    "

! !

!ClassBuilder class methodsFor:'recompiling'!

copyInvalidatedMethodsFrom:oldClass for:newClass

    "copy all methods from oldClass to newClass and change their code

     to a trap method reporting an error.

     This is done when a class has changed its layout or inheritance,

     before recompilation is attempted.

     This allows us to keep the source while trapping uncompilable (due to

     now undefined instvars) methods. Later compilation of these methods will show

     an error on the transcript and lead to the debugger once called."

    |trap trapCode trapByteCode oldMethod newMethod

     oldDict newDict|

    oldDict := oldClass methodDictionary.

    newDict := MethodDictionary new:oldDict size.

    oldDict keysAndValuesDo:[ :sel :mthd |

        trap := mthd trapMethodForNumArgs:(mthd numArgs).

        trapCode := trap code.

        trapByteCode := trap byteCode.

        mthd isWrapped ifTrue:[

            oldMethod := mthd originalMethod

        ] ifFalse:[

            oldMethod := mthd.

        ].

        newMethod := oldMethod copy.

        newMethod makeInvalid.

        newDict at:sel put:newMethod

    ].

    newClass methodDictionary:newDict.

    "Modified: 12.6.1996 / 10:44:27 / stefan"

    "Modified: 4.11.1996 / 22:55:57 / cg"

!

copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:setOfNames

    "copy all methods from oldClass to newClass. Those methods accessing

     a variable in setOfNames will be copied as invalid method, leading to

     a trap when its executed. This is used when a class has changed its

     layout for all methods which are affected by the change."

    self copyInvalidatedMethodsFrom:oldClass 

                                for:newClass 

                       accessingAny:setOfNames 

                            orSuper:false 

!

copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:setOfNames orSuper:superBoolean

    "copy all methods from oldClass to newClass. 

     Those methods accessing a variable in setOfNames will be copied as invalid method, 

     leading to a trap when its executed. If superBoolean is true, this is also done

     for methods accessing super.  This is used when a class has changed its

     layout for all methods which are affected by the change."

    |p source mustInvalidate

     oldMethod newMethod methodDict newMethodDict nNames|

    methodDict := oldClass methodDictionary.

    newMethodDict := methodDict copy.

    nNames := setOfNames size.

    methodDict keysAndValuesDo:[:selector :method |

        method isWrapped ifTrue:[

            oldMethod := method originalMethod

        ] ifFalse:[

            oldMethod := method

        ].

        "before parsing (which may take some time),

         do a string search if its only one variable,

         we are looking for.

         Could look for more than one variable by string compare, but then

         parsing it right away may be faster ..."

        source := oldMethod source.

        ((nNames == 1) and:[superBoolean not]) ifTrue:[

            mustInvalidate := (source findString:(setOfNames first)) ~~ 0.

        ] ifFalse:[

            ((nNames == 0) and:[superBoolean]) ifTrue:[

                mustInvalidate := (source findString:'super') ~~ 0.

            ] ifFalse:[

                mustInvalidate := true

            ].

        ].

        mustInvalidate ifTrue:[

            "we have to parse it ..."

            p := Parser parseMethod:source in:newClass.

            (p isNil 

             or:[(p usedVars includesAny:setOfNames)

             or:[superBoolean and:[p usesSuper]]]) ifFalse:[

                mustInvalidate := false

            ]

        ].

        mustInvalidate ifTrue:[

            newMethod := oldMethod copy.

"/            Smalltalk silentLoading ifFalse:[

"/                Transcript showCR:'invalidating ' , selector , '...'.

"/            ].

            newMethod makeInvalid.

        ] ifFalse:[

            newMethod := oldMethod.

            newMethod mclass:nil.

        ].

        newMethodDict at:selector put:newMethod

    ].

    newClass methodDictionary:newMethodDict.

    "Modified: 7.6.1996 / 08:33:52 / stefan"

    "Modified: 19.6.1997 / 18:27:09 / cg"

!

copyMethodsFrom:oldClass for:newClass

    "copy all methods from oldClass to newClass.

     This is used for class-methods when a class has changed, but its metaclass is 

     unaffected (i.e. classVars/inheritance have not changed) so there is no need

     to recompile the class methods."

    newClass methodDictionary:(oldClass methodDictionary copy).

    newClass methodDictionary keysAndValuesDo:[:sel :mthd | mthd mclass:nil.].

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

!

recompileGlobalAccessorsTo:aGlobalKey in:aNamespace except:someClass

    "when a new class enters a namespace, all accessors to the same-named

     class in that namespace must be recompiled"

    aNamespace allPrivateClassesDo:[:aClass |

        aClass ~~ someClass ifTrue:[

            aClass isLoaded ifTrue:[

"/                Smalltalk silentLoading ifFalse:[

"/                    Transcript showCR:'recompiling methods in ''' , aClass name , ''' accessing ''' , aGlobalKey , ''''.

"/                    Transcript endEntry.

"/                ].

                aClass recompileMethodsAccessingGlobal:aGlobalKey.

                aClass class recompileMethodsAccessingGlobal:aGlobalKey.

                "/ actually - must eventually recompile USERS of this namespace too

            ]

        ]

    ].

    aNamespace isNameSpace ifFalse:[

        aNamespace recompileMethodsAccessingGlobal:aGlobalKey.

        aNamespace class recompileMethodsAccessingGlobal:aGlobalKey.

    ].

    "Modified: 31.1.1997 / 11:22:57 / cg"

!

recompileMachineCodeMethodsIn:aClass

    "recompile all machine-code methods in aClass."

    aClass recompileMethodsWithMachineCode.

    aClass class recompileMethodsWithMachineCode.

! !

!ClassBuilder methodsFor:'accessing'!

name:newName inEnvironment:aSystemDictionaryOrClass subclassOf:aClass instanceVariableNames:stringOfInstVarNames variable:variableBoolean words:wordsBoolean pointers:pointersBoolean classVariableNames:stringOfClassVarNames poolDictionaries:stringOfPoolNames category:categoryString comment:commentString changed:changedBoolean classInstanceVariableNames:stringOfClassInstVarNamesOrNil 

    className := newName.

    environment := aSystemDictionaryOrClass.

    superClass := aClass.

    instanceVariableNames := stringOfInstVarNames.

    variable := variableBoolean.

    words := wordsBoolean.

    pointers := pointersBoolean.

    classVariableNames := stringOfClassVarNames.

    poolDictionaries := stringOfPoolNames.

    category := categoryString.

    comment := commentString.

    changed := changedBoolean.

    classInstanceVariableNames := stringOfClassInstVarNamesOrNil

!

oldMetaclass:aMetaclass instanceVariableNames:stringOfInstVarNames

    oldMetaClass := aMetaclass.

    instanceVariableNames := stringOfInstVarNames.

! !

!ClassBuilder methodsFor:'building'!

buildClass

    "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 oldPkg idx spec  

     oldCIVNames newCIVNames nsName namespace

     oldSuperClass newSuperClass oldCategory

     recompileGlobalAccessTo answer

     oldClassToBecomeNew newInstSize doCreate|

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

     ST-80 uses a ClassBuilder object to collect the work and perform all updates;

     this method may be changed to do something similar in the future ...

    "

    self checkClassName.

    self checkValidSubclassing.

    "/ owner must be loaded

    (environment notNil and:[environment isLoaded not]) ifTrue:[

        environment autoload

    ].

    (instanceVariableNames size > 0

    or:[classVariableNames size > 0]) ifTrue:[

        "

         Check for invalid variable names (duplicates)

        "

        (self 

            checkValidVarNamesFor:className

            subClassOf:superClass

            instVarNames:instanceVariableNames 

            classVarNames:classVariableNames) 

        ifFalse:[

            ^ nil

        ].

        nInstVars := instanceVariableNames countWords.

    ] ifFalse:[

        nInstVars := 0.

    ].

    nameString := className asString.

    classSymbol := className asSymbol.

    newComment := comment.

    namespace := environment.

    nameKey := classSymbol.

    (namespace notNil

    and:[namespace isNameSpace not]) ifTrue:[

        buildPrivateClass := true.

        realNewName := (namespace name , '::' , classSymbol) asSymbol.

    ] ifFalse:[

        buildPrivateClass := false.

        realNewName := classSymbol.

        "/ does the name imply a nameSpace ?

        ((idx := realNewName indexOf:$:)) ~~ 0 ifTrue:[

            "/ check for this namespace to exist

            nsName := realNewName copyTo:(idx - 1).

            nsName := nsName asSymbol.

            (realNewName indexOf:$: startingAt:(idx+2)) ~~ 0 ifTrue:[

                self warn:('nested namespaces are not (yet) implemented.') withCRs.

                ^ nil

            ].

            namespace := Smalltalk at:nsName ifAbsent:nil.

            namespace isNameSpace ifFalse:[

                namespace isNil ifTrue:[

                    doCreate := Class createNameSpaceQuerySignal query.

                    doCreate ifFalse:[

                        doCreate := Dialog

                            confirmWithCancel:('Nonexistent Namespace: `' , nsName , '''.\\Create ?') withCRs.

                        doCreate isNil ifTrue:[

                            "/ cancelled

                            AbortSignal raise.

                        ]

                    ].

                    doCreate ifFalse:[^ nil].

                    namespace := NameSpace name:nsName.

                ] ifFalse:[

                    (namespace isBehavior

                    and:[namespace isMeta not])

                    ifTrue:[

                        buildPrivateClass := true.

                        realNewName := classSymbol asSymbol.

                    ] ifFalse:[

                        self warn:('A global named ' , nsName , ' exists, but is no namespace.') withCRs.

                        ^ nil

                    ].

                ]

            ].

            namespace isNameSpace ifTrue:[

                nameKey := (classSymbol copyFrom:(nsName size + 3)) asSymbol.

            ]

        ] ifFalse:[

            (namespace notNil and:[namespace ~~ Smalltalk]) ifTrue:[

                realNewName := (namespace name , '::' , classSymbol) asSymbol.

            ]

        ]

    ].

    (superClass notNil and:[realNewName = superClass name]) ifTrue:[

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

        ^ nil

    ].

    "look, if it already exists as a class"

    namespace notNil ifTrue:[

        buildPrivateClass ifFalse:[

            oldClass := namespace at:nameKey ifAbsent:[nil].

        ] ifTrue:[

            oldClass := namespace privateClassesAt:classSymbol.

        ]

    ].

    (oldClass notNil and:[oldClass isNameSpace]) ifTrue:[

        self error:'class exists as namespace'.

        ^ nil

    ].

    (oldClass isBehavior and:[oldClass isLoaded not]) ifTrue:[

        oldClassToBecomeNew := oldClass

    ].

    (oldClass isBehavior and:[oldClass isLoaded]) ifFalse:[

        oldClass := nil.

        buildPrivateClass ifTrue:[

            Compiler warnSTXSpecials ifTrue:[

                (self confirm:('support for private classes is an ST/X extension.\\continue ?') withCRs)

                ifFalse:[^ nil].

            ]

        ].

    ] ifTrue:[

        oldClass name ~= realNewName ifTrue:[

            (self confirm:(classSymbol , ' is an alias for ' , oldClass name , '\\continue ?') withCRs)

            ifFalse:[^ nil].

            oldClass := nil

        ] ifFalse:[

            "/

            "/ some consisteny checks

            "/

            (self checkForCircularDefinitionFrom:oldClass) ifTrue:[

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

                ^ nil

            ].

            newComment isNil ifTrue:[

                newComment := oldClass comment

            ].

            "

             warn, if it exists with different category and different instvars,

             and the existing is not an autoload class.

             Usually, this indicates that someone wants to create a new class with

             a name, which already exists (it happened a few times to myself, while 

             I wanted to create a new class called ReturnNode ...).

             This will be much less of a problem, once multiple name spaces are

             implemented and classes can be put into separate packages.

            "

            oldClass isLoaded ifTrue:[

                oldClass category ~= category ifTrue:[

                    oldClass instanceVariableString asCollectionOfWords 

                    ~= instanceVariableNames asCollectionOfWords ifTrue:[

                        (self confirm:'a class named ' , oldClass name , 

                                      ' already exists -\\create (i.e. change) anyway ?' withCRs)

                        ifFalse:[

                            ^ nil

                        ]

                    ]

                ]

            ].

            "/

            "/ hints - warn, if creating a variableSubclass of a Set

            "/ (common error - containers in ST/X do not use variable-slots)

            "/

            ((variable == true) and:[pointers]) ifTrue:[

                (oldClass isKindOf:Set class) ifTrue:[

                    (self confirm:('ST/X Set & Dictionary are not variable-classes.\Create %1 anyway ?' bindWith:nameString) withCRs)

                    ifFalse:[

                        ^ nil

                    ]

                ]

            ]

        ]

    ].

    "/ Check for some 'considered bad-style' things, like lower case names.

    "/ But only do these checks for new classes - 

    "/ - thus, once confirmed, the warnings will not come again and again.

    "/ NOTICE:

    "/ I dont like the confirmers there - we need a notifying: argument, to give

    "/ the outer codeview a chance to highlight the error.

    "/ (but thats how its defined in the book - maybe I will change anyway).

    "/ - or use upQueries in future versions.

    oldClass isNil ifTrue:[

        (instanceVariableNames size > 0

        or:[classVariableNames size > 0]) ifTrue:[

            (self 

                checkConventionsFor:className

                subClassOf:superClass

                instVarNames:instanceVariableNames 

                classVarNames:classVariableNames) 

            ifFalse:[

                ^ nil

            ]

        ].

        (self

            checkInstvarRedefsWith:instanceVariableNames 

            subclassOf:superClass 

            old:oldClass 

            name:className) ifFalse:[^ nil].

    ].

    classInstanceVariableNames isNil ifTrue:[

        oldClass isNil ifTrue:[

            classInstanceVariableNames := ''

        ] ifFalse:[

            classInstanceVariableNames := oldClass class instanceVariableString

        ]

    ].

    "create the metaclass first"

    newMetaclass := self instantiateMetaclass.

    "then let the new meta create the class"