"

 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.

"

"{ Package: 'stx:libbasic' }"

ClassDescription subclass:#Metaclass

	instanceVariableNames:'myClass'

	classVariableNames:'ConfirmationQuerySignal'

	poolDictionaries:''

	category:'Kernel-Classes'

!

!Metaclass class methodsFor:'documentation'!

copyright

"

 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.

"

!

documentation

"

    every classes class is a subclass of Metaclass.

    (i.e. every class is the sole instance of its Metaclass)

    Metaclass provides support for creating new (sub)classes and/or 

    changing the definition of an already existing class.

    [author:]

	Claus Gittinger

    [see also:]

	Behavior ClassDescription Class

"

! !

!Metaclass class methodsFor:'Signal constants'!

confirmationQuerySignal

    "return the query signal which is raised to ask if user

     confirmation dialogs should be opened.

     If unhandled, they are."

    ^ ConfirmationQuerySignal

    "Created: 31.7.1997 / 21:55:39 / cg"

! !

!Metaclass class methodsFor:'class initialization'!

initialize

    ConfirmationQuerySignal := QuerySignal new defaultAnswer:true

    "Modified: 31.7.1997 / 21:54:44 / cg"

! !

!Metaclass class methodsFor:'creating metaclasses'!

new

    "creating a new metaclass - have to set the new classes

     flags correctly to have it behave like a metaclass ...

     Not for normal applications - creating new metaclasses is a very

     tricky thing; should be left to the gurus ;-)"

    |newMetaclass|

    newMetaclass := super new.

    newMetaclass instSize:(Class instSize).

    newMetaclass setSuperclass:Class.

    ^ newMetaclass

    "

     Metaclass new           <- new metaclass

     Metaclass new new       <- new class

     Metaclass new new new   <- new instance

    "

! !

!Metaclass class methodsFor:'queries'!

asPrivate

    ^ PrivateMetaclass 

!

isBuiltInClass

    "return true if this class is known by the run-time-system.

     Here, true is returned for myself, false for subclasses."

    ^ self == Metaclass class or:[self == Metaclass]

    "Modified: 23.4.1996 / 15:59:44 / cg"

! !

!Metaclass methodsFor:'Compatibility-ST80'!

comment:aString

    "ignored - sometimes found in ST-80 fileOut files.

     Comments are supposed to be defined via class messages."

    "Created: 9.10.1997 / 18:14:34 / cg"

!

sourceCodeTemplate

    "ST80 compatibility - return a definition message for myself.

     Same as #definition"

    ^ self soleInstance definition

    "Created: / 1.11.1997 / 13:16:45 / cg"

! !

!Metaclass methodsFor:'autoload check'!

isLoaded

    "return true, if the class has been loaded; 

     redefined in Autoload; see comment there"

    ^ myClass isLoaded

! !

!Metaclass methodsFor:'class instance variables'!

instanceVariableNames:aString

    "changing / adding class-inst vars -

     this actually creates a new metaclass and class, leaving the original

     classes around as obsolete classes. This may also be true for all subclasses,

     if class instance variables are added/removed.

     Existing instances continue to be defined by their original classes.

     Time will show, if this is an acceptable behavior or if we should migrate

     instances to become insts. of the new classes."

    |builder|

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

    builder := ClassBuilder new.

    builder oldMetaclass:self instanceVariableNames:aString.

    builder rebuildForChangedInstanceVariables.

! !

!Metaclass methodsFor:'compiler interface'!

browserClass

    "return the browser to use for this class - 

     this can be redefined in special classes, to get different browsers"

    ^ UserPreferences systemBrowserClass.

    "Created: 3.5.1996 / 12:36:40 / cg"

!

compilerClass

    "return the compiler to use for this class - 

     this can be redefined in special classes, to compile classes with

     Lisp, Prolog, ASN1, Basic :-) or whatever syntax."

    ^ Compiler

!

evaluatorClass

    "return the compiler to use for expression evaluation for this class - 

     this can be redefined in special classes, to evaluate expressions with

     Lisp, Prolog, ASN1, Basic :-) or whatever syntax."

    ^ Compiler

!

formatterClass

    "return the parser to use for formatting (prettyPrinting) this class - 

     this can be redefined in special classes, to format classes with

     Lisp, Prolog, ASN1, Basic :-) or whatever syntax."

    ^ Parser

    "Created: / 27.4.1998 / 15:33:34 / cg"

!

