"

 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 classClass 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

		newPoolDictionaries classVarChange instVarChange poolChange

		recompileGlobalAccessTo oldClassToBecomeNew oldClassInstVars

		newClassInstVars'

	classVariableNames:'LastNamespace LastNamespaceName LastClassesInNameSpace

		LastClassNamesInNameSpace'

	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:'change & update'!

initialize

    Smalltalk addDependent:self.

    "Created: / 18-08-2011 / 14:32:27 / cg"

!

update:something with:aParameter from:changedObject

    "keep track of the namespace->classnames cache"

    something == #projectOrganization ifTrue:[^ self].

    something == #classVariables ifTrue:[^ self].

    something == #methodInClass ifTrue:[^ self].

    something == #newClass ifTrue:[

        aParameter nameSpace name = LastNamespaceName ifTrue:[

            LastClassNamesInNameSpace add:aParameter name

        ].

        ^ self.

    ].

    something == #classRemove ifTrue:[

        aParameter nameSpace name = LastNamespaceName ifTrue:[

            LastClassNamesInNameSpace remove:aParameter name ifAbsent:[]

        ].

        ^ self.

    ].

    "/ Transcript show:something.

    "/ Transcript show:' -> '.

    "/ Transcript showCR:aParameter.

    "Created: / 18-08-2011 / 14:32:16 / cg"

! !

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

                true "/ (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

                ]

            ]

        ]

    ].

    "Modified: / 20-12-2011 / 12:22:42 / cg"

!

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.

        oldMethod := mthd originalMethodIfWrapped.

        newMethod := oldMethod copy.

        newMethod makeInvalid.

        newDict at:sel put:newMethod

    ].

    newClass methodDictionary:newDict.

    "Modified: / 12-06-1996 / 10:44:27 / stefan"

    "Modified: / 22-10-2010 / 11:47:27 / 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

    "Modified: / 02-08-2010 / 16:40:30 / cg"

!

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 |

        oldMethod := method originalMethodIfWrapped.

        "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 := newClass parserClass 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: / 07-06-1996 / 08:33:52 / stefan"

    "Modified: / 21-08-2009 / 10:14:49 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 22-10-2010 / 11:47:39 / 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 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.

     Because that is used heavily during package loading (for the same namespace), cache it."

    |privateClassNames|

    aNamespace name = LastNamespaceName ifTrue:[

        privateClassNames := LastClassNamesInNameSpace

    ] ifFalse:[

        privateClassNames := aNamespace allPrivateClasses 

                                reject:[:cls | cls isJavaClass or:[cls isNameSpace] ]

                                thenCollect:[:each | each name].   

        LastNamespaceName := aNamespace name.

        LastClassNamesInNameSpace := privateClassNames asOrderedCollection.

    ].

    privateClassNames do:[:eachClassName |

        |cls|

        cls := Smalltalk classNamed:eachClassName.

        (cls notNil and:[cls ~~ someClass]) ifTrue:[

            cls isLoaded ifTrue:[

"/                Smalltalk silentLoading ifFalse:[

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

"/                    Transcript endEntry.

"/                ].

                cls recompileMethodsAccessingGlobal:aGlobalKey.

                cls class recompileMethodsAccessingGlobal:aGlobalKey.

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

            ]

        ]

    ].

    aNamespace isNameSpace ifFalse:[

        aNamespace recompileMethodsAccessingGlobal:aGlobalKey.

        aNamespace class recompileMethodsAccessingGlobal:aGlobalKey.

    ].

    "Modified: / 24-08-2011 / 13:32:22 / cg"

    "Modified: / 01-09-2011 / 11:58:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

recompileMachineCodeMethodsIn:aClass

    "recompile all machine-code methods in aClass."

    aClass recompileMethodsWithMachineCode.

    aClass class recompileMethodsWithMachineCode.

! !

!ClassBuilder methodsFor:'Compatibility-Squeak'!

name:newName 

    inEnvironment:aSystemDictionaryOrClass 

    subclassOf:aClass

    type: type 

    instanceVariableNames: stringOfInstVarNames 

    classVariableNames: stringOfClassVarNames 

    poolDictionaries: stringOfPoolNames

    category: categoryString

    "this returns the created class; it is not a simple accessor"

    |variableBoolean wordsBoolean pointersBoolean|

    variableBoolean := wordsBoolean := pointersBoolean := false.

    type ~~ #normal ifTrue:[

        type == #words ifTrue:[

            wordsBoolean := true

        ] ifFalse:[

self halt:'todo'.

        ]

    ].

    self 

        name:newName 

        inEnvironment:aSystemDictionaryOrClass 

        subclassOf:aClass 

        instanceVariableNames:stringOfInstVarNames 

        variable:variableBoolean 

        words:wordsBoolean 

        pointers:pointersBoolean 

        classVariableNames:stringOfClassVarNames 

        poolDictionaries:stringOfPoolNames 

        category:categoryString 

        comment:''

        changed:false

        classInstanceVariableNames:''.

    ^ self buildClass

    "Modified: / 07-09-2011 / 15:21:09 / cg"

! !

!ClassBuilder methodsFor:'accessing'!

classClass

    ^ classClass ? Class

!

classClass:aClass

    classClass := aClass.

!

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: / 30-01-2011 / 10:07:36 / 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 := ''

    ].

    buildingPrivateClass := false.

    environment notNil ifTrue:[

        self determineNewName ifFalse:[

            ^ nil.

        ].

    ].

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

        ClassBuildError raiseErrorString:'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.

        ]

    ].

    (instanceVariableNames size > 0

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