"
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:aSystemDictionary
subclassOf:aClass
instanceVariableNames:stringOfInstVarNames
variable:variableBoolean
words:wordsBoolean
pointers:pointersBoolean
classVariableNames:stringOfClassVarNames
poolDictionaries:stringOfPoolNames
category:categoryString
comment:commentString
changed:changed
^ self
name:newName
inEnvironment:aSystemDictionary
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:aSystemDictionaryOrClass
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:aSystemDictionaryOrClass
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."
|s owner ns nsName fullName forceNoNameSpace superNameWithoutNameSpacePrefix cls topOwner
syntaxHilighting superclass superclassNamespace|
UserPreferences isNil ifTrue:[
syntaxHilighting := false
] ifFalse:[
syntaxHilighting := UserPreferences current syntaxColoring.
].
fullName := FileOutNameSpaceQuerySignal query == true.
owner := aClass owningClass.
ns := aClass topNameSpace.
(showPackage and:[owner isNil]) 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: '.
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:nsName.
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:' }"'; cr; cr.
]
].
].
"take care of nil-superclass"
superclass := aClass superclass.
superclass isNil ifTrue:[
s := 'nil'
] ifFalse:[
superclassNamespace := superclass nameSpace.
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:[
s := superclassNamespace name , '::' , superNameWithoutNameSpacePrefix
] ifFalse:[
"/ no class with that name found in my namespace ...
"/ if the superclass resides in Smalltalk,
"/ suppress prefix; otherwise, use full prefix.
(superclassNamespace notNil
and:[superclassNamespace ~~ Smalltalk]) ifTrue:[
(owner notNil
and:[(topOwner := owner topOwningClass) notNil
and:[topOwner nameSpace == superclass topOwningClass "owningClass" nameSpace
]]) ifTrue:[
s := superNameWithoutNameSpacePrefix
] ifFalse:[
ns == superclass topNameSpace ifTrue:[
s := superNameWithoutNameSpacePrefix
] ifFalse:[
s := superclass name
]
]
] ifFalse:[
s := superNameWithoutNameSpacePrefix
]
]
]
]
].
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:s. "/ superclass
syntaxHilighting ifTrue:[aStream normal].
aStream space.
aClass basicFileOutInstvarTypeKeywordOn:aStream.
(fullName and:[owner isNil]) ifTrue:[
aStream nextPutAll:'#'''.
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:(aClass name).
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:''''.
] ifFalse:[
aStream nextPut:$#.
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:(aClass nameWithoutPrefix).
syntaxHilighting ifTrue:[aStream normal].
].
aStream crtab.
aStream nextPutAll:'instanceVariableNames:'''.
syntaxHilighting ifTrue:[aStream bold].
aClass printInstVarNamesOn:aStream indent:16.
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:''''.
aStream crtab.
aStream nextPutAll:'classVariableNames:'''.
syntaxHilighting ifTrue:[aStream bold].
aClass printClassVarNamesOn:aStream indent:16.
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:''''.
aStream crtab.
aStream nextPutAll:'poolDictionaries:'''''.
aStream crtab.
owner isNil ifTrue:[
"/ a public class
aStream nextPutAll:'category:'.
aClass category isNil ifTrue:[
s := ''''''
] ifFalse:[
s := aClass category asString storeString
].
aStream nextPutAll:s.
] ifFalse:[
"/ a private class
aStream nextPutAll:'privateIn:'.
syntaxHilighting ifTrue:[aStream bold].
fullName ifTrue:[
s := owner name.
] ifFalse:[
s := owner nameWithoutNameSpacePrefix.
].
aStream nextPutAll:s.
syntaxHilighting ifTrue:[aStream normal].
].
aStream cr
"Created: / 4.1.1997 / 20:38:16 / cg"
"Modified: / 8.8.1997 / 10:59:50 / cg"
"Modified: / 18.3.1999 / 18:15:46 / stefan"
!
fileOutClassInstVarDefinitionOn:aStream withNameSpace:withNameSpace
"append an expression to define my classInstanceVariables on aStream"
|anySuperClassInstVar|
myClass isLoaded ifFalse:[
^ myClass basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
].
withNameSpace ifTrue:[
myClass name printOn:aStream.
] ifFalse:[
myClass printClassNameOn:aStream.
].
aStream nextPutAll:' class instanceVariableNames:'''.
self printInstVarNamesOn:aStream indent:8.
aStream nextPutAll:''''.
"mhmh - good idea; saw this in SmallDraw sourcecode ..."
anySuperClassInstVar := false.
myClass allSuperclassesDo:[:aSuperClass |
aSuperClass class instVarNames do:[:ignored | anySuperClassInstVar := true].
].
aStream cr; cr; nextPut:(Character doubleQuote); cr; space.
anySuperClassInstVar ifFalse:[
aStream
nextPutLine:'No other class instance variables are inherited by this class.'.
] ifTrue:[
aStream
nextPutLine:'The following class instance variables are inherited by this class:'.
aStream cr.
myClass allSuperclassesDo:[:aSuperClass |
aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
aStream nextPutLine:(aSuperClass class instanceVariableString).
].
].
aStream nextPut:(Character doubleQuote); cr.
"Created: / 10.12.1995 / 16:31:25 / cg"
"Modified: / 1.4.1997 / 16:00:33 / stefan"
"Modified: / 3.2.2000 / 23:05:28 / cg"
!
fileOutDefinitionOn:aStream
myClass fileOutClassInstVarDefinitionOn:aStream
"Modified: / 21.6.1998 / 04:10:02 / cg"
!
fileOutOn:outStreamArg withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter encoder:encoderOrNil
"file out my definition and all methods onto aStream.
If stampIt is true, a timeStamp comment is prepended.
If initIt is true, and the class implements a class-initialize method,
append a corresponding doIt expression for initialization.
The order by which the fileOut is done is used to put the version string at the end.
Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
SmalltalkChunkFileSourceWriter new
fileOut:myClass on:outStreamArg withTimeStamp:stampIt
withInitialize:initIt withDefinition:withDefinition
methodFilter:methodFilter encoder:encoderOrNil
! !
!Metaclass methodsFor:'private'!
setSoleInstance:aClass
myClass := aClass
"Created: 12.12.1995 / 13:46:22 / cg"
! !
!Metaclass methodsFor:'queries'!
category
"return my category"
myClass isNil ifTrue:[^ nil].
^ myClass category
"Created: 2.4.1997 / 00:46:11 / stefan"
!
comment
"return my comment"
^ myClass comment
"Created: 2.4.1997 / 00:51:35 / stefan"
!
hasExtensions
"return true if I have extensions"
^ myClass hasExtensions
!
hasExtensionsFrom:aPackageID
"return true if I have extensions from a package"
^ myClass hasExtensionsFrom:aPackageID
!
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]
"Created: 15.4.1996 / 17:17:34 / cg"
"Modified: 23.4.1996 / 15:59:37 / cg"
!
isMeta
"return true, if the receiver is some kind of metaclass;
true is returned here. Redefines isMeta in Object"
^ true
!
name
"return my name - that is the name of my sole class, with ' class'
appended."
|nm|
myClass isNil ifTrue:[
^ #someMetaclass
].
(nm := myClass name) isNil ifTrue:[
'Metaclass [warning]: no name in my class' errorPrintCR.
^ #'unnamed class'
].
^ nm , ' class'
"Modified: 10.1.1997 / 17:55:08 / cg"
"Modified: 1.4.1997 / 15:53:11 / stefan"
!
nameSpace
"return the nameSpace I am contained in.
Due to the implementation of nameSpaces (as classVariables),
a class can only be contained in one nameSpace (which is the desired)"
"/ this information is in the class
^ myClass nameSpace
"Created: 7.11.1996 / 13:18:52 / cg"
!
owningClass
"return nil here - regular metaclasses are never private"
^ nil
"Created: 12.10.1996 / 20:12:16 / cg"
!
package
"return my package-id"
^ myClass package
"Created: 15.10.1996 / 19:44:51 / cg"
!
soleInstance
"return my sole class."
^ myClass
!
subclasses
^ myClass subclasses collect:[:theNonMetaClass| theNonMetaClass class].
"
Integer class subclasses
"
!
theMetaclass
"return myself; also implemented in my class object, which also returns me."
^ self
"Created: / 30.1.2000 / 23:08:15 / cg"
"Modified: / 31.1.2000 / 16:15:00 / cg"
!
theNonMetaclass
"return my class object, also implemented in my class object, which also returns iteself."
^ self soleInstance
"Created: / 30.1.2000 / 23:08:11 / cg"
"Modified: / 31.1.2000 / 16:17:02 / cg"
!
topOwningClass
"return nil here - regular metaclasses are never private"
^ nil
"Created: 3.1.1997 / 19:18:06 / cg"
! !
!Metaclass methodsFor:'source management'!
binaryRevision
^ myClass binaryRevision
"
Object binaryRevision
Object class binaryRevision
"
"Modified: 2.4.1997 / 01:17:04 / stefan"
!
sourceFileSuffix
^ 'st'
!
sourceStream
"return the classes source stream"
^ myClass sourceStream
"Modified: 1.4.1997 / 14:36:31 / stefan"
!
sourceStreamFor:sourceFileName
"return the sourceStream for a sourceFileName"
^ myClass sourceStreamFor:sourceFileName
"Modified: 1.4.1997 / 14:36:38 / stefan"
! !
!Metaclass class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.189 2004-03-30 18:53:26 cg Exp $'
! !
Metaclass initialize!