parserClass

    "return the parser to use for parsing this class - 

     this can be redefined in special classes, to parse classes with

     Lisp, Prolog, ASN1, Basic :-) or whatever syntax."

    ^ Parser

    "Created: 18.4.1997 / 21:02:41 / cg"

!

realSubclassDefinerClass

    ^ self evaluatorClass

!

subclassDefinerClass

    "Answer an evaluator class appropriate for evaluating definitions of new 

     subclasses of this class."

    ^ self evaluatorClass

!

syntaxHighlighterClass

    "return the class to use for syntaxHighlighting (prettyPrinting) this class - 

     this can be redefined in special classes, to highlight classes with

     Lisp, Prolog, ASN1, Basic :-) or whatever syntax."

    ^ SyntaxHighlighter

    "Created: / 27.4.1998 / 15:34:08 / cg"

! !

!Metaclass methodsFor:'copying'!

postCopy

    "redefined - a copy may have a new instance"

    myClass := nil

! !

!Metaclass methodsFor:'creating classes'!

name:newName inEnvironment:aNameSpaceOrOwningClass

             subclassOf:aClass

             instanceVariableNames:stringOfInstVarNames

             variable:variableBoolean

             words:wordsBoolean

             pointers:pointersBoolean

             classVariableNames:stringOfClassVarNames

             poolDictionaries:stringOfPoolNames

             category:categoryString

             comment:commentString

             changed:changed

    ^ self

        name:newName 

        inEnvironment:aNameSpaceOrOwningClass

        subclassOf:aClass

        instanceVariableNames:stringOfInstVarNames

        variable:variableBoolean

        words:wordsBoolean

        pointers:pointersBoolean

        classVariableNames:stringOfClassVarNames

        poolDictionaries:stringOfPoolNames

        category:categoryString

        comment:commentString

        changed:changed

        classInstanceVariableNames:nil

    "Modified: 16.6.1997 / 11:53:58 / cg"

!

name:newName inEnvironment:aNameSpaceOrOwningClass

             subclassOf:aClass

             instanceVariableNames:stringOfInstVarNames

             variable:variableBoolean

             words:wordsBoolean

             pointers:pointersBoolean

             classVariableNames:stringOfClassVarNames

             poolDictionaries:stringOfPoolNames

             category:categoryString

             comment:commentString

             changed:changed

             classInstanceVariableNames:stringOfClassInstVarNamesOrNil

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

    "

    |builder|

    builder := self newClassBuilder.

    builder name:newName 

        inEnvironment:aNameSpaceOrOwningClass

        subclassOf:aClass

        instanceVariableNames:stringOfInstVarNames

        variable:variableBoolean

        words:wordsBoolean

        pointers:pointersBoolean

        classVariableNames:stringOfClassVarNames

        poolDictionaries:stringOfPoolNames

        category:categoryString

        comment:commentString

        changed:changed

        classInstanceVariableNames:stringOfClassInstVarNamesOrNil.

    ^ builder buildClass.

!

