hg/stx-libbasic: comparison Metaclass.st

equal deleted inserted replaced

-:295728e8f410
+:a1892eeca6c0
 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
 ! !
 !Metaclass class methodsFor:'class initialization'!
 initialize
-ConfirmationQuerySignal := QuerySignal new defaultAnswer:true
+ConfirmationQuerySignal isNil ifTrue:[
+ConfirmationQuerySignal := Query newSignal defaultAnswer:true.
+].
 "Modified: 31.7.1997 / 21:54:44 / cg"
 ! !
 !Metaclass class methodsFor:'creating metaclasses'!
 ! !
 !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."
 ! !
 !Metaclass methodsFor:'autoload check'!
 isLoaded
 "return true, if the class has been loaded;
 redefined in Autoload; see comment there"
 ^ myClass isLoaded
 ! !
 !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
+^ 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."
-^ Compiler
+^ 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."
-^ Parser
+^ self programmingLanguage formatterClass.
-"Created: / 27.4.1998 / 15:33:34 / cg"
+"
-!
+Array formatterClass
+"
-language
+!
-^SmalltalkLanguage instance
+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>"
 !
-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
+^ self programmingLanguage syntaxHighlighterClass.
-"Created: / 27.4.1998 / 15:34:08 / cg"
+"
+Array syntaxHighlighterClass
+"
 ! !
 !Metaclass methodsFor:'copying'!
 postCopy
 ! !
 !Metaclass methodsFor:'creating classes'!
 name:newName inEnvironment:aNameSpaceOrOwningClass
-subclassOf:aClass
+	     subclassOf:aClass
-instanceVariableNames:stringOfInstVarNames
+	     instanceVariableNames:stringOfInstVarNames
-variable:variableBoolean
+	     variable:variableBoolean
-words:wordsBoolean
+	     words:wordsBoolean
-pointers:pointersBoolean
+	     pointers:pointersBoolean
-classVariableNames:stringOfClassVarNames
+	     classVariableNames:stringOfClassVarNames
-poolDictionaries:stringOfPoolNames
+	     poolDictionaries:stringOfPoolNames
-category:categoryString
+	     category:categoryString
-comment:commentString
+	     comment:commentString
-changed:changed
+	     changed:changed
 ^ self
-name:newName
+	name:newName
-inEnvironment:aNameSpaceOrOwningClass
+	inEnvironment:aNameSpaceOrOwningClass
-subclassOf:aClass
+	subclassOf:aClass
-instanceVariableNames:stringOfInstVarNames
+	instanceVariableNames:stringOfInstVarNames
-variable:variableBoolean
+	variable:variableBoolean
-words:wordsBoolean
+	words:wordsBoolean
-pointers:pointersBoolean
+	pointers:pointersBoolean
-classVariableNames:stringOfClassVarNames
+	classVariableNames:stringOfClassVarNames
-poolDictionaries:stringOfPoolNames
+	poolDictionaries:stringOfPoolNames
-category:categoryString
+	category:categoryString
-comment:commentString
+	comment:commentString
-changed:changed
+	changed:changed
-classInstanceVariableNames:nil
+	classInstanceVariableNames:nil
 "Modified: 16.6.1997 / 11:53:58 / cg"
 !
 name:newName inEnvironment:aNameSpaceOrOwningClass
