.
"
COPYRIGHT (c) 1989 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.
"
ClassDescription subclass:#Class
instanceVariableNames:'classvars comment subclasses classFilename package history'
classVariableNames:'UpdatingChanges FileOutErrorSignal'
poolDictionaries:''
category:'Kernel-Classes'
!
Class comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libbasic/Class.st,v 1.40 1995-05-01 21:28:45 claus Exp $
'!
!Class class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 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.
"
!
version
"
$Header: /cvs/stx/stx/libbasic/Class.st,v 1.40 1995-05-01 21:28:45 claus Exp $
"
!
documentation
"
Class adds more functionality to classes; minimum stuff has already
been defined in Behavior and ClassDescription; this adds naming, categories etc.
Also change management and recompilation is defined here (since the superclasses
do not have enough symbolic information to support compilation).
For production code, the stc compiler is planned to (optionally) generate classes
as subclasses of Behavior - to excludes all name, source info etc.,
however, normally all classes are subclasses of Class.
Instance variables:
classvars <String> the names of the class variables
comment <String> the classes comment; either a string,
a number specifying the offset in classFilename, or nil
subclasses <Collection> cached collection of subclasses
(currently unused - but will be soon)
classFilename <String> the file (or nil) where the classes
sources are found
package <Symbol> the package, in which the class was defined
(not currently used)
history <any> a place for a history string (not currently used)
Class variables:
UpdatingChanges <Boolean> true if the changes-file shall be updated
(except during startup and when filing in, this flag
is usually true)
FileOutErrorSignal raised when an error occurs during fileOut
WARNING: layout known by compiler and runtime system
"
! !
!Class 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.
FileOutErrorSignal isNil ifTrue:[
FileOutErrorSignal := Object errorSignal newSignalMayProceed:false.
FileOutErrorSignal nameClass:self message:#fileOutErrorSignal.
FileOutErrorSignal notifierString:'error during fileOut'.
]
! !
!Class class methodsFor:'signal access'!
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
! !
!Class class methodsFor:'creating new classes'!
new
"creates and returs a new class"
|newClass|
newClass := super new.
"/ newClass setComment:(self comment) category:(self category).
^ newClass
! !
!Class 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]
"
!
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
! !
!Class methodsFor:'subclass creation'!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s 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:t
inEnvironment:Smalltalk
subclassOf:self
instanceVariableNames:f
variable:false
words:true
pointers:true
classVariableNames:d
poolDictionaries:s
category:cat
comment:nil
changed:false
].
self isBytes ifTrue:[
^ self
variableByteSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
].
self isLongs ifTrue:[
^ self
variableLongSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
].
self isFloats ifTrue:[
^ self
variableFloatSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
].
self isDoubles ifTrue:[
^ self
variableDoubleSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
].
self isWords ifTrue:[
^ self
variableWordSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
].
^ self
variableSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
!
variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s 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:t
inEnvironment:Smalltalk
subclassOf:self
instanceVariableNames:f
variable:true
words:false
pointers:true
classVariableNames:d
poolDictionaries:s
category:cat
comment:nil
changed:false
!
variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s 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:t
inEnvironment:Smalltalk
subclassOf:self
instanceVariableNames:f
variable:true
words:false
pointers:false
classVariableNames:d
poolDictionaries:s
category:cat
comment:nil
changed:false
!
variableWordSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s 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:t
inEnvironment:Smalltalk
subclassOf:self
instanceVariableNames:f
variable:true
words:true
pointers:false
classVariableNames:d
poolDictionaries:s
category:cat
comment:nil
changed:false
!
variableLongSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s 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:t
inEnvironment:Smalltalk
subclassOf:self
instanceVariableNames:f
variable:#long
words:false
pointers:false
classVariableNames:d
poolDictionaries:s
category:cat
comment:nil
changed:false
!
variableFloatSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s 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:t
inEnvironment:Smalltalk
subclassOf:self
instanceVariableNames:f
variable:#float
words:false
pointers:false
classVariableNames:d
poolDictionaries:s
category:cat
comment:nil
changed:false
!
variableDoubleSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s 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:t
inEnvironment:Smalltalk
subclassOf:self
instanceVariableNames:f
variable:#double
words:false
pointers:false
classVariableNames:d
poolDictionaries:s
category:cat
comment:nil
changed:false
! !
!Class methodsFor:'ST/V subclass creation'!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V classes
(which seem to have no category)"
^ self subclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:'ST/V classes'
!
variableByteSubclass:t classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V variable byte classes
(which seem to have no category and no instvars)"
^ self variableByteSubclass:t
instanceVariableNames:''
classVariableNames:d
poolDictionaries:s
category:'ST/V classes'
!
variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V variable pointer classes
(which seem to have no category)"
^ self variableSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:'ST/V classes'
! !
!Class methodsFor:'accessing'!
classVariableString
"return a string of the class variables names.
Only names of class variables defined in this class are in the
returned string."
classvars isNil ifTrue:[^ ''].
^ classvars
"
Object classVariableString
Float classVariableString
"
!
classVarNames
"return a collection of the class variable name-strings.
Only names of class variables defined in this class are included
in the returned collection - use allClassVarNames, to get all known names."
classvars isNil ifTrue:[
^ OrderedCollection new
].
^ classvars asCollectionOfWords
"
Object classVarNames
Float classVarNames
"
!
classVarAt:aSymbol
"return the value of a class variable.
Currently, this returns nil if there is no such classvar -
this may change."
"
this hides the (current) implementation of classVariables
from the outside world. Currently, classvars are stored in
the Smalltalk dictionary with a funny name, since there are
no classPools yet.
"
^ Smalltalk at:(self name , ':' , aSymbol) asSymbol
!
classVarAt:aSymbol put:something
"store something in a classvariable.
Currently this creates a global with a funny name if no such
classVar exists - this may change."
"
this hides the (current) implementation of classVariables
from the outside world. Currently, classvars are stored in
the Smalltalk dictionary with a funny name, since there are
no classPools yet.
"
Smalltalk at:(self name , ':' , aSymbol) asSymbol put:something.
!
allClassVarNames
"return a collection of all the class variable name-strings
this includes all superclass-class variables"
^ self addAllClassVarNamesTo:(OrderedCollection new)
"
Float allClassVarNames
"
!
comment
"return the comment (aString) of the class"
|stream string|
"the comment is either a string, or an integer specifying the
position within the classes sourcefile ...
"
comment isNumber ifTrue:[
classFilename notNil ifTrue:[
stream := Smalltalk sourceFileStreamFor:classFilename.
stream notNil ifTrue:[
stream position:comment.
string := String readFrom:stream onError:''.
stream close.
^ string
]
]
].
^ comment
"
Object comment
"
!
setComment:aString
"set the comment of the class to be the argument, aString;
do NOT create a change record"
comment := aString
!
comment:aString
"set the comment of the class to be the argument, aString;
create a change record and notify dependents."
|oldComment|
comment ~= aString ifTrue:[
oldComment := self comment.
comment := aString.
self changed:#comment with:oldComment.
self addChangeRecordForClassComment:self.
]
!
package
"return the package of the class"
^ package
"
Object package
"
!
setPackage:aStringOrSymbol
"set the package of the class."
package := aStringOrSymbol
!
package:aStringOrSymbol
"set the package of the class."
package := aStringOrSymbol
!
history
"return the history of the class"
^ history
"
Object history
"
!
setHistory:aString
"set the history of the class."
history := aString
!
history:aString
"set the history of the class."
history := aString
!
primitiveSpec
"return the primitiveSpec or nil"
^ primitiveSpec
!
primitiveDefinitionsString
"return the primitiveDefinition string or nil"
^ self primitiveSpecs:1
"
Object primitiveDefinitionsString
String primitiveDefinitionsString
"
!
primitiveVariablesString
"return the primitiveVariables string or nil"
^ self primitiveSpecs:2
!
primitiveFunctionsString
"return the primitiveFunctions string or nil"
^ self primitiveSpecs:3
!
primitiveDefinitions:aString
"set the primitiveDefinition string"
^ self setPrimitiveSpecs:1 to:aString
!
primitiveVariables:aString
"set the primitiveVariable string"
^ self setPrimitiveSpecs:2 to:aString
!
primitiveFunctions:aString
"set the primitiveFunction string"
^ self setPrimitiveSpecs:3 to:aString
!
classFilename
"return the name of the file from which the class was compiled.
This is currently NOT used."
^ classFilename
!
definition
"return an expression-string to define myself"
|s|
s := WriteStream on:(String new).
self fileOutDefinitionOn:s.
^ s contents
"
Object definition
Point definition
"
!
source
"return the classes full source code"
|code aStream|
" this is too slow for big classes ...
code := String new:1000.
aStream := WriteStream on:code.
self fileOutOn:aStream
"
aStream := FileStream newFileNamed:'__temp'.
aStream isNil ifTrue:[
self notify:'cannot create temporary file.'.
^ nil
].
self fileOutOn:aStream.
aStream close.
aStream := FileStream oldFileNamed:'__temp'.
aStream isNil ifTrue:[
self notify:'oops - cannot reopen temp file'.
^ nil
].
code := aStream contents.
aStream close.
OperatingSystem removeFile:'__temp'.
^ code
!
sharedPools
"ST/X does not (currently) support pools"
^ #()
!
setComment:com category:categoryStringOrSymbol
"set the comment and category of the class;
do NOT create a change record"
comment := com.
category := categoryStringOrSymbol asSymbol
!
setClassVariableString:aString
"set the classes classvarnames string.
This is a dangerous (low level) operation, since the
classvariables are not really created or updated. Also,
NO change record is written."
classvars := aString
!
classVariableString:aString
"set the classes classvarnames string;
Initialize new class variables with nil, clear and remove old ones.
No change record is written and no classes are recompiled."
|prevVarNames varNames any|
"ignore for metaclasses except the one"
(self isMeta) ifTrue:[
(self == Metaclass) ifFalse:[
^ self
]
].
(classvars = aString) ifFalse:[
prevVarNames := self classVarNames.
classvars := aString.
varNames := self classVarNames.
"new ones get initialized to nil;
- old ones are nilled and removed from Smalltalk"
any := false.
varNames do:[:aName |
(prevVarNames includes:aName) ifFalse:[
"a new one"
self classVarAt:aName put:nil.
any := true.
] ifTrue:[
prevVarNames remove:aName
]
].
"left overs are gone"
prevVarNames do:[:aName |
self classVarAt:aName put:nil.
Smalltalk removeKey:(self name , ':' , aName) asSymbol.
].
any ifTrue:[
Smalltalk changed:#classVariables
]
]
!
addClassVarName:aString
"add a class variable if not already there and initialize it with nil.
Also write a change record and notify dependents.
BUG: Currently, no recompilation is done - this will change."
(self classVarNames includes:aString) ifFalse:[
self classVariableString:(self classVariableString , ' ' , aString).
self addChangeRecordForClass:self.
self changed:#definition.
]
!
removeClassVarName:aString
"remove a class variable if not already there.
Also write a change record and notify dependents.
BUG: Currently, no recompilation is done - this will change."
|names newNames|
names := self classVarNames.
(names includes:aString) ifTrue:[
newNames := ''.
names do:[:nm | nm ~= aString ifTrue:[newNames := newNames , nm , ' ']].
self classVariableString:newNames withoutSpaces.
self addChangeRecordForClass:self.
self changed:#definition.
]
!
renameCategory:oldCategory to:newCategory
"rename a category (changes category of those methods).
Append a change record and notifies dependents."
|any|
any := false.
methodArray do:[:aMethod |
aMethod category = oldCategory ifTrue:[
aMethod category:newCategory.
any := true.
]
].
any ifTrue:[
self addChangeRecordForRenameCategory:oldCategory to:newCategory.
self changed:#methodCategory.
]
! !
!Class 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."
(super addSelector:newSelector withMethod:newMethod) ifTrue:[
self addChangeRecordForMethod:newMethod
]
!
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.
self changed:#methodDictionary with:aSelector.
]
!
unload
"if the receiver was autoloaded, unload and reinstall it as
autoloaded. Can be used to get rid of no longer needed autoloaded
classes.
(maybe, autoloaded classes should unload themselfes when no
longer needed - for example, after some delay when the last instance
is gone ...)"
|nm|
self wasAutoloaded ifFalse:[
"
can it be done ?
"
self methodArray do:[:aMethod |
aMethod source isNil ifTrue:[^false].
aMethod hasPrimitiveCode ifTrue:[^ false].
].
].
self allSubclassesDo:[:aClass |
aClass unload
].
Transcript showCr:'unloading ' , name.
nm := name.
Smalltalk at:nm put:nil.
name := nm , ' (leftover)'.
ObjectMemory flushInlineCaches.
ObjectMemory flushMethodCache.
Autoload addClass:nm inCategory:category.
^ true
"
Clock open.
Clock unload.
ClockView unload.
Clock open
"
! !
!Class methodsFor:'changes management'!
withoutUpdatingChangesDo:aBlock
"turn off change file update while evaluating aBlock.
This method makes sure, that the update-flag is correctly restored
in case of an abort or other error."
|prev|
prev := UpdatingChanges.
UpdatingChanges := false.
aBlock valueNowOrOnUnwindDo:[
prev ifTrue:[UpdatingChanges := true]
].
!
updateChanges:aBoolean
"turn on/off changes management. Return the prior value of the flag."
|prev|
prev := UpdatingChanges.
UpdatingChanges := aBoolean.
^ prev
!
updatingChanges
"return true if changes are recorded"
^ UpdatingChanges
!
changesStream
"return a Stream for the changes file - or nil if no update is wanted"
|aStream fileName|
UpdatingChanges ifTrue:[
fileName := ObjectMemory nameForChanges.
aStream := FileStream oldFileNamed:fileName.
aStream isNil ifTrue:[
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
self warning:'cannot create/update changes file'.
^ nil
]
].
aStream setToEnd
].
^ aStream
!
sourcesStream
"return a stream for the sources file"
|aStream fileName|
fileName := ObjectMemory nameForSources.
aStream := FileStream oldFileNamed:fileName.
aStream isNil ifTrue:[
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
Transcript showCr:'cannot update sources file'.
^ nil
]
].
aStream setToEnd.
^ aStream
!
writingChangeDo:aBlock
"common helper to write a change record.
Opens the changefile and executes aBlock passing the stream
as argument. WriteErrors are cought 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."
|aStream|
aStream := self changesStream.
aStream notNil ifTrue:[
FileStream writeErrorSignal handle:[:ex |
self warning:('could not update the changes-file\\' , ex errorString) withCRs.
ex return
] do:[
aBlock value:aStream.
aStream cr.
].
aStream close
]
!
writingChangePerform:aSelector with:anArgument
|aStream|
aStream := self changesStream.
aStream notNil ifTrue:[
FileStream writeErrorSignal handle:[:ex |
self warning:('could not update the changes-file\\' , ex errorString) withCRs.
ex return
] do:[
self perform:aSelector with:anArgument with:aStream.
aStream cr.
].
aStream close
]
!
addChangeRecordForMethod:aMethod to:aStream
"append a method-change-record to aStream"
self fileOutMethod:aMethod on:aStream.
!
addChangeRecordForRemoveSelector:aSelector to:aStream
"append a method-remove-record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' removeSelector:#' , aSelector).
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForMethodCategory:aMethod category:newCategory to:aStream
"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 nextPut:(aStream class chunkSeparator).
]
!
addChangeRecordForClass:aClass to:aStream
"append a class-definition-record to aStream"
aClass fileOutDefinitionOn:aStream.
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForClassInstvars:aClass to:aStream
"append a class-instvars-record to aStream"
aClass fileOutClassInstVarDefinitionOn:aStream.
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForClassComment:aClass to:aStream
"append a class-comment-record to aStream"
aClass fileOutCommentOn:aStream.
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForClassRename:oldName to:newName to:aStream
"append a class-rename-record to aStream"
aStream nextPutAll:('Smalltalk renameClass:' , oldName , ' to:''' , newName , '''').
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForClassRemove:oldName to:aStream
"append a class-remove-record to aStream"
aStream nextPutAll:('Smalltalk removeClass:' , oldName).
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream
"append a category-rename record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
aStream nextPutAll:(' to:' , newCategory storeString).
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForChangeCategory:category to:aStream
"append a category change record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' category:' , category storeString).
aStream nextPut:(aStream class chunkSeparator).
!
addInfoRecord:aMessage to:aStream
"append an info-record (snapshot, class fileOut etc.) to aStream"
aStream nextPutAll:('''---- ' , aMessage , ' ',
Date today printString , ' ' ,
Time now printString ,
' ----''').
aStream nextPut:(aStream class chunkSeparator).
!
addChangeRecordForSnapshot:aFileName to:aStream
"add a snapshot-record to aStream"
self addInfoRecord:('snapshot ' , aFileName) to:aStream
!
addChangeRecordForMethod:aMethod
"add a method-change-record to the changes file"
UpdatingChanges ifTrue:[
self writingChangePerform:#addChangeRecordForMethod:to: with:aMethod.
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodChange:aMethod in:self
]
]
!
addChangeRecordForRemoveSelector:aSelector
"add a method-remove-record to the changes file"
self writingChangePerform:#addChangeRecordForRemoveSelector:to: with:aSelector.
!
addChangeRecordForMethodCategory:aMethod category:aString
"add a methodCategory-change-record to the changes file"
UpdatingChanges 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
]
]
!
addChangeRecordForClass:aClass
"add a class-definition-record to the changes file"
self writingChangePerform:#addChangeRecordForClass:to: with:aClass.
!
addChangeRecordForClassInstvars:aClass
"add a class-instvars-record to the changes file"
self writingChangePerform:#addChangeRecordForClassInstvars:to: with:aClass.
!
addChangeRecordForClassComment:aClass
"add a class-comment-record to the changes file"
self writingChangePerform:#addChangeRecordForClassComment:to: with:aClass.
!
addChangeRecordForClassRename:oldName to:newName
"add a class-rename-record to the changes file"
UpdatingChanges ifTrue:[
self writingChangeDo:[:aStream |
self addChangeRecordForClassRename:oldName to:newName to:aStream
]
]
!
addChangeRecordForClassRemove:oldName
"add a class-remove-record to the changes file"
self writingChangePerform:#addChangeRecordForClassRemove:to: with:oldName.
!
addChangeRecordForRenameCategory:oldCategory to:newCategory
"add a category-rename record to the changes file"
UpdatingChanges ifTrue:[
self writingChangeDo:[:aStream |
self addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream.
]
]
!
addChangeRecordForChangeCategory
"add a category change record to the changes file"
self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
!
addInfoRecord:aMessage
"add an info-record (snapshot, class fileOut etc.) to the changes file"
self writingChangePerform:#addInfoRecord:to: with:aMessage.
!
addChangeRecordForSnapshot:aFileName
"add a snapshot-record to the changes file"
self addInfoRecord:('snapshot ' , aFileName)
!
addChangeRecordForClassFileOut:aClass
"append a class-was-filedOut-record to the changes file"
self addInfoRecord:('fileOut ' , aClass name)
! !
!Class methodsFor:'compiling'!
compile:code
"compile code, aString for this class;
if sucessful update the method dictionary."
self compilerClass
compile:code
forClass:self
!
compile:code classified:category
"compile code, aString for this class;
if sucessful update the method dictionary.
The method is classified under category."
self compilerClass
compile:code
forClass:self
inCategory:category
!
compile:code notifying:requestor
"compile code, aString for this class; on any error, notify
requestor, anObject with the error reason."
self compilerClass
compile:code
forClass:self
notifying:requestor
!
recompileMethodsAccessingAny:setOfNames
"recompile all methods accessing a variable from setOfNames"
self recompileMethodsAccessingAny:setOfNames orSuper:false
!
recompileMethodsAccessingAny:setOfNames orSuper:superBoolean
"recompile all methods accessing a variable from setOfNames,
or super (if superBoolean is true)"
|p|
selectorArray do:[:aSelector |
|m|
m := self compiledMethodAt:aSelector.
p := Parser parseMethod:(m source) in:self.
(p isNil
or:[(p usedVars notNil and:[p usedVars includesAny:setOfNames])
or:[superBoolean and:[p usesSuper]]]) ifTrue:[
self recompile:aSelector
]
]
!
recompile:aSelector
"recompile the method associated with the argument, aSelector;
used when a superclass changes instances and we have to recompile
subclasses"
|cat code|
Class withoutUpdatingChangesDo:[
cat := (self compiledMethodAt:aSelector) category.
code := self sourceCodeAt:aSelector.
self compilerClass compile:code forClass:self inCategory:cat
]
!
recompile
"recompile all methods
used when a class changes instances and therefore all methods
have to be recompiled"
selectorArray do:[:aSelector |
self recompile:aSelector
]
!
recompileAll
"recompile this class and all subclasses"
|classes|
classes := self subclasses.
self recompile.
classes do:[:aClass |
aClass recompileAll
]
!
recompileInvalidatedMethods:trap
"recompile all invalidated methods"
|trapCode trapByteCode|
trapCode := trap code.
trapByteCode := trap byteCode.
selectorArray do:[:aSelector |
|m|
m := self compiledMethodAt:aSelector.
((m code == trapCode) and:[m byteCode == trapByteCode]) ifTrue:[
self recompile:aSelector
]
]
! !
!Class methodsFor:'queries'!
isClass
"return true, if the receiver is some kind of class
(a real class, not just behavior);
true is returned here - the method is redefined from Object.
See also Behavior>>isBehavior."
^ true
"
Point isClass
1 isClass
Behavior new isBehavior
Behavior new isClass
Class new isBehavior
Class new isClass
"
!
categories
"Return a Collection of all method-category strings known in class.
The returned collection is not sorted by any order."
|newList cat|
newList := OrderedCollection new.
methodArray do:[:aMethod |
cat := aMethod category.
newList indexOf:cat ifAbsent:[newList add:cat]
].
^ newList
"
Point categories
"
!
allCategories
"Return a Collection of all method-category strings known in class
and all superclasses. The returned collection is not sorted by any order."
|coll|
coll := OrderedCollection new.
self addAllCategoriesTo:coll.
^ coll
"
Point categories
Point allCategories
"
!
wasAutoloaded
"return true, if this class came into the system via an
autoload; false otherwise.
This is not an attribute of the class, but instead remembered in
Autoload. The interface here is for covenience."
^ Autoload wasAutoloaded:self
!
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'
"
!
whichClassDefinesClassVar:aVariableName
"return the class which defines the class 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 classVarNames includes:aVariableName) ifTrue:[ ^ cls].
cls := cls superclass
].
^ nil
"
StandardSystemView whichClassDefinesClassVar:'ErrorSignal'
StandardSystemView whichClassDefinesClassVar:'Foo'
"
! !
!Class methodsFor:'private'!
addAllClassVarNamesTo:aCollection
"helper - add the name-strings of the class variables and of the class-vars
of all superclasses to the argument, aCollection. Return aCollection"
(superclass notNil) ifTrue:[
superclass addAllClassVarNamesTo:aCollection
].
classvars notNil ifTrue:[
aCollection addAll:(classvars asCollectionOfWords).
].
^ aCollection
!
addCategoriesTo:aCollection
"helper - add categories to the argument, aCollection"
methodArray do:[:aMethod |
|cat|
cat := aMethod category.
(aCollection includes:cat) ifFalse:[
aCollection add:cat
]
]
!
addAllCategoriesTo:aCollection
"helper - add categories and all superclasses categories
to the argument, aCollection"
(superclass notNil) ifTrue:[
superclass addAllCategoriesTo:aCollection
].
self addCategoriesTo:aCollection
!
primitiveSpecs:index
"return a primitiveSpecification component as string or nil"
|pos stream string|
primitiveSpec isNil ifTrue:[^ nil].
pos := primitiveSpec at:index.
pos isNil ifTrue:[^ nil].
"the primitiveSpec is either a string, or an integer specifying the
position within the classes sourcefile ...
"
pos isNumber ifTrue:[
classFilename notNil ifTrue:[
stream := Smalltalk sourceFileStreamFor:classFilename.
stream notNil ifTrue:[
stream position:pos+1.
string := stream nextChunk.
stream close.
^ string
]
].
^ nil
].
^ pos
!
setPrimitiveSpecs:index to:aString
"set a primitiveSpecification component to aString"
primitiveSpec isNil ifTrue:[
primitiveSpec := Array new:3
].
primitiveSpec at:index put:aString
! !
!Class methodsFor:'fileIn interface'!
methodsFor:aCategory
"return a ClassCategoryReader to read in and compile methods for me.
This one actually creates the ClassReader when code is filed-in."
^ ClassCategoryReader class:self category:aCategory
!
publicMethodsFor:aCategory
"this method allows fileIn of ENVY methods
(although ST/X currently does NOT support method visibility).
Returns a ClassCategoryReader to read in and compile methods for me."
^ self methodsFor:aCategory
!
privateMethodsFor:aCategory
"this method allows fileIn of ENVY methods
(although ST/X currently does NOT really enforce method visibility yet).
Returns a ClassCategoryReader to read in and compile methods for me."
^ (self methodsFor:aCategory) privateProtocol
!
protectedMethodsFor:aCategory
"this method allows fileIn of ENVY methods
(although ST/X currently does NOT really enforce method visibility yet).
Returns a ClassCategoryReader to read in and compile methods for me."
^ (self methodsFor:aCategory) protectedProtocol
!
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
!
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."
^ ClassCategoryReader skippingChunks
!
methods
"this method allows fileIn of ST/V methods -
return a ClassCategoryReader to read in and compile methods for me."
^ ClassCategoryReader class:self category:'ST/V methods'
!
primitiveDefinitions
"this method allows fileIn of classes with primitive code
outside of methods - it returns a CCReader which skips the next chunks"
^ ClassCategoryReader class:self primitiveSpec:#primitiveDefinitions:
!
primitiveVariables
"this method allows fileIn of classes with primitive code
outside of methods - it returns a CCReader which skips the next chunks"
^ ClassCategoryReader class:self primitiveSpec:#primitiveVariables:
!
primitiveFunctions
"this method allows fileIn of classes with primitive code
outside of methods - it returns a CCReader which skips the next chunks"
^ ClassCategoryReader class:self primitiveSpec:#primitiveFunctions:
! !
!Class methodsFor:'c function interfacing'!
cInterfaceFunction:selector calling:cFunctionNameString args:argTypeArray returning:returnType
"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
"
! !
!Class methodsFor:'fileOut'!
fileOutCommentOn:aStream
"append an expression on aStream, which defines my comment"
|comment|
aStream nextPutAll:name.
aStream nextPutAll:' comment:'.
(comment := self comment) isNil ifTrue:[
aStream nextPutAll:''''''
] ifFalse:[
aStream nextPutAll:(comment storeString)
].
aStream cr
!
fileOutDefinitionOn:aStream
"append an expression on aStream, which defines myself."
^ self basicFileOutDefinitionOn:aStream
!
basicFileOutDefinitionOn:aStream
"append an expression on aStream, which defines myself."
|isVar line s|
"take care of nil-superclass"
superclass isNil ifTrue:[
"/ previous versions of stc were not able to compile nil-subclasses;
"/ after 2.10, it can ...
"/ line := 'Object "nil"'.
line := 'nil'
] ifFalse:[
line := (superclass name)
].
superclass isNil ifTrue:[
isVar := self isVariable
] ifFalse:[
"I cant remember what this is for ?"
isVar := (self isVariable and:[superclass isVariable not])
].
isVar ifTrue:[
self isBytes ifTrue:[
s := ' variableByteSubclass:#'
] ifFalse:[
self isWords ifTrue:[
s := ' variableWordSubclass:#'
] ifFalse:[
self isLongs ifTrue:[
s := ' variableLongSubclass:#'
] ifFalse:[
self isFloats ifTrue:[
s := ' variableFloatSubclass:#'
] ifFalse:[
self isDoubles ifTrue:[
s := ' variableDoubleSubclass:#'
] ifFalse:[
s := ' variableSubclass:#'
]
]
]
]
]
] ifFalse:[
s := ' subclass:#'
].
line := line , s , name.
aStream nextPutAll:line.
aStream crTab.
aStream nextPutAll:' instanceVariableNames:'''.
self printInstVarNamesOn:aStream indent:16.
aStream nextPutAll:''''.
aStream crTab.
aStream nextPutAll:' classVariableNames:'''.
self printClassVarNamesOn:aStream indent:16.
aStream nextPutAll:''''.
aStream crTab.
aStream nextPutAll:' poolDictionaries:'''''.
aStream crTab.
aStream nextPutAll:' category:'.
category isNil ifTrue:[
aStream nextPutAll:''''''
] ifFalse:[
aStream nextPutAll:(category asString storeString)
].
aStream cr
!
fileOutPrimitiveDefinitionsOn:aStream
"append primitive defs (if any) to aStream."
|s sep|
sep := aStream class chunkSeparator.
"
primitive definitions - if any
"
(s := self primitiveDefinitionsString) notNil ifTrue:[
aStream nextPut:sep;
nextPutAll:name;
nextPutAll:' primitiveDefinitions';
nextPut:sep;
cr.
aStream nextPutAll:s.
aStream nextPut:sep; space; nextPut:sep; cr; cr
].
(s := self primitiveVariablesString) notNil ifTrue:[
aStream nextPut:sep;
nextPutAll:name;
nextPutAll:' primitiveVariables';
nextPut:sep;
cr.
aStream nextPutAll:s.
aStream nextPut:sep; space; nextPut:sep; cr; cr
].
!
fileOutPrimitiveSpecsOn:aStream
"append primitive defs (if any) to aStream."
|s sep|
"
primitive definitions - if any
"
self fileOutPrimitiveDefinitionsOn:aStream.
"
primitive functions - if any
"
(s := self primitiveFunctionsString) notNil ifTrue:[
sep := aStream class chunkSeparator.
aStream nextPut:sep;
nextPutAll:name;
nextPutAll:' primitiveFunctions';
nextPut:sep;
cr.
aStream nextPutAll:s.
aStream nextPut:sep; space; nextPut:sep; cr; cr
].
!
fileOutClassInstVarDefinitionOn:aStream
"append an expression to define my classInstanceVariables on aStream"
aStream nextPutAll:(name , ' class instanceVariableNames:''').
self class printInstVarNamesOn:aStream indent:8.
aStream nextPutAll:''''.
"mhmh - good idea; saw this in SmallDraw sourcecode ..."
aStream cr; cr.
aStream nextPut:(Character doubleQuote); cr.
aStream space;
nextPutAll:'The following class instance variables are inherited by this class:';
cr; cr.
self allSuperclassesDo:[:aSuperClass |
aStream tab; nextPutAll:aSuperClass name;
nextPutAll:' - '.
aStream nextPutAll:(aSuperClass class instanceVariableString); cr.
].
aStream nextPut:(Character doubleQuote); cr.
!
fileOutCategory:aCategory on:aStream
"file out all methods belonging to aCategory, aString onto aStream"
|nMethods count sep source|
methodArray notNil ifTrue:[
nMethods := 0.
methodArray do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
nMethods := nMethods + 1
]
].
sep := aStream class chunkSeparator.
(nMethods ~~ 0) ifTrue:[
aStream nextPut:sep.
self printClassNameOn:aStream.
aStream nextPutAll:' methodsFor:'''.
aCategory notNil ifTrue:[
aStream nextPutAll:aCategory
].
aStream nextPut:$'. aStream nextPut:sep. aStream cr.
aStream cr.
count := 1.
methodArray do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
source := aMethod source.
source isNil ifTrue:[
FileOutErrorSignal raiseRequestWith:'no source for method'
] ifFalse:[
aStream nextChunkPut:(aMethod source).
].
(count ~~ nMethods) ifTrue:[
aStream cr.
aStream cr
].
count := count + 1
]
].
aStream space.
aStream nextPut:sep.
aStream cr
]
]
!
fileOutMethod:aMethod on:aStream
"file out the method, aMethod onto aStream"
|cat sep source|
methodArray notNil ifTrue:[
sep := aStream class chunkSeparator.
aStream nextPut:sep.
self printClassNameOn:aStream.
aStream nextPutAll:' methodsFor:'''.
cat := aMethod category.
cat notNil ifTrue:[
aStream nextPutAll:cat
].
aStream nextPut:$'.
aStream nextPut:sep.
aStream cr.
aStream cr.
source := aMethod source.
source isNil ifTrue:[
FileOutErrorSignal
raiseRequestWith:self
errorString:('no source for method: ' ,
self name , '>>' ,
(self selectorAtMethod:aMethod))
] ifFalse:[
aStream nextChunkPut:(aMethod source).
].
aStream space.
aStream nextPut:sep.
aStream cr
]
!
fileOutOn:aStream
"file out my definition and all methods onto aStream"
|collectionOfCategories copyrightText sep comment|
"
if there is a copyright method, add a copyright comment
at the beginning, taking the string from the copyright method.
We cannot do this unconditionally - that would lead to my copyrights
being put on your code ;-).
On the other hand: I want every file created by myself to have the
copyright string at the beginning be preserved .... even if the
code was edited in the browser and filedOut.
"
(self class selectorArray includes:#copyright) ifTrue:[
"
get the copyright methods source,
and insert at beginning.
"
copyrightText := (self class compiledMethodAt:#copyright) source.
copyrightText isNil ifTrue:[
"
no source available - trigger an error
"
self error:'no source for class ' , name , ' available. Cannot fileOut'.
^ self
].
copyrightText := copyrightText asCollectionOfLines.
copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
copyrightText do:[:line | aStream nextPutAll:line. aStream cr.].
].
sep := aStream class chunkSeparator.
"
first, a timestamp
"
aStream nextPutAll:(Smalltalk timeStamp).
aStream nextPut:sep.
aStream cr.
aStream cr.
"
then the definition
"
self fileOutDefinitionOn:aStream.
aStream nextPut:sep.
aStream cr.
aStream cr.
"
optional classInstanceVariables
"
self class instanceVariableString isBlank ifFalse:[
self fileOutClassInstVarDefinitionOn:aStream.
aStream nextPut:sep.
aStream cr.
aStream cr
].
"
a comment - if any
"
(comment := self comment) notNil ifTrue:[
aStream nextPutAll:name.
aStream nextPutAll:' comment:'.
aStream nextPutAll:(comment storeString).
aStream nextPut:sep.
aStream cr.
aStream cr
].
"
primitive definitions - if any
"
self fileOutPrimitiveSpecsOn:aStream.
"
methods from all categories in metaclass
"
collectionOfCategories := self class categories.
collectionOfCategories notNil ifTrue:[
"
documentation first (if any)
"
(collectionOfCategories includes:'documentation') ifTrue:[
self class fileOutCategory:'documentation' on:aStream.
aStream cr.
].
"
initialization next (if any)
"
(collectionOfCategories includes:'initialization') ifTrue:[
self class fileOutCategory:'initialization' on:aStream.
aStream cr.
].
"
instance creation next (if any)
"
(collectionOfCategories includes:'instance creation') ifTrue:[
self class fileOutCategory:'instance creation' on:aStream.
aStream cr.
].
collectionOfCategories do:[:aCategory |
((aCategory ~= 'documentation')
and:[(aCategory ~= 'initialization')
and:[aCategory ~= 'instance creation']]) ifTrue:[
self class fileOutCategory:aCategory on:aStream.
aStream cr
]
]
].
"
methods from all categories in myself
"
collectionOfCategories := self categories.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutCategory:aCategory on:aStream.
aStream cr
]
].
"
optionally an initialize message
"
(self class implements:#initialize) ifTrue:[
aStream nextPutAll:(name , ' initialize').
aStream nextPut:sep.
aStream cr
]
!
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 := 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
!
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 := 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
]
!
fileOut
"create a file 'class.st' consisting of all methods in myself.
If the current project is not nil, create the file in the projects
directory. Care is taken, to not clobber any existing file in
case of errors (for example: disk full). Also, since the classes
methods need a valid sourcefile, the current sourceFile cannot be rewritten,
but must be kept around until the fileOut is finished."
|aStream baseName dirName fileName newFileName needRename|
baseName := (Smalltalk fileNameForClass:self name).
fileName := baseName , '.st'.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
dirName := Project currentProjectDirectory
] ifFalse:[
dirName := ''
].
fileName := dirName , fileName.
"
if file exists, copy the existing to a .sav-file,
create the new file as XXX.new-file,
and, if that worked rename afterwards ...
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:('/tmp/' , baseName , '.sav').
newFileName := dirName , baseName , '.new'.
needRename := true
] ifFalse:[
newFileName := fileName.
needRename := false
].
aStream := FileStream newFileNamed:newFileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal raiseRequestWith:newFileName
errorString:('cannot create file:', newFileName)
].
self fileOutOn:aStream.
aStream close.
"
finally, replace the old-file
be careful, if the old one is a symbolic link; in this case,
we have to do a copy ...
"
needRename ifTrue:[
newFileName asFilename copyTo:fileName.
newFileName asFilename delete
].
"
add a change record; that way, administration is much easier,
since we can see in that changeBrowser, which changes have
already found their way into a sourceFile and which must be
applied again
"
self addChangeRecordForClassFileOut:self
!
fileOutIn:aFileDirectory
"create a file 'class.st' consisting of all methods in self in
directory aFileDirectory (ignoring any directory setting in
the current porject).
This is not logged in that change file (should it be ?)."
|aStream fileName|
fileName := (Smalltalk fileNameForClass:self name) , '.st'.
aStream := FileStream newFileNamed:fileName in:aFileDirectory.
aStream isNil ifTrue:[
^ self error:('cannot create source file:', fileName)
].
self fileOutOn:aStream.
aStream close
! !
!Class methodsFor:'printOut'!
printClassNameOn:aStream
"helper for fileOut - print my name if I am not a Metaclass;
otherwise my name without -class followed by space-class"
self isMeta ifTrue:[
aStream nextPutAll:(name copyTo:(name size - 5)).
aStream nextPutAll:' class'
] ifFalse:[
name printOn:aStream
]
!
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 nextPutAll:line.
aStream cr.
spaces isNil ifTrue:[
spaces := String new:indent
].
line := spaces.
pos := indent
] ifFalse:[
line := line , ' '.
pos := pos + 1
].
thisName := nextName
]
].
aStream nextPutAll:line
]
!
printClassVarNamesOn:aStream indent:indent
"print the class variable names indented and breaking at line end"
self printNameArray:(self classVarNames) on:aStream indent:indent
!
printInstVarNamesOn:aStream indent:indent
"print the instance variable names indented and breaking at line end"
self printNameArray:(self instVarNames) on:aStream indent:indent
!
printHierarchyOn:aStream
"print my class hierarchy on aStream"
self printHierarchyAnswerIndentOn:aStream
!
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|
indent := 0.
(superclass notNil) ifTrue:[
indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
].
aStream spaces:indent.
aStream nextPutAll:name.
aStream nextPutAll:' ('.
self printInstVarNamesOn:aStream indent:(indent + name size + 2).
aStream nextPutAll:')'.
aStream cr.
^ indent
!
printFullHierarchyOn:aStream indent:indent
"print myself and all subclasses on aStream.
recursively calls itself to print subclasses.
Can be used to print hierarchy on the printer."
aStream spaces:indent.
aStream bold.
aStream nextPutAll:name.
aStream normal.
aStream nextPutAll:' ('.
self printInstVarNamesOn:aStream indent:(indent + name size + 2).
aStream nextPutAll:')'.
aStream cr.
(self subclasses sort:[:a :b | a name < b name]) do:[:aSubclass |
aSubclass printFullHierarchyOn:aStream indent:(indent + 2)
]
"|printStream|
printStream := Printer new.
Object printFullHierarchyOn:printStream indent:0.
printStream close"
!
printOutDefinitionOn:aPrintStream
"print out my definition"
|comment|
aPrintStream nextPutAll:'class '.
aPrintStream bold.
aPrintStream nextPutAll:name.
aPrintStream normal.
aPrintStream cr.
aPrintStream nextPutAll:'superclass '.
superclass isNil ifTrue:[
aPrintStream nextPutAll:'Object'
] ifFalse:[
aPrintStream nextPutAll:(superclass name)
].
aPrintStream cr.
aPrintStream nextPutAll:'instance Variables '.
self printInstVarNamesOn:aPrintStream indent:21.
aPrintStream cr.
aPrintStream nextPutAll:'class Variables '.
self printClassVarNamesOn:aPrintStream indent:21.
aPrintStream cr.
category notNil ifTrue:[
aPrintStream nextPutAll:'category '.
aPrintStream nextPutAll:(category printString).
aPrintStream cr
].
(comment := self comment) notNil ifTrue:[
aPrintStream cr.
aPrintStream nextPutAll:'comment:'.
aPrintStream cr.
aPrintStream italic.
aPrintStream nextPutAll:comment.
aPrintStream normal.
aPrintStream cr
]
!
printOutSourceProtocol:aMethod on:aPrintStream
"given the source in aString, print the methods message specification
and any method comments - without source; used to generate documentation
pages"
|text|
text := aMethod source asStringCollection.
(text size < 1) ifTrue:[^self].
aPrintStream bold.
aPrintStream nextPutAll:(text at:1).
aPrintStream cr.
(text size >= 2) ifTrue:[
aPrintStream italic.
aPrintStream spaces:((text at:2) indexOfNonSeparatorStartingAt:1).
aPrintStream nextPutAll:aMethod comment.
aPrintStream cr.
].
aPrintStream normal
"
Float printOutProtocolOn:Stdout
"
!
printOutSource:aString on:aPrintStream
"print out a source-string; the message-specification is printed bold,
comments are printed italic"
|text textIndex textSize line lineIndex lineSize inComment aCharacter|
text := aString asStringCollection.
aPrintStream bold.
aPrintStream nextPutAll:(text at:1).
aPrintStream normal.
aPrintStream cr.
inComment := false.
textSize := text size.
textIndex := 2.
[textIndex <= textSize] whileTrue:[
line := text at:textIndex.
((line occurrencesOf:Character doubleQuote) == 0) ifTrue:[
aPrintStream nextPutAll:line
] ifFalse:[
lineSize := line size.
lineIndex := 1.
[lineIndex <= lineSize] whileTrue:[
aCharacter := line at:lineIndex.
(aCharacter == Character doubleQuote) ifTrue:[
inComment ifTrue:[
aPrintStream normal.
aPrintStream nextPut:aCharacter.
inComment := false
] ifFalse:[
aPrintStream nextPut:aCharacter.
aPrintStream italic.
inComment := true
]
] ifFalse:[
aPrintStream nextPut:aCharacter
].
lineIndex := lineIndex + 1
]
].
aPrintStream cr.
textIndex := textIndex + 1
]
!
printOutCategory:aCategory on:aPrintStream
"print out all methods in aCategory on aPrintStream should be a PrintStream"
|any|
methodArray notNil ifTrue:[
any := false.
methodArray do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
any := true
]
].
any ifTrue:[
aPrintStream italic.
aPrintStream nextPutAll:aCategory.
aPrintStream normal.
aPrintStream cr.
aPrintStream cr.
methodArray do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
self printOutSource:(aMethod source) on:aPrintStream.
aPrintStream cr.
aPrintStream cr
]
].
aPrintStream cr
]
]
!
printOutOn:aPrintStream
"print out all methods on aPrintStream which should be a printStream"
|collectionOfCategories|
self printOutDefinitionOn:aPrintStream.
aPrintStream cr.
collectionOfCategories := self class categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'class protocol'.
aPrintStream cr. aPrintStream cr.
collectionOfCategories do:[:aCategory |
self class printOutCategory:aCategory on:aPrintStream
]
].
collectionOfCategories := self categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'instance protocol'.
aPrintStream cr. aPrintStream cr.
collectionOfCategories do:[:aCategory |
self printOutCategory:aCategory on:aPrintStream
]
]
!
printOutCategoryProtocol:aCategory on:aPrintStream
|any|
methodArray notNil ifTrue:[
any := false.
methodArray do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
any := true
]
].
any ifTrue:[
aPrintStream italic.
aPrintStream nextPutAll:aCategory.
aPrintStream normal.
aPrintStream cr.
aPrintStream cr.
methodArray do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
self printOutSourceProtocol:aMethod
on:aPrintStream.
aPrintStream cr.
aPrintStream cr
]
].
aPrintStream cr
]
]
!
printOutProtocolOn:aPrintStream
|collectionOfCategories|
self printOutDefinitionOn:aPrintStream.
aPrintStream cr.
collectionOfCategories := self class categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'class protocol'.
aPrintStream cr. aPrintStream cr.
collectionOfCategories do:[:aCategory |
self class printOutCategoryProtocol:aCategory on:aPrintStream
]
].
collectionOfCategories := self categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'instance protocol'.
aPrintStream cr. aPrintStream cr.
collectionOfCategories do:[:aCategory |
self printOutCategoryProtocol:aCategory on:aPrintStream
]
]
! !
!Class methodsFor: 'binary storage'!
addGlobalsTo: globalDictionary manager: manager
"
classPool == nil ifFalse: [
classPool associationsDo: [:assoc|
globalDictionary at: assoc put: self
]
]
"
!
storeBinaryDefinitionOn: stream manager: manager
"classes will store the name, signature and instvar names.
They restore by looking for that name in the Smalltalk dictionary.
However, using the signature, a check for being valid is made at
restore time."
|varnames n sz|
"
output the signature
"
stream nextNumber:4 put:self signature.
"
output the intstance variable name string
"
varnames := self allInstVarNames.
n := varnames size.
n == 0 ifTrue:[
sz := 0
] ifFalse:[
sz := varnames inject:0 into:[:sum :nm | sum + nm size].
sz := sz + n - 1.
].
stream nextNumber:2 put:sz.
varnames keysAndValuesDo:[:i :nm |
nm do:[:c |
stream nextPut:c asciiValue
].
i ~~ n ifTrue:[stream nextPut:(Character space asciiValue)]
].
"
output my name
"
stream nextNumber:2 put:name size.
name do:[:c|
stream nextPut:c asciiValue
]
"
|s|
s := WriteStream on:ByteArray new.
Rectangle storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents)
"
!
storeBinaryDefinitionOf: anAssociation on: stream manager: manager
"not usable at the moment - there are no classpools currently"
| string |
string := self name, ' classPool at: ', anAssociation key storeString.
stream nextNumber: 2 put: string size.
string do: [:char| stream nextPut: char asciiValue]
! !