"

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

        ConfirmationQuerySignal := Query newSignal 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."

    ^ self programmingLanguage compilerClass.

    "

     Array compilerClass

    "

!

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

    ^ self programmingLanguage evaluatorClass.

    "

     Array evaluatorClass

    "

!

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

    ^ self programmingLanguage formatterClass.

    "

     Array formatterClass

    "

!

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

    ^ self programmingLanguage parserClass.

    "

     Array parserClass

    "

!

programmingLanguage

    "return the programming language in which this class is written"

    ^ SmalltalkLanguage instance

    "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

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

    ^ self programmingLanguage syntaxHighlighterClass.

    "

     Array syntaxHighlighterClass

    "

! !

!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 ~= PackageId 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

"/                ]