-subclassOf:aClass
+	     subclassOf:aClass
-instanceVariableNames:stringOfInstVarNames
+	     instanceVariableNames:stringOfInstVarNames
-variable:variableBoolean
+	     variable:variableBoolean
-words:wordsBoolean
+	     words:wordsBoolean
-pointers:pointersBoolean
+	     pointers:pointersBoolean
-classVariableNames:stringOfClassVarNames
+	     classVariableNames:stringOfClassVarNames
-poolDictionaries:stringOfPoolNames
+	     poolDictionaries:stringOfPoolNames
-category:categoryString
+	     category:categoryString
-comment:commentString
+	     comment:commentString
-changed:changed
+	     changed:changed
-classInstanceVariableNames:stringOfClassInstVarNamesOrNil
+	     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
+	inEnvironment:aNameSpaceOrOwningClass
-subclassOf:aClass
+	subclassOf:aClass
-instanceVariableNames:stringOfInstVarNames
+	instanceVariableNames:stringOfInstVarNames
-variable:variableBoolean
+	variable:variableBoolean
-words:wordsBoolean
+	words:wordsBoolean
-pointers:pointersBoolean
+	pointers:pointersBoolean
-classVariableNames:stringOfClassVarNames
+	classVariableNames:stringOfClassVarNames
-poolDictionaries:stringOfPoolNames
+	poolDictionaries:stringOfPoolNames
-category:categoryString
+	category:categoryString
-comment:commentString
+	comment:commentString
-changed:changed
+	changed:changed
-classInstanceVariableNames:stringOfClassInstVarNamesOrNil.
+	classInstanceVariableNames:stringOfClassInstVarNamesOrNil.
 ^ builder buildClass.
 !
 new
 "create & return a new metaclass (a classes class).
 (confusing - isn't it ?)"
 |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
+	setSuperclass:Object
-methodDictionary:(MethodDictionary new)
+	methodDictionary:(MethodDictionary new)
-instSize:0
+	instSize:0
-flags:(Behavior flagBehavior).
+	flags:(Behavior flagBehavior).
 myClass := newClass.
 ^ newClass
 "Modified: 1.4.1997 / 15:44:50 / stefan"
 !
 "metaclasses are not found via Smalltalk allClassesDo:
 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
 "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
+	basicFileOutDefinitionOf:aClass
-on:aStream
+	on:aStream
-withNameSpace:forceNameSpace
+	withNameSpace:forceNameSpace
-withPackage:showPackage
+	withPackage:showPackage
-syntaxHilighting:syntaxHilighting
+	syntaxHilighting:syntaxHilighting
 !
 basicFileOutDefinitionOf:aClass on:aStream withNameSpace:forceNameSpace withPackage:showPackage syntaxHilighting:syntaxHilighting
 "append an expression on aStream, which defines myself."
 owner := aClass owningClass.
 ns := aClass topNameSpace.
 (showPackage and:[owner isNil]) ifTrue:[
 pkg := aClass getPackage.
-(pkg notNil and:[pkg ~= Project noProjectID]) ifTrue:[
+(pkg notNil and:[pkg ~= PackageId noProjectID]) ifTrue:[
 aStream nextPutAll:'"{ Package: '''.
 aStream nextPutAll:aClass package asString.
 aStream nextPutAll:''' }"'; cr; cr.
 ]
 ].
 "/ 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:[
 "/ 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.
 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]
 boldOff value.
 useStoreString ifTrue:[
 aStream nextPutAll:''''.
 ].
 aStream crtab.
 aStream nextPutAll:'instanceVariableNames:'''.
 boldOn value.
 aClass printInstVarNamesOn:aStream indent:16.
 boldOff value.
 aStream nextPutAll:''''.
 "append an expression to define my classInstanceVariables on aStream"
 |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.
 aStream nextPutAll:''''.
 "mhmh - good idea; saw this in SmallDraw sourcecode ..."
 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
+	aStream
-nextPutLine:'No other class instance variables are inherited by this class.'.
+	    nextPutLine:'No other class instance variables are inherited by this class.'.
 ] ifTrue:[
-aStream
+	aStream
-nextPutLine:'The following class instance variables are inherited by this class:'.
+	    nextPutLine:'The following class instance variables are inherited by this class:'.
-aStream cr.
+	aStream cr.
-myClass allSuperclassesDo:[:aSuperClass |
+	myClass allSuperclassesDo:[:aSuperClass |
-aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
+	    aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
-aStream nextPutLine:(aSuperClass class instanceVariableString).
+	    aStream nextPutLine:(aSuperClass class instanceVariableString).
-].
+	].
 ].
 aStream nextPut:(Character doubleQuote); cr.
 "Created: / 10.12.1995 / 16:31:25 / cg"
 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"
-self language sourceFileWriterClass new
+self programmingLanguage sourceFileWriterClass new
 fileOut:myClass on:outStreamArg withTimeStamp:stampIt
 withInitialize:initIt withDefinition:withDefinition
 methodFilter:methodFilter encoder:encoderOrNil
+! !
-"Modified: / 16-08-2009 / 09:52:41 / Jan Vrany <vranyj1@fel.cvut.cz>"
-! !
+!Metaclass methodsFor:'method templates'!
+versionMethodTemplateForSourceCodeManager:aSourceCodeManager
+^ 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
 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"
 !
 appended."
 |nm|
 myClass isNil ifTrue:[
-^ #someMetaclass
+	^ #someMetaclass
 ].
 (nm := myClass name) isNil ifTrue:[
-'Metaclass [warning]: no name in my class' errorPrintCR.
+	'Metaclass [warning]: no name in my class' errorPrintCR.
-^ #'unnamed class'
+	^ #'unnamed class'
 ].
 ^ nm , ' class'
 "Modified: 10.1.1997 / 17:55:08 / cg"
 "Modified: 1.4.1997 / 15:53:11 / stefan"
 ^ myClass package
 "Created: 15.10.1996 / 19:44:51 / cg"
 !
 soleInstance
 "return my sole class."
 ^ myClass
 !
 "Modified: 2.4.1997 / 01:17:04 / stefan"
 !
 sourceFileSuffix
-^ self language sourceFileSuffix
+^ self programmingLanguage sourceFileSuffix
 "Modified: / 15-08-2009 / 22:46:44 / Jan Vrany <vranyj1@fel.cvut.cz>"
 !
 sourceStream
 ! !
 !Metaclass class methodsFor:'documentation'!
 version
-^ '$Id: Metaclass.st 10465 2009-08-16 17:14:23Z vranyj1 $'
+^ '$Id: Metaclass.st 10473 2009-10-24 15:48:19Z vranyj1 $'
+!
+version_CVS
+^ '§Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.207 2009/10/13 11:11:15 stefan Exp §'
 ! !
 Metaclass initialize!

branch	jv
changeset 17732	a1892eeca6c0
parent 17727	3945dfe4659c
child 17734	406b1590afe8