"
COPYRIGHT (c) 1993 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.
"
Behavior subclass:#ClassDescription
instanceVariableNames:'instvars'
classVariableNames:'UpdatingChanges LockChangesFile FileOutErrorSignal
CatchMethodRedefinitions MethodRedefinitionSignal
UpdateChangeFileQuerySignal TryLocalSourceFirst
ChangeFileAccessLock NameSpaceQuerySignal PackageQuerySignal
UsedNameSpaceQuerySignal CreateNameSpaceQuerySignal
FileOutNameSpaceQuerySignal'
poolDictionaries:''
category:'Kernel-Classes'
!
!ClassDescription class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1993 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
"
ClassDescription conceptually adds some descriptive information to the basic
Behavior class. It is an abstract class used as a common superclass
for Metaclass and Class.
Subclasses must define the #name, #category and #comment methods.
[Instance variables:]
instvars <String> the names of the instance variables
[Class variables:]
UpdatingChanges <Boolean> true if the changes-file shall be updated
(except during startup and when filing in, this flag
is usually true)
UpdateChangeFileQuerySignal used as an upQuery from the change management.
Whenever a changeRecord is to be written,
this signal is raised and a handler (if present)
is supposed to return true or false.
If unhandled, the value of the global
UpdatingChanges is returned for backward
compatibility (which means that the old
mechanism is used if no query-handler
is present).
LockChangesFile <Boolean> if true, the change file is locked for updates.
Required when multiple users operate on a common
change file.
This is an experimental new feature, being evaluated.
FileOutErrorSignal raised when an error occurs during fileOut
CatchMethodRedefinitions if true, classes protect themself
MethodRedefinitionSignal (by raising MethodRedefinitionSignal)
from redefining any existing methods,
which are defined in another package.
(i.e. a signal will be raised, if you
fileIn something which redefines an
existing method and the packages do not
match).
The default is (currently) true.
TryLocalSourceFirst If true, local source files are tried
first BEFORE the sourceCodeManager is
consulted. If false, the sourceCodeManager
is asked first.
Should be turned on, if you run an image from
local sources which have not yet been checked in.
NameSpaceQuerySignal used as an upQuery to ask for a namespace into
which new classes are to be installed.
PackageQuerySignal used as an upQuery to ask for a packageSymbol with
which new classes/methods are to be marked.
CreateNameSpaceQuerySignal used as an upQuery to ask if unknown namespaces
should be silently created (without asking the user)
[author:]
Claus Gittinger
[see also:]
Behavior Class Metaclass
"
! !
!ClassDescription class methodsFor:'initialization'!
initialize
"the classvariable 'UpdatingChanges' controls if changes are put
into the changes-file; normally this variable is set to true, but
(for example) during fileIn or when changes are applied, it is set to false
to avoid putting too much junk into the changes-file."
UpdatingChanges := true.
LockChangesFile := false.
CatchMethodRedefinitions := true.
TryLocalSourceFirst := false.
FileOutErrorSignal isNil ifTrue:[
FileOutErrorSignal := ErrorSignal newSignalMayProceed:false.
FileOutErrorSignal nameClass:self message:#fileOutErrorSignal.
FileOutErrorSignal notifierString:'error during fileOut'.
MethodRedefinitionSignal := ErrorSignal newSignalMayProceed:true.
MethodRedefinitionSignal nameClass:self message:#methodRedefinitionSignal.
MethodRedefinitionSignal notifierString:'attempt to redefine method from different package'.
UpdateChangeFileQuerySignal := QuerySignal new.
UpdateChangeFileQuerySignal nameClass:self message:#updateChangeFileQuerySignal.
UpdateChangeFileQuerySignal notifierString:'asking if changeFile update is wanted'.
UpdateChangeFileQuerySignal handlerBlock:[:ex | ex proceedWith:UpdatingChanges].
NameSpaceQuerySignal := QuerySignal new.
NameSpaceQuerySignal nameClass:self message:#nameSpaceQuerySignal.
NameSpaceQuerySignal notifierString:'asking for nameSpace'.
NameSpaceQuerySignal handlerBlock:[:ex | ex proceedWith:Smalltalk defaultNameSpace].
UsedNameSpaceQuerySignal := QuerySignal new.
UsedNameSpaceQuerySignal nameClass:self message:#usedNameSpaceQuerySignal.
UsedNameSpaceQuerySignal notifierString:'asking for used nameSpaced'.
CreateNameSpaceQuerySignal := QuerySignal new.
CreateNameSpaceQuerySignal nameClass:self message:#createNameSpaceQuerySignal.
CreateNameSpaceQuerySignal notifierString:'asking for nameSpace creation'.
CreateNameSpaceQuerySignal defaultAnswer:false.
PackageQuerySignal := QuerySignal new.
PackageQuerySignal nameClass:self message:#packageQuerySignal.
PackageQuerySignal notifierString:'asking for package'.
PackageQuerySignal handlerBlock:[:ex | ex proceedWith:(Project isNil
ifTrue:[
'no package'
] ifFalse:[
Project currentPackageName
])].
FileOutNameSpaceQuerySignal := QuerySignal new.
FileOutNameSpaceQuerySignal defaultAnswer:false.
ChangeFileAccessLock := Semaphore forMutualExclusion name:'ChangeFileAccessLock'.
]
"Modified: 3.1.1997 / 15:16:05 / cg"
"Created: 2.4.1997 / 17:27:40 / stefan"
! !
!ClassDescription class methodsFor:'Signal constants'!
createNameSpaceQuerySignal
"return the signal used as an upQuery if a new nameSpace should be
silently created without user confirmation.
Only used when installing autoloaded classes"
^ CreateNameSpaceQuerySignal
"Created: 2.4.1997 / 17:27:54 / stefan"
!
fileOutErrorSignal
"return the signal raised when an error occurs while fileing out.
This is signalled to allow browsers some user feed back in case
a fileout fails (for example due to disk-full errors)"
^ FileOutErrorSignal
"Created: 2.4.1997 / 17:28:03 / stefan"
!
fileOutNameSpaceQuerySignal
"return the signal used as an upQuery wether the current
namespace should be prepended on fileOut."
^ FileOutNameSpaceQuerySignal
"
Transcript showCR:Class fileOutNameSpaceQuerySignal raise
"
"Modified: 5.11.1996 / 20:08:38 / cg"
"Created: 2.4.1997 / 17:28:41 / stefan"
! !
!ClassDescription class methodsFor:'enumeration '!
allClassesInCategory:aCategory do:aBlock
"evaluate aBlock for all classes in aCategory;
no specific order is defined."
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = aCategory) ifTrue:[
aBlock value:aClass
]
].
]
"
Class allClassesInCategory:'Kernel-Classes'
do:[:class |Transcript showCR:class name]
"
"Created: 1.4.1997 / 23:45:09 / stefan"
!
allClassesInCategory:aCategory inOrderDo:aBlock
"evaluate aBlock for all classes in aCategory;
superclasses come first - then subclasses."
|classes|
classes := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = aCategory) ifTrue:[
classes add:aClass
]
]
].
classes topologicalSort:[:a :b | b isSubclassOf:a].
classes do:aBlock
"Created: 1.4.1997 / 23:45:15 / stefan"
! !
!ClassDescription class methodsFor:'queries'!
isBuiltInClass
"return true if this class is known by the run-time-system.
Here, true is returned for myself, false for subclasses."
^ self == ClassDescription class or:[self == ClassDescription]
"Created: 15.4.1996 / 17:16:59 / cg"
"Modified: 23.4.1996 / 15:56:54 / cg"
! !
!ClassDescription methodsFor:'accessing'!
category
^ self subclassResponsibility
"Created: 2.4.1997 / 00:51:04 / stefan"
!
comment
^ self subclassResponsibility
"Created: 2.4.1997 / 00:51:11 / stefan"
!
instVarAtOffset:index
"return the name of the instance variable at index"
^ self allInstanceVariableNames at:index
!
instVarNames
"return a collection of the instance variable name-strings"
instvars isNil ifTrue:[
^ OrderedCollection new
].
^ instvars asCollectionOfWords
"
Point instVarNames
"
!
instVarOffsetOf:aVariableName
"return the index (as used in instVarAt:/instVarAt:put:) of a named instance
variable. The returned number is 1..instSize for valid variable names, nil for
illegal names."
^ self allInstVarNames lastIndexOf:aVariableName ifAbsent:nil
"Modified: 7.4.1997 / 16:59:39 / cg"
!
instanceVariableOffsets
"returns a dictionary containing the instance variable index
for each instVar name"
|dict index|
index := 0. dict := Dictionary new.
self allInstVarNames do:[:nm | index := index + 1. dict at:nm put:index].
^ dict
"
Point instanceVariableOffsets
GraphicsContext instanceVariableOffsets
"
!
instanceVariableString
"return a string of the instance variable names"
instvars isNil ifTrue:[^ ''].
^ instvars
"
Point instanceVariableString
"
!
name
^ self subclassResponsibility
"Created: 2.4.1997 / 00:50:56 / stefan"
!
organization
"for ST80 compatibility;
read the documentation in ClassOrganizer for more info."
^ ClassOrganizer for:self
!
renameCategory:oldCategory to:newCategory
"{ Pragma: +optSpace }"
"rename a category (changes category of those methods).
Appends a change record and notifies dependents."
|any|
any := false.
self methodDictionary do:[:aMethod |
aMethod category = oldCategory ifTrue:[
aMethod category:newCategory.
any := true.
]
].
any ifTrue:[
self addChangeRecordForRenameCategory:oldCategory to:newCategory.
self changed:#methodCategory.
]
"Modified: 12.6.1996 / 11:49:08 / stefan"
"Created: 3.6.1997 / 11:55:05 / cg"
! !
!ClassDescription methodsFor:'adding/removing'!
addSelector:newSelector withMethod:newMethod
"add the method given by 2nd argument under the selector given by
1st argument to the methodDictionary.
Append a change record to the changes file and tell dependents."
|oldMethod|
oldMethod := self compiledMethodAt:newSelector.
CatchMethodRedefinitions ifTrue:[
"check for attempts to redefine a method
in a different package. Signal a resumable error if so.
This allows tracing redefinitions of existing system methods
when filing in alien code ....
(which we may want to forbit sometimes)
"
oldMethod notNil ifTrue:[
oldMethod package ~= newMethod package ifTrue:[
"
attempt to redefine an existing method, which was
defined in another package.
If you continue in the debugger, the new method gets installed.
Otherwise, the existing (old) method remains valid.
You can turn of the catching of redefinitions by setting
CatchMethodRedefinitions to false
(also found in the Launchers 'settings-misc' menu)
"
(MethodRedefinitionSignal
raiseRequestWith:(oldMethod -> newMethod)
errorString:('redefinition of ' , self name , '>>' , newSelector)
) == #keep ifTrue:[
newMethod package:oldMethod package
].
"/ if proceeded, install as usual.
]
]
].
"/ remember new->old association in the OldMethods dictionary (if non-nil)
OldMethods notNil ifTrue:[
oldMethod notNil ifTrue:[
"/ oldMethod source:(oldMethod source).
OldMethods at:newMethod put:oldMethod
]
].
"/ remember in the projects overwritten dictionary
oldMethod notNil ifTrue:[
oldMethod package ~= newMethod package ifTrue:[
Project notNil ifTrue:[
"/ allow configurations without Project
Project rememberOverwrittenMethod:newMethod from:oldMethod
]
]
].
(super addSelector:newSelector withMethod:newMethod) ifTrue:[
self addChangeRecordForMethod:newMethod.
]
"Modified: 9.9.1996 / 22:39:32 / stefan"
"Modified: 4.6.1997 / 14:47:06 / cg"
"Created: 4.6.1997 / 14:47:10 / cg"
!
basicAddSelector:newSelector withMethod:newMethod
"add the method given by 2nd argument under the selector given by
1st argument to the methodDictionary.
This does NOT append a change record to the changes file and tell
dependents. Also, no methodHistory is kept or redefinition is checked."
super addSelector:newSelector withMethod:newMethod
"Created: 2.4.1997 / 01:01:08 / stefan"
!
removeSelector:aSelector
"remove the selector, aSelector and its associated method
from the methodDictionary.
Append a change record to the changes file and tell dependents."
(super removeSelector:aSelector) ifTrue:[
self addChangeRecordForRemoveSelector:aSelector.
"/
"/ also notify a change of mySelf;
"/
self changed:#methodDictionary with:aSelector.
"/
"/ also notify a change of Smalltalk;
"/ this allows a dependent of Smalltalk to watch all class
"/ changes (no need for observing all classes)
"/ - this allows for watchers to find out if its a new method or a method-change
"/
Smalltalk changed:#methodInClassRemoved with:(Array with:self with:aSelector).
]
"Modified: 8.1.1997 / 23:03:49 / cg"
"Created: 2.4.1997 / 00:59:29 / stefan"
! !
!ClassDescription methodsFor:'c function interfacing'!
cInterfaceFunction:selector calling:cFunctionNameString args:argTypeArray returning:returnType
"{ Pragma: +optSpace }"
"create an interface to an existing (i.e. already linked in) c function.
The function can be called by sending selector to the receiver class.
The c-function has the name cFunctionNameString, and expects parameters as specified in
argTypeArray. The functions return value has a type as specified by returnType.
WARNING:
this interface is EXPERIMENTAL - it may change or even be removed."
StubGenerator isNil ifTrue:[
^ self error:'this system does not support dynamic C Interface functions'.
].
StubGenerator
createStubFor:selector
calling:cFunctionNameString
args:argTypeArray
returning:returnType
in:self
"
Object subclass:#CInterface
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'Examples'.
CInterface cInterfaceFunction:#printfOn:format:withFloat:
calling:'fprintf'
args:#(ExternalStream String Float)
returning:#SmallInteger.
CInterface printfOn:Stdout format:'this is a float: %g' withFloat:(Float pi). Stdout cr
"
"Modified: 5.1.1997 / 19:58:22 / cg"
"Created: 2.4.1997 / 00:57:40 / stefan"
! !
!ClassDescription methodsFor:'changes management'!
addChangeRecordForMethod:aMethod
"{ Pragma: +optSpace }"
"add a method-change-record to the changes file"
UpdateChangeFileQuerySignal raise ifTrue:[
self writingChangePerform:#addChangeRecordForMethod:to: with:aMethod.
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodChange:aMethod in:self
]
]
"Modified: 20.1.1997 / 12:36:02 / cg"
"Created: 2.4.1997 / 01:02:16 / stefan"
!
addChangeRecordForMethodCategory:aMethod category:aString
"{ Pragma: +optSpace }"
"add a methodCategory-change-record to the changes file"
UpdateChangeFileQuerySignal raise ifTrue:[
self writingChangeDo:[:aStream |
self addChangeRecordForMethodCategory:aMethod category:aString to:aStream.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodCategoryChange:aMethod category:aString in:self
]
]
"Modified: 20.1.1997 / 12:36:05 / cg"
"Modified: 2.4.1997 / 17:30:20 / stefan"
!
addChangeRecordForMethodPrivacy:aMethod
"{ Pragma: +optSpace }"
"add a method-privacy-change-record to the changes file"
UpdateChangeFileQuerySignal raise ifTrue:[
self writingChangePerform:#addChangeRecordForMethodPrivacy:to: with:aMethod.
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodPrivacyChange:aMethod in:self
]
]
"Modified: 27.8.1995 / 22:47:32 / claus"
"Modified: 20.1.1997 / 12:36:08 / cg"
"Created: 2.4.1997 / 17:30:33 / stefan"
!
addChangeRecordForRemoveSelector:aSelector
"{ Pragma: +optSpace }"
"add a method-remove-record to the changes file"
UpdateChangeFileQuerySignal raise ifTrue:[
self writingChangePerform:#addChangeRecordForRemoveSelector:to: with:aSelector.
]
"Modified: 24.1.1997 / 19:10:48 / cg"
"Created: 2.4.1997 / 17:30:47 / stefan"
!
addChangeRecordForRenameCategory:oldCategory to:newCategory
"{ Pragma: +optSpace }"
"add a category-rename record to the changes file"
UpdateChangeFileQuerySignal raise ifTrue:[
self writingChangeDo:[:aStream |
self addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream.
]
]
"Modified: 24.1.1997 / 19:10:57 / cg"
"Created: 2.4.1997 / 17:31:03 / stefan"
!
addChangeTimeStampTo:aStream
"{ Pragma: +optSpace }"
"a timestamp - prepended to any change, except infoRecords"
|info|
info := 'timestamp ' , OperatingSystem getLoginName , '@' , OperatingSystem getHostName.
self addInfoRecord:info to:aStream. aStream cr.
"Modified: 22.3.1997 / 17:14:10 / cg"
"Created: 3.4.1997 / 19:18:27 / stefan"
!
addInfoRecord:aMessage
"{ Pragma: +optSpace }"
"add an info-record (snapshot, class fileOut etc.) to the changes file"
UpdateChangeFileQuerySignal raise ifTrue:[
self writingChangeWithTimeStamp:false
perform:#addInfoRecord:to:
with:aMessage.
]
"Modified: 24.1.1997 / 19:13:14 / cg"
"Created: 2.4.1997 / 17:34:18 / stefan"
!
changesStream
"return a Stream for the writing changes file.
This returns a regular stream or a locked stream - according to
the LockChangesFile settings
(recommended if multiple images operate on a common changes file)"
|streamType aStream fileName|
fileName := ObjectMemory nameForChanges.
LockChangesFile ifTrue:[
streamType := LockedFileStream.
] ifFalse:[
streamType := FileStream.
].
aStream := streamType oldFileNamed:fileName.
aStream isNil ifTrue:[
aStream := streamType newFileNamed:fileName.
aStream isNil ifTrue:[
self warn:'cannot create/update the changes file'.
^ nil
]
].
aStream setToEnd.
^ aStream
"Modified: 24.1.1997 / 19:14:27 / cg"
"Created: 2.4.1997 / 17:34:13 / stefan"
!
withoutUpdatingChangesDo:aBlock
"turn off change file update while evaluating aBlock."
UpdateChangeFileQuerySignal
answer:false
do:[
aBlock value
].
"Modified: 17.1.1997 / 20:48:05 / cg"
"Created: 2.4.1997 / 17:34:35 / stefan"
! !
!ClassDescription methodsFor:'compiling'!
compile:code
"compile code, aString for this class;
if successful update the method dictionary.
Returns the new method or nil (on failure)."
^ self compilerClass
compile:code
forClass:self
"Modified: 13.12.1995 / 10:56:00 / cg"
"Created: 1.4.1997 / 23:43:51 / stefan"
!
compile:code classified:category
"compile code, aString for this class;
if successful update the method dictionary.
The method is classified under category.
Returns the new method or nil (on failure)."
^ self compile:code classified:category logged:true
"Modified: 20.4.1996 / 12:30:51 / cg"
"Created: 1.4.1997 / 23:43:57 / stefan"
!
compile:code classified:category logged:logged
"compile code, aString for this class;
if successful update the method dictionary.
The method is classified under category.
If logged is true, a changeRecord is written.
Returns the new method or nil (on failure)."
logged ifFalse:[
self withoutUpdatingChangesDo:[
^ self compilerClass
compile:code
forClass:self
inCategory:category
]
] ifTrue:[
^ self compilerClass
compile:code
forClass:self
inCategory:category
].
"Modified: 13.12.1995 / 11:02:34 / cg"
"Created: 1.4.1997 / 23:44:02 / stefan"
!
compile:code notifying:requestor
"compile code, aString for this class; on any error, notify
requestor, anObject with the error reason.
Returns the new method or nil (on failure)."
^ self compilerClass
compile:code
forClass:self
notifying:requestor
"Modified: 13.12.1995 / 11:02:40 / cg"
"Created: 1.4.1997 / 23:43:43 / stefan"
!
recompile
"{ Pragma: +optSpace }"
"recompile all methods
used when a class changes instances and therefore all methods
have to be recompiled"
self methodDictionary keys do:[:aSelector |
self recompile:aSelector
]
"Modified: 12.6.1996 / 11:51:15 / stefan"
"Modified: 5.1.1997 / 19:56:23 / cg"
"Created: 1.4.1997 / 23:43:38 / stefan"
!
recompile:aSelector
"{ Pragma: +optSpace }"
"recompile the method associated with the argument, aSelector;
used when a superclass changes instances and we have to recompile
subclasses"
|cat code|
Class withoutUpdatingChangesDo:[
MethodRedefinitionSignal ignoreIn:[
cat := (self compiledMethodAt:aSelector) category.
code := self sourceCodeAt:aSelector.
self compilerClass compile:code forClass:self inCategory:cat
]
]
"Modified: 5.1.1997 / 19:56:54 / cg"
"Created: 1.4.1997 / 23:43:34 / stefan"
!
recompileAll
"{ Pragma: +optSpace }"
"recompile this class and all subclasses"
|classes|
classes := self subclasses.
self recompile.
classes do:[:aClass |
aClass recompileAll
]
"Modified: 5.1.1997 / 19:56:29 / cg"
"Created: 1.4.1997 / 23:44:15 / stefan"
!
recompileForSpeed:aSelector
"{ Pragma: +optSpace }"
"recompile the method associated with the argument, aSelector;
for highest speed (i.e. using the stc compiler, if supported by
the architecture)."
|cat code prev savedMethod|
Class withoutUpdatingChangesDo:[
MethodRedefinitionSignal ignoreIn:[
savedMethod := self compiledMethodAt:aSelector.
cat := savedMethod category.
code := self sourceCodeAt:aSelector.
prev := Compiler stcCompilation:#always.
[
self compilerClass compile:code forClass:self inCategory:cat
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:prev.
(self compiledMethodAt:aSelector) isNil ifTrue:[
self primAddSelector:aSelector withMethod:savedMethod
]
]
]
]
"Modified: 5.1.1997 / 19:55:33 / cg"
"Created: 1.4.1997 / 23:44:32 / stefan"
!
recompileInvalidatedMethods
"{ Pragma: +optSpace }"
"recompile all invalidated methods"
self methodDictionary keysAndValuesDo:[:aSelector :aMethod |
|trap trapCode trapByteCode|
trap := aMethod trapMethodForNumArgs:aMethod numArgs.
trapCode := trap code.
trapByteCode := trap byteCode.
(aMethod code = trapCode
or:[aMethod byteCode == trapByteCode]) ifTrue:[
self recompile:aSelector
]
]
"Modified: 12.6.1996 / 11:52:09 / stefan"
"Modified: 5.1.1997 / 19:56:59 / cg"
"Created: 1.4.1997 / 23:44:37 / stefan"
!
recompileMethodsAccessingAny:setOfNames
"{ Pragma: +optSpace }"
"recompile all methods accessing a variable from setOfNames"
self recompileMethodsAccessingAny:setOfNames orSuper:false
"Modified: 5.1.1997 / 19:57:05 / cg"
"Created: 1.4.1997 / 23:44:41 / stefan"
!
recompileMethodsAccessingAny:setOfNames orSuper:superBoolean
"{ Pragma: +optSpace }"
"recompile all methods accessing a variable from setOfNames,
or super (if superBoolean is true)"
|p|
self methodDictionary keys do:[:aSelector |
|m mustCompile lits source|
m := self compiledMethodAt:aSelector.
mustCompile := nil.
source := m source.
"/ avoid parsing, if possible
superBoolean ifFalse:[
setOfNames size == 1 ifTrue:[
(source findString:(setOfNames first)) == 0 ifTrue:[
mustCompile := false.
]
]
].
mustCompile isNil ifTrue:[
p := Parser parseMethod:(m source) in:self.
(p isNil
or:[(p usedVars notNil and:[p usedVars includesAny:setOfNames])
or:[superBoolean and:[p usesSuper]]]) ifTrue:[
mustCompile := true
]
].
mustCompile == true ifTrue:[
self recompile:aSelector
]
]
"Modified: 12.6.1996 / 11:52:35 / stefan"
"Modified: 9.1.1997 / 02:07:40 / cg"
"Created: 1.4.1997 / 23:44:46 / stefan"
!
recompileMethodsAccessingGlobal:aGlobalKey
"{ Pragma: +optSpace }"
"recompile all methods accessing the global variable aGlobalKey"
self methodDictionary keys do:[:aSelector |
|m lits|
m := self compiledMethodAt:aSelector.
"/ can look at the methods literalArray ..
m isWrapped ifTrue:[
m := m originalMethod
].
lits := m literals.
lits notNil ifTrue:[
(lits includes:aGlobalKey) ifTrue:[
self recompile:aSelector
]
]
]
"Modified: 12.6.1996 / 11:52:35 / stefan"
"Modified: 29.1.1997 / 23:51:11 / cg"
"Created: 1.4.1997 / 23:44:53 / stefan"
! !
!ClassDescription methodsFor:'fileIn interface'!
ignoredMethodsFor:aCategory
"this is a speciality of ST/X - it allows quick commenting of methods
from a source-file by replacing the 'methodsFor:' by 'ignoredMethodsFor:'.
Returns a ClassCategoryReader to read in and skip methods."
^ (self methodsFor:aCategory) ignoredProtocol
"Modified: 10.2.1996 / 12:53:25 / cg"
"Created: 1.4.1997 / 13:58:46 / stefan"
!
methods
"this method allows fileIn of ST/V methods -
return a ClassCategoryReader to read in and compile methods for me.
Since ST/V does not support method categories, the loaded methods are
categorized as 'ST/V methods'."
^ ClassCategoryReader class:self category:'ST/V methods'
"Modified: 10.2.1996 / 12:44:21 / cg"
"Created: 1.4.1997 / 13:58:52 / stefan"
!
methodsFor:aCategory
"return a ClassCategoryReader to read in and compile methods for me."
^ ClassCategoryReader class:self category:aCategory
"Modified: 10.2.1996 / 12:44:43 / cg"
"Created: 1.4.1997 / 13:57:37 / stefan"
!
methodsForUndefined:categoryString
"ST-80 compatibility.
I dont yet know what this does - it was encountered by some tester.
For now, simply forward it."
^ self methodsFor:categoryString
"Created: 1.4.1997 / 13:59:14 / stefan"
!
privateMethodsFor:aCategory
"this method allows fileIn of ENVY and ST/X private methods.
The following methods are only allowed to be executed if sent from a method
within the current class. Subclass sends or out-of-class sends will raise
a privatMethodError exception."
^ (self methodsFor:aCategory) privateProtocol
"Modified: 10.2.1996 / 12:48:44 / cg"
"Created: 1.4.1997 / 14:01:07 / stefan"
!
protectedMethodsFor:aCategory
"this method allows fileIn of ENVY and ST/X protected methods.
The following methods are only allowed to be executed if sent from a method
within the current class or a subclass. Out-of-class sends will raise
a privatMethodError exception."
^ (self methodsFor:aCategory) protectedProtocol
"Modified: 10.2.1996 / 12:49:18 / cg"
"Created: 1.4.1997 / 13:59:32 / stefan"
!
publicMethodsFor:aCategory
"this method allows fileIn of ENVY methods
The publicMethods keyword is for documentation only; my default, methods
are public anyway (for backward compatibility)."
^ self methodsFor:aCategory
"Modified: 10.2.1996 / 12:50:11 / cg"
"Created: 1.4.1997 / 13:59:39 / stefan"
! !
!ClassDescription methodsFor:'fileOut'!
fileOutCategory:aCategory
"create a file 'class-category.st' consisting of all methods in aCategory.
If the current project is not nil, create the file in the projects
directory."
|aStream fileName|
fileName := self name , '-' , aCategory , '.st'.
fileName replaceAll:(Character space) by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
self fileOutCategory:aCategory on:aStream.
aStream close
"Modified: 1.4.1997 / 16:00:24 / stefan"
"Created: 1.4.1997 / 16:04:18 / stefan"
!
fileOutCategory:aCategory except:skippedMethods only:savedMethods on:aStream
"file out all methods belonging to aCategory, aString onto aStream.
If skippedMethods is nonNil, those are not saved.
If savedMethods is nonNil, only those are saved.
If both are nil, all are saved. See version-method handling in
fileOut for what this is needed."
|dict source sortedSelectors first privacy interestingMethods cat|
dict := self methodDictionary.
dict notNil ifTrue:[
interestingMethods := OrderedCollection new.
dict do:[:aMethod |
|wanted|
(aCategory = aMethod category) ifTrue:[
skippedMethods notNil ifTrue:[
wanted := (skippedMethods includesIdentical:aMethod) not
] ifFalse:[
savedMethods notNil ifTrue:[
wanted := (savedMethods includesIdentical:aMethod).
] ifFalse:[
wanted := true
]
].
wanted ifTrue:[interestingMethods add:aMethod].
]
].
interestingMethods notEmpty ifTrue:[
first := true.
privacy := nil.
"/
"/ sort by selector
"/
sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m].
sortedSelectors sortWith:interestingMethods.
interestingMethods do:[:aMethod |
first ifFalse:[
privacy ~~ aMethod privacy ifTrue:[
first := true.
aStream space.
aStream nextPutChunkSeparator.
].
aStream cr; cr
].
privacy := aMethod privacy.
first ifTrue:[
aStream nextPutChunkSeparator.
self printClassNameOn:aStream.
privacy ~~ #public ifTrue:[
aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
] ifFalse:[
aStream nextPutAll:' methodsFor:'.
].
cat := aCategory.
cat isNil ifTrue:[ cat := '' ].
aStream nextPutAll:aCategory asString storeString.
aStream nextPutChunkSeparator; cr; cr.
first := false.
].
source := aMethod source.
source isNil ifTrue:[
FileOutErrorSignal
raiseRequestWith:self
errorString:'no source for method: ', (aMethod displayString)
] ifFalse:[
aStream nextChunkPut:source.
].
].
aStream space.
aStream nextPutChunkSeparator.
aStream cr
]
]
"Modified: 28.8.1995 / 14:30:41 / claus"
"Modified: 12.6.1996 / 11:37:33 / stefan"
"Modified: 15.11.1996 / 11:32:21 / cg"
"Created: 1.4.1997 / 16:04:33 / stefan"
!
fileOutCategory:aCategory on:aStream
"file out all methods belonging to aCategory, aString onto aStream"
self fileOutCategory:aCategory except:nil only:nil on:aStream
"Created: 1.4.1997 / 16:04:44 / stefan"
!
fileOutMethod:aMethod
"create a file 'class-method.st' consisting of the method, aMethod.
If the current project is not nil, create the file in the projects
directory."
|aStream fileName selector|
selector := self selectorAtMethod:aMethod.
selector notNil ifTrue:[
fileName := self name , '-' , selector, '.st'.
fileName replaceAll:$: by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
self fileOutMethod:aMethod on:aStream.
aStream close
]
"Modified: 1.4.1997 / 16:00:57 / stefan"
"Created: 2.4.1997 / 00:24:28 / stefan"
!
fileOutMethod:aMethod on:aStream
"file out the method, aMethod onto aStream"
|dict cat source privacy|
dict := self methodDictionary.
dict notNil ifTrue:[
aStream nextPutChunkSeparator.
self printClassNameOn:aStream.
(privacy := aMethod privacy) ~~ #public ifTrue:[
aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
] ifFalse:[
aStream nextPutAll:' methodsFor:'.
].
cat := aMethod category.
cat isNil ifTrue:[
cat := ''
].
aStream nextPutAll:cat asString storeString.
aStream nextPutChunkSeparator; cr; cr.
source := aMethod source.
source isNil ifTrue:[
FileOutErrorSignal
raiseRequestWith:self
errorString:('no source for method: ' ,
self name , '>>' ,
(self selectorAtMethod:aMethod))
] ifFalse:[
aStream nextChunkPut:source.
].
aStream space.
aStream nextPutChunkSeparator.
aStream cr
]
"Modified: 27.8.1995 / 01:23:19 / claus"
"Modified: 12.6.1996 / 11:44:41 / stefan"
"Modified: 15.11.1996 / 11:32:43 / cg"
"Created: 2.4.1997 / 00:24:33 / stefan"
! !
!ClassDescription methodsFor:'printOut'!
nameWithoutNameSpacePrefix
"helper for fileOut and others - return my names printString,
without any nameSpace prefix (but with owningClasses prefix)"
|nm owner|
nm := self nameWithoutPrefix.
(owner := self owningClass) isNil ifTrue:[
^ nm
].
^ (owner nameWithoutNameSpacePrefix , '::' , nm)
"a public class:
Array name
Array nameWithoutPrefix
Array nameWithoutNameSpacePrefix
"
"a private class:
Method::MethodWhoInfo name
Method::MethodWhoInfo nameWithoutPrefix
Method::MethodWhoInfo nameWithoutNameSpacePrefix
"
"a namespace class:
CodingExamples::TopClass name
CodingExamples::TopClass nameWithoutPrefix
CodingExamples::TopClass nameWithoutNameSpacePrefix
"
"a private class in a namespace class:
CodingExamples::TopClass::SubClass name
CodingExamples::TopClass::SubClass nameWithoutPrefix
CodingExamples::TopClass::SubClass nameWithoutNameSpacePrefix
"
"Modified: 5.1.1997 / 18:22:57 / cg"
"Created: 1.4.1997 / 16:20:13 / stefan"
!
nameWithoutPrefix
"helper for fileOut and others - return my names printString,
without any owningClass or nameSpace prefix"
|nm idx|
nm := self name.
idx := nm lastIndexOf:$:.
idx == 0 ifTrue:[
^ nm
].
^ nm copyFrom:idx+1.
"a public class:
Array name
Array nameWithoutPrefix
Array nameWithoutNameSpacePrefix
"
"a private class:
Method::MethodWhoInfo name
Method::MethodWhoInfo nameWithoutPrefix
Method::MethodWhoInfo nameWithoutNameSpacePrefix
"
"a namespace class:
CodingExamples::TopClass name
CodingExamples::TopClass nameWithoutPrefix
CodingExamples::TopClass nameWithoutNameSpacePrefix
"
"a private class in a namespace class:
CodingExamples::TopClass::SubClass name
CodingExamples::TopClass::SubClass nameWithoutPrefix
CodingExamples::TopClass::SubClass nameWithoutNameSpacePrefix
"
"Modified: 5.1.1997 / 18:23:14 / cg"
"Created: 1.4.1997 / 16:20:34 / stefan"
!
printClassNameOn:aStream
"helper for fileOut - print my name.
Private classes always print their owning-class as nameSpace
prefix; non-private ones print without, except if the
FileOutNameSpaceQuery returns true. The last feature is used
with changefile updates - here, the full name is wanted."
|nm|
Class fileOutNameSpaceQuerySignal raise == false ifTrue:[
nm := self nameWithoutNameSpacePrefix
] ifFalse:[
nm := self name.
].
aStream nextPutAll:nm.
"Modified: 3.1.1997 / 20:41:26 / cg"
"Created: 1.4.1997 / 16:06:57 / stefan"
"Modified: 1.4.1997 / 16:19:22 / stefan"
!
printHierarchyAnswerIndentOn:aStream
"print my class hierarchy on aStream - return indent
recursively calls itself to print superclass and use returned indent
for my description - used in the browser"
|indent nm|
indent := 0.
(superclass notNil) ifTrue:[
indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
].
aStream spaces:indent.
nm := self printNameInHierarchy.
aStream nextPutAll:nm; nextPutAll:' ('.
self printInstVarNamesOn:aStream indent:(indent + nm size + 2).
aStream nextPutLine:')'.
^ indent
"Created: 22.3.1997 / 14:11:29 / cg"
"Modified: 22.3.1997 / 14:15:42 / cg"
!
printHierarchyOn:aStream
"print my class hierarchy on aStream"
self printHierarchyAnswerIndentOn:aStream
"Created: 22.3.1997 / 14:11:13 / cg"
!
printInstVarNamesOn:aStream indent:indent
"print the instance variable names indented and breaking at line end"
self printNameArray:(self instVarNames) on:aStream indent:indent
"Created: 22.3.1997 / 14:12:00 / cg"
!
printNameArray:anArray on:aStream indent:indent
"print an array of strings separated by spaces; when the stream
defines a lineLength, break when this limit is reached; indent
every line; used to printOut instance variable names"
|thisName nextName arraySize lenMax pos mustBreak line spaces|
arraySize := anArray size.
arraySize ~~ 0 ifTrue:[
pos := indent.
lenMax := aStream lineLength.
thisName := anArray at:1.
line := ''.
1 to:arraySize do:[:index |
line := line , thisName.
pos := pos + thisName size.
(index == arraySize) ifFalse:[
nextName := anArray at:(index + 1).
mustBreak := false.
(lenMax > 0) ifTrue:[
((pos + nextName size) > lenMax) ifTrue:[
mustBreak := true
]
].
mustBreak ifTrue:[
aStream nextPutLine:line withTabs.
spaces isNil ifTrue:[
spaces := String new:indent
].
line := spaces.
pos := indent
] ifFalse:[
line := line , ' '.
pos := pos + 1
].
thisName := nextName
]
].
aStream nextPutAll:line withTabs
]
"Modified: 9.11.1996 / 00:12:06 / cg"
"Created: 22.3.1997 / 14:12:12 / cg"
!
printNameInHierarchy
"return my name as printed in the hierarchy"
^ self name
"Created: 22.3.1997 / 14:15:36 / cg"
! !
!ClassDescription methodsFor:'printing & storing'!
displayString
"return a string for display in inspectors"
|nm more cat|
cat := self category.
(cat = 'obsolete'
or:[cat = '* obsolete *']) ifTrue:[
"add obsolete - to make life easier ..."
more := ' (obsolete)'
].
(cat = 'removed'
or:[cat = '* removed *']) ifTrue:[
"add removed - to make life easier ..."
more := ' (removed)'
].
self isPrivate ifTrue:[
nm := self nameWithoutPrefix.
more := ' (private in ' , self owningClass name , ')'.
] ifFalse:[
nm := self name.
].
more isNil ifTrue:[^ nm].
^ nm , more
"Modified: 15.10.1996 / 20:01:30 / cg"
"Modified: 1.4.1997 / 15:49:13 / stefan"
!
isObsolete
"return true, if the receiver is obsolete
(i.e. has been replaced by a different class or was removed,
but is still referenced by instanced)"
|cat|
cat := self category.
^ cat = 'obsolete'
or:[cat = 'removed'
or:[cat = '* removed *'
or:[cat = '* obsolete *']]]
"Modified: 10.9.1996 / 14:02:07 / cg"
"Modified: 1.4.1997 / 15:49:49 / stefan"
! !
!ClassDescription methodsFor:'private changes management'!
addChangeRecordForMethod:aMethod to:aStream
"{ Pragma: +optSpace }"
"append a method-change-record to aStream"
self fileOutMethod:aMethod on:aStream.
"Created: 2.4.1997 / 17:31:46 / stefan"
!
addChangeRecordForMethodCategory:aMethod category:newCategory to:aStream
"{ Pragma: +optSpace }"
"append a methodCategory-change-record to aStream"
|selector|
selector := aMethod selector.
selector notNil ifTrue:[
aStream nextPutAll:'('.
self printClassNameOn:aStream.
aStream nextPutAll:(' compiledMethodAt:' , selector storeString).
aStream nextPutAll:(') category:' , newCategory storeString).
aStream nextPutChunkSeparator.
]
"Created: 2.4.1997 / 17:31:56 / stefan"
!
addChangeRecordForMethodPrivacy:aMethod to:aStream
"{ Pragma: +optSpace }"
"append a method-privacy-change-record to aStream"
|selector|
selector := aMethod selector.
selector notNil ifTrue:[
aStream nextPutAll:'('.
self printClassNameOn:aStream.
aStream nextPutAll:(' compiledMethodAt:' , selector storeString).
aStream nextPutAll:(') privacy:' , aMethod privacy storeString).
aStream nextPutChunkSeparator.
]
"Modified: 27.8.1995 / 22:59:56 / claus"
"Created: 2.4.1997 / 17:32:04 / stefan"
!
addChangeRecordForRemoveSelector:aSelector to:aStream
"{ Pragma: +optSpace }"
"append a method-remove-record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' removeSelector:' , aSelector asSymbol storeString).
aStream nextPutChunkSeparator.
"Modified: 1.7.1996 / 21:27:55 / cg"
"Created: 2.4.1997 / 17:32:31 / stefan"
!
addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream
"{ Pragma: +optSpace }"
"append a category-rename record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
aStream nextPutAll:(' to:' , newCategory storeString).
aStream nextPutChunkSeparator.
"Created: 2.4.1997 / 17:32:44 / stefan"
!
addInfoRecord:aMessage to:aStream
"{ Pragma: +optSpace }"
"append an info-record (snapshot, class fileOut etc.) to aStream"
aStream nextPutAll:('''---- ' , aMessage , ' ',
Date today printString , ' ' ,
Time now printString ,
' ----''').
aStream nextPutChunkSeparator.
"Created: 2.4.1997 / 17:33:42 / stefan"
!
writingChangeDo:aBlock
"{ Pragma: +optSpace }"
"common helper to write a change record.
Opens the changefile and executes aBlock passing the stream
as argument. WriteErrors are caught and will lead to a warning.
The changefile is not kept open, to force the change to go to disk
as soon as possible - thus, in case of a crash, no changes should
be lost due to buffering."
self writingChangeWithTimeStamp:true do:aBlock
"Modified: 18.11.1995 / 15:43:36 / cg"
"Created: 2.4.1997 / 17:32:57 / stefan"
!
writingChangePerform:aSelector with:anArgument
"{ Pragma: +optSpace }"
self writingChangeWithTimeStamp:true perform:aSelector with:anArgument
"Modified: 18.11.1995 / 15:44:53 / cg"
"Created: 2.4.1997 / 17:33:03 / stefan"
!
writingChangeWithTimeStamp:doStampIt do:aBlock
"{ Pragma: +optSpace }"
"common helper to write a change record.
Opens the changefile and executes aBlock passing the stream
as argument. WriteErrors are caught and will lead to a warning.
The changefile is not kept open, to force the change to go to disk
as soon as possible - thus, in case of a crash, no changes should
be lost due to buffering.
Access to the change file is serialized via the accessLock;
this prevents the changefile to be corrupted when multiple users
accept in the browser in a multi-display (or timesliced) configuration"
ChangeFileAccessLock critical:[
|aStream|
FileOutNameSpaceQuerySignal answer:true
do:[
aStream := self changesStream.
aStream notNil ifTrue:[
[
FileStream writeErrorSignal handle:[:ex |
self warn:('could not update the changes-file\\' , ex errorString) withCRs.
ex return
] do:[
doStampIt ifTrue:[
self addChangeTimeStampTo:aStream
].
aBlock value:aStream.
aStream cr.
].
] valueNowOrOnUnwindDo:[
aStream close
]
]
]
]
"Modified: 22.3.1997 / 17:12:40 / cg"
"Created: 2.4.1997 / 17:33:09 / stefan"
!
writingChangeWithTimeStamp:stampIt perform:aSelector with:anArgument
"{ Pragma: +optSpace }"
self writingChangeWithTimeStamp:stampIt do:[:stream |
self perform:aSelector with:anArgument with:stream.
]
"Created: 2.4.1997 / 17:33:16 / stefan"
! !
!ClassDescription methodsFor:'private helpers'!
addAllCategoriesTo:aCollection
"helper - add categories and all superclasses categories
to the argument, aCollection"
(superclass notNil) ifTrue:[
superclass addAllCategoriesTo:aCollection
].
self addCategoriesTo:aCollection
"Created: 1.4.1997 / 23:52:27 / stefan"
!
addCategoriesTo:aCollection
"helper - add categories to the argument, aCollection"
self methodDictionary do:[:aMethod |
|cat|
cat := aMethod category.
(aCollection includes:cat) ifFalse:[
aCollection add:cat
]
]
"Modified: 12.6.1996 / 11:46:24 / stefan"
"Created: 1.4.1997 / 23:52:38 / stefan"
! !
!ClassDescription methodsFor:'protocol printOut'!
printOutCategoryProtocol:aCategory on:aPrintStream
"{ Pragma: +optSpace }"
|dict any|
dict := self methodDictionary.
dict notNil ifTrue:[
any := false.
dict do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
any := true
]
].
any ifTrue:[
aPrintStream italic.
aPrintStream nextPutAll:aCategory.
aPrintStream normal.
aPrintStream cr; cr.
dict do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
self printOutMethodProtocol:aMethod on:aPrintStream.
aPrintStream cr; cr
]
].
aPrintStream cr
]
]
"Modified: 20.4.1996 / 18:20:26 / cg"
"Modified: 12.6.1996 / 11:48:46 / stefan"
"Created: 2.4.1997 / 01:10:40 / stefan"
!
printOutMethodProtocol:aMethod on:aPrintStream
"{ Pragma: +optSpace }"
"given the source in aString, print the methods message specification
and any method comments - without source; used to generate documentation
pages"
|text comment|
text := aMethod source asStringCollection.
(text size < 1) ifTrue:[^self].
aPrintStream bold.
aPrintStream nextPutLine:(text at:1).
(text size >= 2) ifTrue:[
(comment := aMethod comment) notNil ifTrue:[
aPrintStream italic.
aPrintStream spaces:((text at:2) indexOfNonSeparatorStartingAt:1).
aPrintStream nextPutLine:aMethod comment.
]
].
aPrintStream normal
"
Float printOutProtocolOn:Stdout
"
"Modified: 9.11.1996 / 00:13:54 / cg"
"Created: 2.4.1997 / 01:11:00 / stefan"
! !
!ClassDescription methodsFor:'queries'!
allCategories
"Return a collection of all method-categories known in class
and all superclasses. This does NOT include the metaclass categories.
The returned collection is not sorted by any order."
|coll|
coll := OrderedCollection new.
self addAllCategoriesTo:coll.
^ coll
"
Point categories
Point allCategories
Point class categories
Point class allCategories
"
"Modified: 21.3.1996 / 16:28:57 / cg"
"Created: 1.4.1997 / 15:57:41 / stefan"
!
categories
"Return a collection of all method-categories known in the receiver class.
This does NOT include the metaclasses categories or the superclass categories.
The returned collection is not sorted by any order."
|newList cat|
newList := OrderedCollection new.
self methodDictionary do:[:aMethod |
cat := aMethod category.
newList indexOf:cat ifAbsent:[newList add:cat]
].
^ newList
"
Point categories
Point class categories
"
"Modified: 16.4.1996 / 18:06:11 / cg"
"Modified: 12.6.1996 / 11:25:59 / stefan"
"Created: 1.4.1997 / 15:57:18 / stefan"
!
whichClassDefinesInstVar:aVariableName
"return the class which defines the instance variable
named aVariableName. This method should not be used for
repeated searches (i.e. in the compiler/parser), since it creates
many throw away intermediate objects."
|cls|
cls := self.
[cls notNil] whileTrue:[
(cls instVarNames includes:aVariableName) ifTrue:[ ^ cls].
cls := cls superclass
].
^ nil
"
StandardSystemView whichClassDefinesInstVar:'label'
StandardSystemView whichClassDefinesInstVar:'paint'
StandardSystemView whichClassDefinesInstVar:'foo'
"
"Created: 2.4.1997 / 01:12:27 / stefan"
! !
!ClassDescription methodsFor:'special accessing'!
setInstanceVariableString:aString
"set the classes instvarnames string - no recompilation
or updates are done and no changeList records are written.
This is NOT for general use."
instvars := aString.
! !
!ClassDescription methodsFor:'subclass creation'!
subclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver).
The subclass will have indexed variables if the receiving-class has."
self isVariable ifFalse:[
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:false
words:true
pointers:true
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
].
^ self
perform:(self definitionSelector)
withArguments:(Array with:nameSymbol
with:instVarNameString
with:classVarString
with:pool
with:cat).
"Modified: 8.3.1997 / 00:41:08 / cg"
!
subclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat inEnvironment:aNameSpace
"create a new class as a subclass of an existing class (the receiver).
The subclass will have indexed variables if the receiving-class has."
self isVariable ifTrue:[
Class nameSpaceQuerySignal handle:[:ex |
ex proceedWith:aNameSpace
] do:[
^ self
subclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
category:cat
].
].
^ self class
name:nameSymbol
inEnvironment:aNameSpace
subclassOf:self
instanceVariableNames:instVarNameString
variable:false
words:true
pointers:true
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 8.2.1997 / 19:41:44 / cg"
"Modified: 8.2.1997 / 20:03:52 / cg"
!
variableByteSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable byte-sized nonpointer variables"
self isVariable ifTrue:[
self isBytes ifFalse:[
^ self error:
'cannot make a variable byte subclass of a variable non-byte class'
].
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:true
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:18 / cg"
"Modified: 6.11.1996 / 22:48:18 / cg"
!
variableDoubleSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable double-sized nonpointer variables"
self isVariable ifTrue:[
self isDoubles ifFalse:[
^ self error:
'cannot make a variable double subclass of a variable non-double class'
].
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:#double
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:21 / cg"
"Modified: 6.11.1996 / 22:48:22 / cg"
!
variableFloatSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable float-sized nonpointer variables"
self isVariable ifTrue:[
self isFloats ifFalse:[
^ self error:
'cannot make a variable float subclass of a variable non-float class'
].
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:#float
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:24 / cg"
"Modified: 6.11.1996 / 22:48:26 / cg"
!
variableLongSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable long-sized nonpointer variables"
self isVariable ifTrue:[
self isLongs ifFalse:[
^ self error:
'cannot make a variable long subclass of a variable non-long class'
].
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:#long
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:27 / cg"
"Modified: 6.11.1996 / 22:48:29 / cg"
!
variableSignedLongSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable signed long-sized nonpointer variables"
self isVariable ifTrue:[
self isSignedLongs ifFalse:[
^ self error:
'cannot make a variable signed long subclass of a variable non-long class'
].
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:#signedLong
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:31 / cg"
"Modified: 6.11.1996 / 22:48:32 / cg"
!
variableSignedWordSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable word-sized signed nonpointer variables"
self isVariable ifTrue:[
self isSignedWords ifFalse:[
^ self error:
'cannot make a variable signed word subclass of a variable non-word class'
].
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:#signedWord
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:34 / cg"
"Modified: 6.11.1996 / 22:48:35 / cg"
!
variableSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable pointer variables"
self isVariable ifTrue:[
self isPointers ifFalse:[
^ self error:
'cannot make a variable pointer subclass of a variable non-pointer class'
]
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:true
words:false
pointers:true
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:37 / cg"
"Modified: 6.11.1996 / 22:48:40 / cg"
!
variableWordSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable word-sized nonpointer variables"
self isVariable ifTrue:[
self isWords ifFalse:[
^ self error:
'cannot make a variable word subclass of a variable non-word class'
].
].
^ self class
name:nameSymbol
inEnvironment:(Class nameSpaceQuerySignal raise)
subclassOf:self
instanceVariableNames:instVarNameString
variable:true
words:true
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:cat
comment:nil
changed:true
"Created: 12.10.1996 / 19:18:40 / cg"
"Modified: 6.11.1996 / 22:48:43 / cg"
! !
!ClassDescription methodsFor:'subclass creation - private classes'!
subclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver).
The subclass will have indexed variables if the receiving-class has."
|newClass|
self isVariable ifFalse:[
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:false
words:true
pointers:true
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
].
self isBytes ifTrue:[
^ self
variableByteSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
].
self isLongs ifTrue:[
^ self
variableLongSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
].
self isFloats ifTrue:[
^ self
variableFloatSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
].
self isDoubles ifTrue:[
^ self
variableDoubleSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
].
self isWords ifTrue:[
^ self
variableWordSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
].
self isSignedWords ifTrue:[
^ self
variableSignedWordSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
].
self isSignedLongs ifTrue:[
^ self
variableSignedLongSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
].
^ self
variableSubclass:nameSymbol
instanceVariableNames:instVarNameString
classVariableNames:classVarString
poolDictionaries:pool
privateIn:aClass
"Created: 11.10.1996 / 16:30:53 / cg"
"Modified: 5.11.1996 / 23:05:22 / cg"
!
variableByteSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable byte-sized nonpointer variables"
|newClass|
self isVariable ifTrue:[
self isBytes ifFalse:[
^ self error:
'cannot make a variable byte subclass of a variable non-byte class'
].
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:true
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:31:27 / cg"
"Modified: 14.10.1996 / 17:39:42 / cg"
!
variableDoubleSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable double-sized nonpointer variables"
|newClass|
self isVariable ifTrue:[
self isDoubles ifFalse:[
^ self error:
'cannot make a variable double subclass of a variable non-double class'
].
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:#double
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:32:23 / cg"
"Modified: 14.10.1996 / 17:39:45 / cg"
!
variableFloatSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable float-sized nonpointer variables"
|newClass|
self isVariable ifTrue:[
self isFloats ifFalse:[
^ self error:
'cannot make a variable float subclass of a variable non-float class'
].
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:#float
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:32:37 / cg"
"Modified: 14.10.1996 / 17:39:50 / cg"
!
variableLongSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable long-sized nonpointer variables"
|newClass|
self isVariable ifTrue:[
self isLongs ifFalse:[
^ self error:
'cannot make a variable long subclass of a variable non-long class'
].
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:#long
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:32:48 / cg"
"Modified: 14.10.1996 / 17:39:54 / cg"
!
variableSignedLongSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable signed long-sized nonpointer variables"
|newClass|
self isVariable ifTrue:[
self isSignedLongs ifFalse:[
^ self error:
'cannot make a variable signed long subclass of a variable non-long class'
].
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:#signedLong
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:46:30 / cg"
"Modified: 14.10.1996 / 17:39:58 / cg"
!
variableSignedWordSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable word-sized signed nonpointer variables"
|newClass|
self isVariable ifTrue:[
self isSignedWords ifFalse:[
^ self error:
'cannot make a variable signed word subclass of a variable non-word class'
].
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:#signedWord
words:false
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:46:44 / cg"
"Modified: 14.10.1996 / 17:40:01 / cg"
!
variableSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable pointer variables"
|newClass|
self isVariable ifTrue:[
self isPointers ifFalse:[
^ self error:
'cannot make a variable pointer subclass of a variable non-pointer class'
]
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:true
words:false
pointers:true
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:54:33 / cg"
"Modified: 14.10.1996 / 17:40:06 / cg"
!
variableWordSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool privateIn:aClass
"create a new class as a subclass of an existing class (the receiver)
in which the subclass has indexable word-sized nonpointer variables"
|newClass|
self isVariable ifTrue:[
self isWords ifFalse:[
^ self error:
'cannot make a variable word subclass of a variable non-word class'
].
].
newClass := self class
name:nameSymbol
inEnvironment:aClass
subclassOf:self
instanceVariableNames:instVarNameString
variable:true
words:true
pointers:false
classVariableNames:classVarString
poolDictionaries:pool
category:(aClass category)
comment:nil
changed:true.
^ newClass
"Created: 11.10.1996 / 16:54:48 / cg"
"Modified: 14.10.1996 / 17:40:09 / cg"
! !
!ClassDescription class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Attic/ClassDescr.st,v 1.48 1997-06-16 18:20:26 cg Exp $'
! !
ClassDescription initialize!