new

    "create & return a new metaclass (a classes class).

     Since metaclasses only have one instance (the class),

     complain if there is already one.

     You get a new class by sending #new to the returned metaclass

     (confusing - isn't it ?)"

    |newClass|

    myClass notNil ifTrue:[

        self error:'Each metaclass may only have one instance'.

    ].

    newClass := self basicNew.

    newClass 

        setSuperclass:Object

        methodDictionary:(MethodDictionary new)

        instSize:0 

        flags:(Behavior flagBehavior).

    myClass := newClass.

    ^ newClass

    "Modified: 1.4.1997 / 15:44:50 / stefan"

!

newClassBuilder

    ^ ClassBuilder new metaclass:self class.

! !

!Metaclass methodsFor:'enumerating'!

instAndClassSelectorsAndMethodsDo:aTwoArgBlock

    myClass instAndClassSelectorsAndMethodsDo:aTwoArgBlock

!

subclassesDo:aBlock

    "evaluate the argument, aBlock for all immediate subclasses.

     This will only enumerate globally known classes - for anonymous

     behaviors, you have to walk over all instances of Behavior."

    "metaclasses are not found via Smalltalk allClassesDo:

     here, walk over classes and enumerate corresponding metas"

    self soleInstance subclassesDo:[:aSubClass |

        aBlock value:aSubClass class

    ].

! !

!Metaclass methodsFor:'fileOut'!

basicFileOutDefinitionOf:aClass on:aStream withNameSpace:forceNameSpace withPackage:showPackage 

    "append an expression on aStream, which defines myself."

    |syntaxHilighting|

    UserPreferences isNil ifTrue:[

        syntaxHilighting := false

    ] ifFalse:[

        syntaxHilighting := UserPreferences current syntaxColoring.

    ].

    self

        basicFileOutDefinitionOf:aClass 

        on:aStream 

        withNameSpace:forceNameSpace 

        withPackage:showPackage 

        syntaxHilighting:syntaxHilighting

!

basicFileOutDefinitionOf:aClass on:aStream withNameSpace:forceNameSpace withPackage:showPackage syntaxHilighting:syntaxHilighting

    "append an expression on aStream, which defines myself."

    |s owner ns nsName fullName forceNoNameSpace superNameWithoutNameSpacePrefix cls topOwner

     superclass superclassNamespace nm useStoreString boldOn boldOff pkg|

    syntaxHilighting ifTrue:[

        boldOn := [aStream bold].

        boldOff := [aStream normal].

    ].

    fullName := FileOutNameSpaceQuerySignal query == true.

    owner := aClass owningClass.

    ns := aClass topNameSpace.

    (showPackage and:[owner isNil]) ifTrue:[

        pkg := aClass getPackage.

        (pkg notNil and:[pkg ~= Project noProjectID]) ifTrue:[

            aStream nextPutAll:'"{ Package: '''.

            aStream nextPutAll:aClass package asString.

            aStream nextPutAll:''' }"'; cr; cr.

        ]

    ].

    "/ the backward compatible namespace directive is only used

    "/ for non-private classes.

    "/ Private classes cannot be filed into another smalltalk anyway,

    "/ and there is no need to complicate global lookup in stc...

    owner notNil ifTrue:[

        forceNoNameSpace := ForceNoNameSpaceQuerySignal query == true.

        forceNoNameSpace ifFalse:[

            fullName := true.    

        ]

    ].

    fullName ifFalse:[

        (owner isNil or:[forceNameSpace]) ifTrue:[

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

                nsName := ns name.

                (nsName includes:$:) ifTrue:[

                    nsName := '''' , nsName , ''''

                ].

                aStream nextPutAll:'"{ NameSpace: '.

                boldOn value.

                aStream nextPutAll:nsName.

                boldOff value.

                aStream nextPutAll:' }"'; cr; cr.

            ]

        ].

    ].

    "take care of nil-superclass"

    superclass := aClass superclass.

    superclass isNil ifTrue:[

        s := 'nil'

    ] ifFalse:[

        superclassNamespace := superclass nameSpace.

        "/ be careful: if the superclasses ns is Smalltalk,

        "/ AND this is the definition of a private class,

        "/ AND a private class with the same name as my superclas

        "/ exists in my owning class,

        "/ THEN we MUST add the smalltalk-prefix.

        "/ (otherwise, we get the private class as superclass when accepting the

        "/  next time)

        (owner notNil

        and:[ superclassNamespace == Smalltalk 

        and:[ (owner privateClassesAt:superclass name) notNil ]]) ifTrue:[

            s := superclass nameWithNameSpacePrefix.

        ] ifFalse:[

            fullName ifTrue:[

                s := superclass name.

            ] ifFalse:[

                (ns == superclassNamespace 

                and:[superclass owningClass isNil]) ifTrue:[

                    "/ superclass is in the same namespace and not private;

                    "/ still prepend namespace prefix for private classes,

                    "/  to avoid confusing stc, which needs that information.

                    "/ LATE note (AUG2002) - no longer; stc was fixed.

"/                owner notNil ifTrue:[

"/                    s := superclass name

"/                ] ifFalse:[

                        s := superclass nameWithoutPrefix

"/                ]

                ] ifFalse:[

                    "/ a very special (rare) situation:

                    "/ my superclass resides in another nameSpace,

                    "/ but there is something else named like this

                    "/ to be found in my nameSpace (or a private class)

                    superNameWithoutNameSpacePrefix := superclass nameWithoutNameSpacePrefix asSymbol.

                    cls := aClass privateClassesAt:superNameWithoutNameSpacePrefix.

                    cls isNil ifTrue:[

                        (topOwner := aClass topOwningClass) isNil ifTrue:[

                            ns := aClass nameSpace.

                            ns notNil ifTrue:[

                                cls := ns privateClassesAt:superNameWithoutNameSpacePrefix

                            ] ifFalse:[

                                "/ aClass error:'unexpected nil namespace'

                            ]

                        ] ifFalse:[

                            cls := topOwner nameSpace at:superNameWithoutNameSpacePrefix.

                        ]

                    ].

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