"

 COPYRIGHT (c) 2001 by eXept Software AG

              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' }"

Object subclass:#ClassBuilder

	instanceVariableNames:'metaclass className environment superClass instanceVariableNames

		flags classVariableNames poolDictionaries category comment

		changed classInstanceVariableNames oldMetaClass oldClass

		oldPoolDictionaries oldSuperClass oldClassVars oldInstVars

		realNewName buildPrivateClass buildingPrivateClass nameKey

		newSuperClass superClassChange newClassVars newInstVars

		classVarChange instVarChange recompileGlobalAccessTo

		oldClassToBecomeNew oldClassInstVars newClassInstVars'

	classVariableNames:''

	poolDictionaries:''

	category:'Kernel-Support'

!

!ClassBuilder class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2001 by eXept Software AG

              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.

"

! !

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

!

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 do:[:mthd | mthd mclass:nil.].

    "Modified: / 05-08-2004 / 19:52:28 / 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'!

classClass

    ^ Class

!

metaclass:metaclassOrASubclassOfIt

    metaclass := metaclassOrASubclassOfIt.

!

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

    environment := aSystemDictionaryOrClass.

    superClass := aClass.

    instanceVariableNames := stringOfInstVarNames.

    "/ Allowing non-booleans as variableBoolean

    "/ is a hack for backward (ST-80) compatibility:

    "/ ST-80 code will pass true or false as variableBoolean,

    "/ while ST/X also calls it with symbols such as #float, #double etc.

    flags := self flagsForVariable:variableBoolean pointers:pointersBoolean words:wordsBoolean.

    classVariableNames := stringOfClassVarNames.

    poolDictionaries := stringOfPoolNames.

    category := categoryString.

    comment := commentString.

    changed := changedBoolean.

    classInstanceVariableNames := stringOfClassInstVarNamesOrNil

    "Modified: / 07-06-2007 / 12:16:57 / cg"

!

oldMetaclass:aMetaclass instanceVariableNames:stringOfInstVarNames

    |instrVarNames|

    oldMetaClass := aMetaclass.

    instrVarNames := oldMetaClass superclass allInstanceVariableNames asBag.

    instrVarNames addAll:(stringOfInstVarNames asStringCollection).

    (instrVarNames contents includesValue:2) ifTrue:[

        self error:'duplicate variable name'.

    ].

    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 newComment sourceContainer|

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

    "

    environment notNil ifTrue:[ self checkClassName ].

    self checkValidSubclassing.

    environment notNil ifTrue:[

        environment autoload   "/ owner must be loaded

    ].

    instanceVariableNames notNil ifTrue:[

        instanceVariableNames isString ifFalse:[

            instanceVariableNames := instanceVariableNames asStringWith:Character space

        ].

    ] ifFalse:[

        instanceVariableNames := ''

    ].

    classVariableNames notNil ifTrue:[

        classVariableNames isString ifFalse:[

            classVariableNames := classVariableNames asStringWith:Character space

        ].

    ] ifFalse:[

        classVariableNames := ''

    ].

    (instanceVariableNames size > 0

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

        (self 

            checkValidVarNamesFor:className

            subClassOf:superClass

            instVarNames:instanceVariableNames 

            classVarNames:classVariableNames) 

        ifFalse:[

            ^ nil

        ].

    ].

    buildingPrivateClass := false.

    environment notNil ifTrue:[

        self determineNewName ifFalse:[

            ^ nil.

        ].

    ].

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

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

        ^ nil

    ].

    "look, if it already exists as a class"

    environment notNil ifTrue:[

        environment isLoaded ifFalse:[ environment autoload ].

        buildingPrivateClass ifFalse:[

            oldClass := environment at:className ifAbsent:[nil].

        ] ifTrue:[

            oldClass := environment privateClassesAt:className.

        ]

    ].

    oldClass notNil ifTrue:[

        (oldClass isRealNameSpace) ifTrue:[

            (superClass == NameSpace or:[superClass isNamespace]) ifFalse:[

                self error:'class exists as namespace'.

                ^ nil.

            ].

            ^ oldClass

        ].

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

            oldClassToBecomeNew := oldClass

        ].

    ].

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

        oldClass := nil.

        (buildingPrivateClass and:[ParserFlags warnings and:[ParserFlags warnSTXSpecials]]) ifTrue:[

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

            ifFalse:[^ nil].

        ].

    ] ifTrue:[

        oldClass name ~= realNewName ifTrue:[

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

            ifFalse:[^ nil].

            oldClass := nil

        ] ifFalse:[

            (self checkForCircularDefinitionFrom:oldClass) ifTrue:[

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

                ^ nil

            ].

            "

             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)

            "/

            (flags bitAnd:Behavior maskIndexType) == (Behavior flagForSymbolic:#objects)

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

                (oldClass isKindOf:Set class) ifTrue:[

                    (self confirm:('ST/X Set & Dictionary are not variable-classes.\Create %1 anyway ?' bindWith:className) 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].

    self checkValidPools.

    newMetaclass := self instantiateMetaclass.

    newClass := self instantiateNewClassFrom:newMetaclass.

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

        newClass setName:realNewName.

        "/