"

 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)

    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

    "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

!

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

     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

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

    ^ UserPreferences systemBrowserClass.

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

!

compilerClass

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

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

!

evaluatorClass

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

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

!

formatterClass

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

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

!

    "Created: / 15-08-2009 / 09:06:25 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 16-08-2009 / 10:37:08 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

realSubclassDefinerClass

    ^ self evaluatorClass

!

subclassDefinerClass

     subclasses of this class."

    ^ self evaluatorClass

!

syntaxHighlighterClass

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

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

! !

!Metaclass methodsFor:'copying'!

postCopy

    "redefined - a copy may have a new instance"

    myClass := nil

! !

!Metaclass methodsFor:'creating classes'!

name:newName inEnvironment:aNameSpaceOrOwningClass

    ^ self

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

!

name:newName inEnvironment:aNameSpaceOrOwningClass

    "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),

     This might change in the future.

    "

    |builder|

    builder := self newClassBuilder.

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

    ].

    newClass := self basicNew.

    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 |

    ].

! !

!Metaclass methodsFor:'fileOut'!

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

    |syntaxHilighting|

    UserPreferences isNil ifTrue:[

    ] ifFalse:[

    ].

    self

!

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.

            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 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:[ (owner privateClassesAt:superclass name) notNil ]]) ifTrue:[

            s := superclass nameWithNameSpacePrefix.

        ] ifFalse:[

            fullName ifTrue:[

                s := superclass name.

            ] ifFalse:[

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