--- a/Metaclass.st Fri Oct 02 08:51:28 2009 +0200
+++ b/Metaclass.st Fri Oct 02 09:54:44 2009 +0200
@@ -38,7 +38,7 @@
"
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
+ Metaclass provides support for creating new (sub)classes and/or
changing the definition of an already existing class.
[author:]
@@ -95,7 +95,7 @@
!Metaclass class methodsFor:'queries'!
asPrivate
- ^ PrivateMetaclass
+ ^ PrivateMetaclass
!
isBuiltInClass
@@ -128,7 +128,7 @@
!Metaclass methodsFor:'autoload check'!
isLoaded
- "return true, if the class has been loaded;
+ "return true, if the class has been loaded;
redefined in Autoload; see comment there"
^ myClass isLoaded
@@ -160,7 +160,7 @@
!Metaclass methodsFor:'compiler interface'!
browserClass
- "return the browser to use for this class -
+ "return the browser to use for this class -
this can be redefined in special classes, to get different browsers"
^ UserPreferences systemBrowserClass.
@@ -169,7 +169,7 @@
!
compilerClass
- "return the compiler to use for this class -
+ "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."
@@ -177,7 +177,7 @@
!
evaluatorClass
- "return the compiler to use for expression evaluation for this class -
+ "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."
@@ -185,7 +185,7 @@
!
formatterClass
- "return the parser to use for formatting (prettyPrinting) this class -
+ "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."
@@ -203,7 +203,7 @@
!
parserClass
- "return the parser to use for parsing this class -
+ "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."
@@ -217,7 +217,7 @@
!
subclassDefinerClass
- "Answer an evaluator class appropriate for evaluating definitions of new
+ "Answer an evaluator class appropriate for evaluating definitions of new
subclasses of this class."
^ self evaluatorClass
@@ -226,7 +226,7 @@
!
syntaxHighlighterClass
- "return the class to use for syntaxHighlighting (prettyPrinting) this class -
+ "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."
@@ -246,72 +246,72 @@
!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
+ 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
+ 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
+ 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.
+ 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 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.
!
@@ -325,14 +325,14 @@
|newClass|
myClass notNil ifTrue:[
- self error:'Each metaclass may only have one instance'.
+ self error:'Each metaclass may only have one instance'.
].
newClass := self basicNew.
- newClass
- setSuperclass:Object
- methodDictionary:(MethodDictionary new)
- instSize:0
- flags:(Behavior flagBehavior).
+ newClass
+ setSuperclass:Object
+ methodDictionary:(MethodDictionary new)
+ instSize:0
+ flags:(Behavior flagBehavior).
myClass := newClass.
^ newClass
@@ -358,28 +358,28 @@
here, walk over classes and enumerate corresponding metas"
self soleInstance subclassesDo:[:aSubClass |
- aBlock value:aSubClass class
+ aBlock value:aSubClass class
].
! !
!Metaclass methodsFor:'fileOut'!
-basicFileOutDefinitionOf:aClass on:aStream withNameSpace:forceNameSpace withPackage:showPackage
+basicFileOutDefinitionOf:aClass on:aStream withNameSpace:forceNameSpace withPackage:showPackage
"append an expression on aStream, which defines myself."
|syntaxHilighting|
UserPreferences isNil ifTrue:[
- syntaxHilighting := false
+ syntaxHilighting := false
] ifFalse:[
- syntaxHilighting := UserPreferences current syntaxColoring.
+ 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
!
basicFileOutDefinitionOf:aClass on:aStream withNameSpace:forceNameSpace withPackage:showPackage syntaxHilighting:syntaxHilighting
@@ -389,8 +389,8 @@
superclass superclassNamespace nm useStoreString boldOn boldOff pkg|
syntaxHilighting ifTrue:[
- boldOn := [aStream bold].
- boldOff := [aStream normal].
+ boldOn := [aStream bold].
+ boldOff := [aStream normal].
].
fullName := FileOutNameSpaceQuerySignal query == true.
@@ -398,12 +398,12 @@
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.
- ]
+ 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
@@ -412,109 +412,109 @@
"/ and there is no need to complicate global lookup in stc...
owner notNil ifTrue:[
- forceNoNameSpace := ForceNoNameSpaceQuerySignal query == true.
- forceNoNameSpace ifFalse:[
- fullName := true.
- ]
+ 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.
- ]
- ].
+ (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'
+ s := 'nil'
] ifFalse:[
- superclassNamespace := superclass nameSpace.
+ 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.
+ "/ 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
+ 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)
+ ] 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:[superclass 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
- ]
- ]
- ]
- ]
- ]
+ 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:[superclass 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
+ ]
+ ]
+ ]
+ ]
+ ]
].
boldOn value.
@@ -525,26 +525,26 @@
useStoreString := false.
(fullName and:[owner isNil]) ifTrue:[
- nm := aClass name.
- useStoreString := true.
+ nm := aClass name.
+ useStoreString := true.
] ifFalse:[
- nm := aClass nameWithoutPrefix.
- nm isValidSmalltalkIdentifier ifFalse:[
- useStoreString := true.
- ].
+ nm := aClass nameWithoutPrefix.
+ nm isValidSmalltalkIdentifier ifFalse:[
+ useStoreString := true.
+ ].
].
aStream nextPut:$#.
useStoreString ifTrue:[
- aStream nextPutAll:''''.
+ aStream nextPutAll:''''.
].
boldOn value.
aStream nextPutAll:nm.
boldOff value.
useStoreString ifTrue:[
- aStream nextPutAll:''''.
+ aStream nextPutAll:''''.
].
- aStream crtab.
+ aStream crtab.
aStream nextPutAll:'instanceVariableNames:'''.
boldOn value.
aClass printInstVarNamesOn:aStream indent:16.
@@ -567,25 +567,25 @@
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.
+ "/ 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:'.
- boldOn value.
- fullName ifTrue:[
- s := owner name.
- ] ifFalse:[
- s := owner nameWithoutNameSpacePrefix.
- ].
- aStream nextPutAll:s.
- boldOff value.
+ "/ a private class
+ aStream nextPutAll:'privateIn:'.
+ boldOn value.
+ fullName ifTrue:[
+ s := owner name.
+ ] ifFalse:[
+ s := owner nameWithoutNameSpacePrefix.
+ ].
+ aStream nextPutAll:s.
+ boldOff value.
].
aStream cr
@@ -600,13 +600,13 @@
|anySuperClassInstVar|
myClass isLoaded ifFalse:[
- ^ myClass basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
+ ^ myClass basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
].
withNameSpace ifTrue:[
- myClass name printOn:aStream.
+ myClass name printOn:aStream.
] ifFalse:[
- myClass printClassNameOn:aStream.
+ myClass printClassNameOn:aStream.
].
aStream nextPutAll:' class instanceVariableNames:'''.
self printInstVarNamesOn:aStream indent:8.
@@ -616,21 +616,21 @@
anySuperClassInstVar := false.
myClass allSuperclassesDo:[:aSuperClass |
- aSuperClass class instVarNames do:[:ignored | anySuperClassInstVar := true].
+ 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.'.
+ 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
+ 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.
@@ -655,9 +655,9 @@
Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
self language sourceFileWriterClass new
- fileOut:myClass on:outStreamArg withTimeStamp:stampIt
- withInitialize:initIt withDefinition:withDefinition
- methodFilter:methodFilter encoder:encoderOrNil
+ fileOut:myClass on:outStreamArg withTimeStamp:stampIt
+ withInitialize:initIt withDefinition:withDefinition
+ methodFilter:methodFilter encoder:encoderOrNil
! !
!Metaclass methodsFor:'method templates'!
@@ -666,9 +666,18 @@
^ aSourceCodeManager versionMethodTemplateForSmalltalk
! !
+!Metaclass methodsFor:'misc ui support'!
+
+iconInBrowserSymbol
+ "can be redefined for a private icon in the browser.
+ The returned symbol must be a selector of the ToolbarIconLibrary."
+
+ ^ nil
+! !
+
!Metaclass methodsFor:'private'!
-setSoleInstance:aClass
+setSoleInstance:aClass
myClass := aClass
"Created: 12.12.1995 / 13:46:22 / cg"
@@ -679,7 +688,7 @@
category
"return my category"
- myClass isNil ifTrue:[^ nil].
+ myClass isNil ifTrue:[^ nil].
^ myClass category
"Created: 2.4.1997 / 00:46:11 / stefan"
@@ -738,12 +747,12 @@
|nm|
myClass isNil ifTrue:[
- ^ #someMetaclass
+ ^ #someMetaclass
].
(nm := myClass name) isNil ifTrue:[
- 'Metaclass [warning]: no name in my class' errorPrintCR.
- ^ #'unnamed class'
+ 'Metaclass [warning]: no name in my class' errorPrintCR.
+ ^ #'unnamed class'
].
^ nm , ' class'
@@ -779,7 +788,7 @@
"Created: 15.10.1996 / 19:44:51 / cg"
!
-soleInstance
+soleInstance
"return my sole class."
^ myClass
@@ -860,7 +869,7 @@
!Metaclass class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.202 2009-09-24 10:41:11 fm Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.203 2009-10-02 07:54:44 cg Exp $'
! !
Metaclass initialize!