"

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

"{ NameSpace: Smalltalk }"

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

     class hanging around as obsolete classes. 

     This may also be true for all subclasses, if class instance variables are added/removed in a superclass.

     Existing instances (i.e. insts of the class) are migrated to become instances of the new class(es).

     However, if the old class is referenced somewhere (in a collection),

     that reference will still point to the old, now obsolete class.

     Time will show, if that is a problem and will be fixed."

    |builder|

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

    builder := ClassBuilder new.

    builder oldMetaclass:self instanceVariableNames:aString.

    builder rebuildForChangedClassInstanceVariables.

! !

!Metaclass methodsFor:'compiler interface'!

browserClass

    "return the browser to use for this class -

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

    ^ SystemBrowser default.

    "Created: / 03-05-1996 / 12:36:40 / cg"

    "Modified: / 01-09-2017 / 14:21:14 / cg"

!

compilerClass

    "return the compiler to use for this class -

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

     JavaScript, Ruby, 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

     JavaScript, Ruby, 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

     JavaScript, Ruby, 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

     JavaScript, Ruby, 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

    "Answer an evaluator class appropriate for evaluating definitions of new

     subclasses of this class."

    "cg: @jan - what is the difference to the subclassDefinerClass?"

    ^ 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

     JavaScript, Ruby, 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 subclass-methods have to be

     recompiled.

     Also, the old class(es) are still kept (but not accessible as a global),

     to allow existing instances some life.

     This might change in the future.

    "

    |builder newClass|

    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.

    newClass := builder buildClass.

    newClass notNil ifTrue:[

        "/ if the class was autoloaded, and it refers to any autoloaded shared pool,

        "/ reference the pool now. So it will be present, when methods are compiled

        "/ (avoids costy recompiles which may happen, if the sharedPool is loaded 

        "/  after the methods have been compiled assuming that those names are globals)

        (newClass sharedPools ? #()) do:[:each | each autoload].

    ].

    ^ newClass

    "Modified: / 28-07-2017 / 13:40:22 / cg"

    "Modified (comment): / 21-11-2017 / 13:03:39 / cg"

!

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

    namespace := 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.

        ]

    ].

"/  No, always use namespace pragma, otherwise when reading back

"/  from stream, we need somehow to tell what's namespace and what's

"/  a private class in another class. So namespaces are **aleays** denoted by

"/  namespace pragma.

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

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

                nsName := namespace name.

                (nsName includes:$:) ifTrue:[

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

                ].

                aStream nextPutAll:'"{ NameSpace: '.

                boldOn value.

                aStream nextPutAll:nsName.

                boldOff value.

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

            ] ifFalse:[

                "/ always write a namespace directive - even for smalltalk classes.

                "/ reason: the fileout might go into a big file containing multiple classes

                "/ in different namespaces (otherwise, the smalltalk class would later be filed into

                "/ the previous class's namespace)

                aStream nextPutAll:'"{ NameSpace: Smalltalk }"'; cr; cr.

            ].

        ].

    ].