--- a/Class.st Wed Nov 15 13:07:17 1995 +0100
+++ b/Class.st Wed Nov 15 13:10:59 1995 +0100
@@ -1,3 +1,5 @@
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
@@ -20,7 +22,9 @@
!Class class methodsFor:'documentation'!
-aus Gittinger
+copyright
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
@@ -32,7 +36,10 @@
"
!
-ion; this adds naming, categories etc.
+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).
@@ -99,11 +106,12 @@
!
version
-^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.72 1995-11-15 12:07:17 cg Exp $'! !
+^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.73 1995-11-15 12:10:59 cg Exp $'! !
!Class class methodsFor:'initialization'!
-gChanges' controls if changes are put
+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."
@@ -130,7 +138,16 @@
!Class class methodsFor:'Signal constants'!
-he signal raised when a method is about to be installed
+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
+!
+
+methodRedefinitionSignal
+ "return the signal raised when a method is about to be installed
which redefines an existing method and the methods packages are not
equal. This helps when filing in alien code, to prevent existing
methods to be overwritten or redefined by incompatible methods"
@@ -138,46 +155,50 @@
^ MethodRedefinitionSignal
!
-ncompatible methods"
-
- ^ MethodRedefinitionSignal
-!
-
-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
+updateChangeFileQuerySignal
+ "return the signal used as an upQuery if the changeFile should be updated.
+ If unhandled, the value of UpdatingChanges is returned by the signals
+ static handler."
+
+ ^ UpdateChangeFileQuerySignal
+
! !
!Class class methodsFor:'accessing - flags'!
-return true if changes are recorded"
-
- ^ UpdatingChanges
-!
-
-ile
+catchMethodRedefinitions
+ "return the redefinition catching flag."
+
+ ^ CatchMethodRedefinitions
!
-prev|
-
- prev := UpdatingChanges.
- UpdatingChanges := aBoolean.
- ^ prev
-!
-
-prev := CatchMethodRedefinitions.
+catchMethodRedefinitions:aBoolean
+ "turn on/off redefinition catching. Return the prior value of the flag."
+
+ |prev|
+
+ prev := CatchMethodRedefinitions.
CatchMethodRedefinitions := aBoolean.
^ prev
!
-edefinition catching flag."
-
- ^ CatchMethodRedefinitions
+lockChangesFile
+ "return true, if the change file is locked during update"
+
+ ^ LockChangesFile
!
-ean
+lockChangesFile:aBoolean
+ "turn on/off change-file-locking. Return the previous value of the flag."
+
+ |prev|
+
+ prev := LockChangesFile.
+ LockChangesFile := aBoolean.
+ ^ prev
+!
+
+updateChanges:aBoolean
"turn on/off changes management. Return the prior value of the flag."
|prev|
@@ -185,11 +206,18 @@
prev := UpdatingChanges.
UpdatingChanges := aBoolean.
^ prev
+!
+
+updatingChanges
+ "return true if changes are recorded"
+
+ ^ UpdatingChanges
! !
!Class class methodsFor:'enumeration '!
-"evaluate aBlock for all classes in aCategory;
+allClassesInCategory:aCategory do:aBlock
+ "evaluate aBlock for all classes in aCategory;
no specific order is defined."
Smalltalk allBehaviorsDo:[:aClass |
@@ -206,7 +234,7 @@
"
!
-Block
+allClassesInCategory:aCategory inOrderDo:aBlock
"evaluate aBlock for all classes in aCategory;
superclasses come first - then subclasses."
@@ -226,7 +254,7 @@
!Class methodsFor:'ST/V subclass creation'!
-riableNames:d poolDictionaries:s
+subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V classes
(which seem to have no category)"
@@ -237,7 +265,7 @@
category:'ST/V classes'
!
-d poolDictionaries:s
+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)"
@@ -248,7 +276,7 @@
category:'ST/V classes'
!
-classVariableNames:d poolDictionaries:s
+variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V variable pointer classes
(which seem to have no category)"
@@ -261,22 +289,8 @@
!Class methodsFor:'accessing'!
-h:(#directory->directoryString)
- with:(#library->libraryString)
-
- "
- Object sourceCodeInfo
- View sourceCodeInfo
- Model sourceCodeInfo
- BinaryObjectStorage sourceCodeInfo
- MemoryMonitor sourceCodeInfo
- ClockView sourceCodeInfo
- "
-
- "Created: 4.11.1995 / 20:36:53 / cg"
-!
-
-ariable if not already there and initialize it with nil.
+addClassVarName:aString
+ "add a class variable if not already there and initialize it with nil.
Also writes a change record and notifies dependents.
BUG: Currently, no recompilation is done - this will change."
@@ -290,134 +304,108 @@
"Created: 29.10.1995 / 19:40:51 / cg"
!
-ines the name of the class library.
- If left blank, the module info defaults to 'stx',
- the directory info defaults to library name.
- The library name may not be left blank.
- (this is done for backward compatibility,)
-
- For example:
- '....(libbasic)' -> module: stx directory: libbasic library: libbasic
- '....(stx:libbasic)' -> module: stx directory: libbasic library: libbasic
- '....(aeg:libIECInterface)' -> module: aeg directory: libIECInterface library:libIECInterface
- '....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase
-
- The way how the sourceCodeManager uses this to find the source location
- depends on the scheme used. For CVS, the module is taken as the -d arg,
- while the directory is prepended to the file name.
- Other schemes may do things differently - these are not yet specified.
-
- Caveat:
- Encoding this info in the package string seems somewhat kludgy.
+allClassVarNames
+ "return a collection of all the class variable name-strings
+ this includes all superclass-class variables"
+
+ ^ self addAllClassVarNamesTo:(OrderedCollection new)
+
+ "
+ Float allClassVarNames
+ "
+!
+
+classFilename
+ "return the name of the file from which the class was compiled.
+ This is currently NOT used."
+
+ ^ classFilename
+!
+
+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.
"
-
- |sourceInfo packageString idx1 idx2
- moduleString directoryString libraryString components|
-
- package isNil ifTrue:[^ nil].
-
- packageString := package asString.
- idx1 := packageString lastIndexOf:$(.
- idx1 ~~ 0 ifTrue:[
- idx2 := packageString indexOf:$) startingAt:idx1+1.
- idx2 ~~ 0 ifTrue:[
- sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
+ Smalltalk at:(self name , ':' , aSymbol) asSymbol put:something.
+!
+
+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
+ "
+!
+
+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
+ "
+!
+
+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
]
].
- sourceInfo isNil ifTrue:[^ nil].
- components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
- components size == 0 ifTrue:[
- moduleString := 'stx'.
- directoryString := libraryString := ''.
- ^ nil
- ] ifFalse:[
- components size == 1 ifTrue:[
- "/ a single name given - the module becomes 'stx',
- "/ if the component includes slashes, its the directory
- "/ otherwise the library
- "/
- moduleString := 'stx'.
- directoryString := libraryString := components at:1.
- (libraryString includes:$/) ifTrue:[
- libraryString := libraryString asFilename baseName
- ]
- ] ifFalse:[
- components size == 2 ifTrue:[
- "/ two components - assume its the directory and the library
- moduleString := 'stx'.
- directoryString := components at:1.
- libraryString := components at:2.
- ] ifFalse:[
- "/ all components given
- moduleString := components at:1.
- directoryString := components at:2.
- libraryString := components at:3.
- ]
- ]
- ].
- libraryString isEmpty ifTrue:[
- directoryString notEmpty ifTrue:[
- libraryString := directoryString asFilename baseName
- ].
- libraryString isEmpty ifTrue:[
- "/ lets extract the library from the liblist file ...
- libraryString := Smalltalk libraryFileNameOfClass:self.
- libraryString isNil ifTrue:[^ nil].
- ]
- ].
-
- moduleString isEmpty ifTrue:[
- moduleString := 'stx'.
- ].
- directoryString isEmpty ifTrue:[
- directoryString := libraryString.
- ].
-
- ^ IdentityDictionary
- with:(#module->moduleString)
- with:(#directory->directoryString)
- with:(#library->libraryString)
-
- "
- Object sourceCodeInfo
- View sourceCodeInfo
- Model sourceCodeInfo
- BinaryObjectStorage sourceCodeInfo
- MemoryMonitor sourceCodeInfo
- ClockView sourceCodeInfo
- "
-
- "Created: 4.11.1995 / 20:36:53 / cg"
-!
-
-ct comment
- "
-!
-
-n an expression-string to define myself"
-
- |s|
-
- s := WriteStream on:(String new).
- self fileOutDefinitionOn:s.
- ^ s contents
-
- "
- Object definition
- Point definition
- "
-!
-
-self classVariableString:(self classVariableString , ' ' , aString).
- self addChangeRecordForClass:self.
- self updateRevisionString.
- self changed:#definition.
- ]
-
- "Created: 29.10.1995 / 19:40:51 / cg"
-!
-
-arAt:aName put:nil.
+ (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
@@ -434,19 +422,98 @@
]
!
-ection new)
+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 := self sourceStream. "/ Smalltalk sourceFileStreamFor:classFilename.
+ stream notNil ifTrue:[
+ stream position:comment.
+ string := String readFrom:stream onError:''.
+ stream close.
+ ^ string
+ ]
+ ]
+ ].
+ ^ comment
"
- Float allClassVarNames
+ Object comment
"
!
-th:self
- ].
+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 updateRevisionString.
+ self addChangeRecordForClassComment:self.
]
+
+ "Created: 29.10.1995 / 19:41:24 / cg"
!
-iveDefinition string"
+definition
+ "return an expression-string to define myself"
+
+ |s|
+
+ s := WriteStream on:(String new).
+ self fileOutDefinitionOn:s.
+ ^ s contents
+
+ "
+ Object definition
+ Point definition
+ "
+!
+
+history
+ "return the history of the class"
+
+ ^ history
+
+ "
+ Object history
+ "
+!
+
+history:aString
+ "set the history of the class."
+
+ history := aString
+!
+
+package
+ "return the package of the class"
+
+ ^ package
+
+ "
+ Object package
+ "
+!
+
+package:aStringOrSymbol
+ "set the package of the class."
+
+ package := aStringOrSymbol
+!
+
+primitiveDefinitions:aString
+ "set the primitiveDefinition string"
self setPrimitiveSpecsAt:1 to:aString.
self addChangeRecordForPrimitiveDefinitions:self.
@@ -455,241 +522,227 @@
"Created: 29.10.1995 / 19:41:39 / cg"
!
-bbasic
- '....(aeg:libIECInterface)' -> module: aeg directory: libIECInterface library:libIECInterface
- '....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase
-
- The way how the sourceCodeManager uses this to find the source location
- depends on the scheme used. For CVS, the module is taken as the -d arg,
- while the directory is prepended to the file name.
- Other schemes may do things differently - these are not yet specified.
-
- Caveat:
- Encoding this info in the package string seems somewhat kludgy.
- "
-
- |sourceInfo packageString idx1 idx2
- moduleString directoryString libraryString components|
-
- package isNil ifTrue:[^ nil].
-
- packageString := package asString.
- idx1 := packageString lastIndexOf:$(.
- idx1 ~~ 0 ifTrue:[
- idx2 := packageString indexOf:$) startingAt:idx1+1.
- idx2 ~~ 0 ifTrue:[
- sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
- ]
- ].
- sourceInfo isNil ifTrue:[^ nil].
- components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
- components size == 0 ifTrue:[
- moduleString := 'stx'.
- directoryString := libraryString := ''.
- ^ nil
- ] ifFalse:[
- components size == 1 ifTrue:[
- "/ a single name given - the module becomes 'stx',
- "/ if the component includes slashes, its the directory
- "/ otherwise the library
- "/
- moduleString := 'stx'.
- directoryString := libraryString := components at:1.
- (libraryString includes:$/) ifTrue:[
- libraryString := libraryString asFilename baseName
- ]
- ] ifFalse:[
- components size == 2 ifTrue:[
- "/ two components - assume its the directory and the library
- moduleString := 'stx'.
- directoryString := components at:1.
- libraryString := components at:2.
- ] ifFalse:[
- "/ all components given
- moduleString := components at:1.
- directoryString := components at:2.
- libraryString := components at:3.
- ]
- ]
- ].
- libraryString isEmpty ifTrue:[
- directoryString notEmpty ifTrue:[
- libraryString := directoryString asFilename baseName
- ].
- libraryString isEmpty ifTrue:[
- "/ lets extract the library from the liblist file ...
- libraryString := Smalltalk libraryFileNameOfClass:self.
- libraryString isNil ifTrue:[^ nil].
- ]
- ].
-
- moduleString isEmpty ifTrue:[
- moduleString := 'stx'.
- ].
- directoryString isEmpty ifTrue:[
- directoryString := libraryString.
- ].
-
- ^ IdentityDictionary
- with:(#module->moduleString)
- with:(#directory->directoryString)
- with:(#library->libraryString)
+primitiveDefinitionsString
+ "return the primitiveDefinition string or nil"
+
+ ^ self getPrimitiveSpecsAt:1
"
- Object sourceCodeInfo
- View sourceCodeInfo
- Model sourceCodeInfo
- BinaryObjectStorage sourceCodeInfo
- MemoryMonitor sourceCodeInfo
- ClockView sourceCodeInfo
+ Object primitiveDefinitionsString
+ String primitiveDefinitionsString
"
-
- "Created: 4.11.1995 / 20:36:53 / cg"
-!
-
-."
-
- history := aString
!
-'.
- ] do:[
- 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
-!
-
-"
-!
-
-ecsAt:3 to:aString.
+primitiveFunctions:aString
+ "set the primitiveFunction string"
+
+ self setPrimitiveSpecsAt:3 to:aString.
self addChangeRecordForPrimitiveFunctions:self.
self updateRevisionString.
"Created: 29.10.1995 / 19:41:48 / cg"
!
-le:'__temp'.
- ^ code
+primitiveFunctionsString
+ "return the primitiveFunctions string or nil"
+
+ ^ self getPrimitiveSpecsAt:3
+!
+
+primitiveSpec
+ "return the primitiveSpec or nil"
+
+ ^ primitiveSpec
!
-^ #()
+primitiveSpec:anArrayOf3ElementsOrNil
+ "set the primitiveSpec or nil"
+
+ primitiveSpec := anArrayOf3ElementsOrNil
+!
+
+primitiveVariables:aString
+ "set the primitiveVariable string"
+
+ self setPrimitiveSpecsAt:2 to:aString.
+ self addChangeRecordForPrimitiveVariables:self.
+ self updateRevisionString.
+
+ "Created: 29.10.1995 / 19:41:58 / cg"
+!
+
+primitiveVariablesString
+ "return the primitiveVariables string or nil"
+
+ ^ self getPrimitiveSpecsAt:2
!
-renthesis.
- The info consists of 1 to 3 subcomponents, separated by colons.
- The first defines the classes module (i.e. some application identifier),
- the second defines the subdirectory within that module, the third
- defines the name of the class library.
- If left blank, the module info defaults to 'stx',
- the directory info defaults to library name.
- The library name may not be left blank.
- (this is done for backward compatibility,)
-
- For example:
- '....(libbasic)' -> module: stx directory: libbasic library: libbasic
- '....(stx:libbasic)' -> module: stx directory: libbasic library: libbasic
- '....(aeg:libIECInterface)' -> module: aeg directory: libIECInterface library:libIECInterface
- '....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase
-
- The way how the sourceCodeManager uses this to find the source location
- depends on the scheme used. For CVS, the module is taken as the -d arg,
- while the directory is prepended to the file name.
- Other schemes may do things differently - these are not yet specified.
-
- Caveat:
- Encoding this info in the package string seems somewhat kludgy.
- "
-
- |sourceInfo packageString idx1 idx2
- moduleString directoryString libraryString components|
-
- package isNil ifTrue:[^ nil].
-
- packageString := package asString.
- idx1 := packageString lastIndexOf:$(.
- idx1 ~~ 0 ifTrue:[
- idx2 := packageString indexOf:$) startingAt:idx1+1.
- idx2 ~~ 0 ifTrue:[
- sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
+removeClassVarName:aString
+ "remove a class variable if not already there.
+ Also writes a change record and notifies 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 updateRevisionString.
+ self changed:#definition.
+ ]
+
+ "Created: 29.10.1995 / 19:42:08 / cg"
+!
+
+renameCategory:oldCategory to:newCategory
+ "rename a category (changes category of those methods).
+ Appends a change record and notifies dependents."
+
+ |any|
+
+ any := false.
+ methodArray do:[:aMethod |
+ aMethod category = oldCategory ifTrue:[
+ aMethod category:newCategory.
+ any := true.
]
].
- sourceInfo isNil ifTrue:[^ nil].
- components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
- components size == 0 ifTrue:[
- moduleString := 'stx'.
- directoryString := libraryString := ''.
- ^ nil
- ] ifFalse:[
- components size == 1 ifTrue:[
- "/ a single name given - the module becomes 'stx',
- "/ if the component includes slashes, its the directory
- "/ otherwise the library
- "/
- moduleString := 'stx'.
- directoryString := libraryString := components at:1.
- (libraryString includes:$/) ifTrue:[
- libraryString := libraryString asFilename baseName
- ]
- ] ifFalse:[
- components size == 2 ifTrue:[
- "/ two components - assume its the directory and the library
- moduleString := 'stx'.
- directoryString := components at:1.
- libraryString := components at:2.
- ] ifFalse:[
- "/ all components given
- moduleString := components at:1.
- directoryString := components at:2.
- libraryString := components at:3.
- ]
- ]
+ any ifTrue:[
+ self addChangeRecordForRenameCategory:oldCategory to:newCategory.
+ self updateRevisionString.
+ self changed:#methodCategory.
+ ]
+
+ "Created: 29.10.1995 / 19:42:15 / cg"
+!
+
+revision
+ "return the revision-ID of the class which corresponds to the
+ rcs-id of the source from which this class was compiled.
+ This is always valid for stc-compiled classes which include a version method,
+ since stc extracts this info and places it into an instance variable.
+ Alternatively, the code below tries to extract it from the revisionString directly,
+ this is used with filed-In classes (non stc-compiled).
+ To check if a source corresponds to a compiled binary, compare this
+ ID with the one found in the version-methods comment."
+
+ |vsnString words|
+
+ revision notNil ifTrue:[ ^ revision].
+ vsnString := self revisionString.
+ vsnString notNil ifTrue:[
+ words := vsnString asCollectionOfWords.
+ "/
+ "/ supported formats:
+ "/
+ "/ $-Header: pathName rev date time user state $
+ "/ $-Revision: rev $
+ "/ $-Id: fileName rev date time user state $
+ "/
+ ((words at:1) = '$Header:') ifTrue:[
+ ^ words at:3
+ ].
+ ((words at:1) = '$Revision:') ifTrue:[
+ ^ words at:2
+ ].
+ ((words at:1) = '$Id:') ifTrue:[
+ ^ words at:3
+ ].
].
- libraryString isEmpty ifTrue:[
- directoryString notEmpty ifTrue:[
- libraryString := directoryString asFilename baseName
- ].
- libraryString isEmpty ifTrue:[
- "/ lets extract the library from the liblist file ...
- libraryString := Smalltalk libraryFileNameOfClass:self.
- libraryString isNil ifTrue:[^ nil].
- ]
- ].
-
- moduleString isEmpty ifTrue:[
- moduleString := 'stx'.
- ].
- directoryString isEmpty ifTrue:[
- directoryString := libraryString.
- ].
-
- ^ IdentityDictionary
- with:(#module->moduleString)
- with:(#directory->directoryString)
- with:(#library->libraryString)
+ ^ nil
"
- Object sourceCodeInfo
- View sourceCodeInfo
- Model sourceCodeInfo
- BinaryObjectStorage sourceCodeInfo
- MemoryMonitor sourceCodeInfo
- ClockView sourceCodeInfo
+ Object revision
"
- "Created: 4.11.1995 / 20:36:53 / cg"
+ "Created: 11.11.1995 / 14:27:20 / cg"
+!
+
+revision:aString
+ "set the revision-ID.
+ This should normally not be done in the running system, as the source-manager
+ will need this to validate sourcefiles being correct for a given binary
+ (and optionally: extracting the required sourcefile from the rcs source)"
+
+ revision := aString
+!
+
+setClassFilename:aFilename
+ "set the classes filename.
+ This is a dangerous (low level) operation, since the
+ comment and primitiveSpecs may no longer be accessable, if a wrong filename
+ is set here."
+
+ classFilename := aFilename
+
+ "Modified: 8.9.1995 / 14:16:48 / claus"
+!
+
+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
+!
+
+setComment:aString
+ "set the comment of the class to be the argument, aString;
+ do NOT create a change record"
+
+ comment := aString
!
-e temporary file.'.
+setComment:com category:categoryStringOrSymbol
+ "set the comment and category of the class;
+ do NOT create a change record"
+
+ |cat|
+
+ comment := com.
+ categoryStringOrSymbol isNil ifTrue:[
+ cat := ''
+ ] ifFalse:[
+ cat := categoryStringOrSymbol
+ ].
+ category := cat asSymbol
+!
+
+setHistory:aString
+ "set the history of the class."
+
+ history := aString
+!
+
+setPackage:aStringOrSymbol
+ "set the package of the class."
+
+ package := aStringOrSymbol
+!
+
+sharedPools
+ "ST/X does not (currently) support pools"
+
+ ^ #()
+!
+
+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
].
FileOutErrorSignal handle:[:ex |
@@ -709,27 +762,11 @@
^ code
!
-FileStream oldFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'oops - cannot reopen temp file'.
- ^ nil
- ].
- code := aStream contents.
- aStream close.
- OperatingSystem removeFile:'__temp'.
- ^ code
-!
-
-ps - cannot reopen temp file'.
- ^ nil
- ].
- code := aStream contents.
- aStream close.
- OperatingSystem removeFile:'__temp'.
- ^ code
-!
-
-es at: #module, #directory and #library.
+sourceCodeInfo
+ "return the sourceCodeInfo, which defines the module and the subdirectory
+ in which the receiver class was built.
+ The info returned consists of a dictionary
+ filled with (at least) values at: #module, #directory and #library.
If no such info is present in the class, nil is returned.
By convention, this info is encoded in the classes package
@@ -837,307 +874,13 @@
"Created: 4.11.1995 / 20:36:53 / cg"
!
-:aStream
-"
- aStream := FileStream newFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'cannot create temporary file.'.
- ^ nil
- ].
- FileOutErrorSignal handle:[:ex |
- aStream nextPutAll:'"no source available"'.
- ] do:[
- 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
-!
-
-aStream isNil ifTrue:[
- "/
- "/ hard case - there is no source file for this class
- "/ (neither in the source-dir-path, nor in the current directory).
- "/
-
- "/
- "/ look if my binary is from a dynamically loaded module,
- "/ and, if so, look in the modules directory for the
- "/ source file.
- "/
- ObjectFileLoader notNil ifTrue:[
- ObjectFileLoader loadedObjectHandlesDo:[:h |
- |f|
-
- aStream isNil ifTrue:[
- (h classes includes:self) ifTrue:[
- f := h pathName.
- f := f asFilename directory.
- f := f construct:source.
- f exists ifTrue:[
- aStream := f readStream.
- ].
- ].
- ]
- ].
- ].
- ].
-
- aStream isNil ifTrue:[
-
- "/ mhmh - still no source file.
- "/ If there is a SourceCodeManager, ask it to aquire the
- "/ the source for my class, and return an open stream on it.
-
- SourceCodeManager notNil ifTrue:[
- aStream := SourceCodeManager sourceStreamFor:self.
- ]
- ].
-
- ^ aStream
-
- "
- Object sourceStream
- Clock sourceStream
- "
-
- "Created: 10.11.1995 / 21:05:13 / cg"
-!
-
-aStream := f readStream.
- ].
- ].
- ]
- ].
- ].
- ].
-
- aStream isNil ifTrue:[
-
- "/ mhmh - still no source file.
- "/ If there is a SourceCodeManager, ask it to aquire the
- "/ the source for my class, and return an open stream on it.
-
- SourceCodeManager notNil ifTrue:[
- aStream := SourceCodeManager sourceStreamFor:self.
- ]
- ].
-
- ^ aStream
-
- "
- Object sourceStream
- Clock sourceStream
- "
-
- "Created: 10.11.1995 / 21:05:13 / cg"
-!
-
-to get all known names."
-
- classvars isNil ifTrue:[
- ^ OrderedCollection new
- ].
- ^ classvars asCollectionOfWords
-
- "
- Object classVarNames
- Float classVarNames
- "
-!
-
-mitiveFunctions string or nil"
-
- ^ self getPrimitiveSpecsAt:3
-!
-
-.
- The library name may not be left blank.
- (this is done for backward compatibility,)
-
- For example:
- '....(libbasic)' -> module: stx directory: libbasic library: libbasic
- '....(stx:libbasic)' -> module: stx directory: libbasic library: libbasic
- '....(aeg:libIECInterface)' -> module: aeg directory: libIECInterface library:libIECInterface
- '....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase
-
- The way how the sourceCodeManager uses this to find the source location
- depends on the scheme used. For CVS, the module is taken as the -d arg,
- while the directory is prepended to the file name.
- Other schemes may do things differently - these are not yet specified.
-
- Caveat:
- Encoding this info in the package string seems somewhat kludgy.
- "
-
- |sourceInfo packageString idx1 idx2
- moduleString directoryString libraryString components|
-
- package isNil ifTrue:[^ nil].
-
- packageString := package asString.
- idx1 := packageString lastIndexOf:$(.
- idx1 ~~ 0 ifTrue:[
- idx2 := packageString indexOf:$) startingAt:idx1+1.
- idx2 ~~ 0 ifTrue:[
- sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
- ]
- ].
- sourceInfo isNil ifTrue:[^ nil].
- components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
- components size == 0 ifTrue:[
- moduleString := 'stx'.
- directoryString := libraryString := ''.
- ^ nil
- ] ifFalse:[
- components size == 1 ifTrue:[
- "/ a single name given - the module becomes 'stx',
- "/ if the component includes slashes, its the directory
- "/ otherwise the library
- "/
- moduleString := 'stx'.
- directoryString := libraryString := components at:1.
- (libraryString includes:$/) ifTrue:[
- libraryString := libraryString asFilename baseName
- ]
- ] ifFalse:[
- components size == 2 ifTrue:[
- "/ two components - assume its the directory and the library
- moduleString := 'stx'.
- directoryString := components at:1.
- libraryString := components at:2.
- ] ifFalse:[
- "/ all components given
- moduleString := components at:1.
- directoryString := components at:2.
- libraryString := components at:3.
- ]
- ]
- ].
- libraryString isEmpty ifTrue:[
- directoryString notEmpty ifTrue:[
- libraryString := directoryString asFilename baseName
- ].
- libraryString isEmpty ifTrue:[
- "/ lets extract the library from the liblist file ...
- libraryString := Smalltalk libraryFileNameOfClass:self.
- libraryString isNil ifTrue:[^ nil].
- ]
- ].
-
- moduleString isEmpty ifTrue:[
- moduleString := 'stx'.
- ].
- directoryString isEmpty ifTrue:[
- directoryString := libraryString.
- ].
-
- ^ IdentityDictionary
- with:(#module->moduleString)
- with:(#directory->directoryString)
- with:(#library->libraryString)
-
- "
- Object sourceCodeInfo
- View sourceCodeInfo
- Model sourceCodeInfo
- BinaryObjectStorage sourceCodeInfo
- MemoryMonitor sourceCodeInfo
- ClockView sourceCodeInfo
- "
-
- "Created: 4.11.1995 / 20:36:53 / cg"
-!
-
-eInstance
- ] ifFalse:[
- cls := self
- ].
- source := (Smalltalk fileNameForClass:cls) , '.st'
- ].
-
- fileName := Smalltalk getSourceFileName:source.
- fileName isNil ifTrue:[
- fileName := source
- ].
- aStream := fileName asFilename readStream.
- aStream isNil ifTrue:[
- "/
- "/ hard case - there is no source file for this class
- "/ (neither in the source-dir-path, nor in the current directory).
- "/
-
- "/
- "/ look if my binary is from a dynamically loaded module,
- "/ and, if so, look in the modules directory for the
- "/ source file.
- "/
- ObjectFileLoader notNil ifTrue:[
- ObjectFileLoader loadedObjectHandlesDo:[:h |
- |f|
-
- aStream isNil ifTrue:[
- (h classes includes:self) ifTrue:[
- f := h pathName.
- f := f asFilename directory.
- f := f construct:source.
- f exists ifTrue:[
- aStream := f readStream.
- ].
- ].
- ]
- ].
- ].
- ].
-
- aStream isNil ifTrue:[
-
- "/ mhmh - still no source file.
- "/ If there is a SourceCodeManager, ask it to aquire the
- "/ the source for my class, and return an open stream on it.
-
- SourceCodeManager notNil ifTrue:[
- aStream := SourceCodeManager sourceStreamFor:self.
- ]
- ].
-
- ^ aStream
-
- "
- Object sourceStream
- Clock sourceStream
- "
-
- "Created: 10.11.1995 / 21:05:13 / cg"
-!
-
-package:aStringOrSymbol
- "set the package of the class."
-
- package := aStringOrSymbol
-!
-
-no classPools yet.
- "
- Smalltalk at:(self name , ':' , aSymbol) asSymbol put:something.
-!
-
-age := aStringOrSymbol
-!
-
-String.
-
- "Created: 29.10.1995 / 19:41:48 / cg"
-!
-
-classFilename
+sourceStream
+ "return an open stream on my sourcefile, nil if that is not available"
+
+ |source fileName aStream cls|
+
+ classFilename notNil ifTrue:[
+ source := classFilename
] ifFalse:[
self isMeta ifTrue:[
cls := self soleInstance
@@ -1200,177 +943,11 @@
"
"Created: 10.11.1995 / 21:05:13 / cg"
-!
-
-The way how the sourceCodeManager uses this to find the source location
- depends on the scheme used. For CVS, the module is taken as the -d arg,
- while the directory is prepended to the file name.
- Other schemes may do things differently - these are not yet specified.
-
- Caveat:
- Encoding this info in the package string seems somewhat kludgy.
- "
-
- |sourceInfo packageString idx1 idx2
- moduleString directoryString libraryString components|
-
- package isNil ifTrue:[^ nil].
-
- packageString := package asString.
- idx1 := packageString lastIndexOf:$(.
- idx1 ~~ 0 ifTrue:[
- idx2 := packageString indexOf:$) startingAt:idx1+1.
- idx2 ~~ 0 ifTrue:[
- sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
- ]
- ].
- sourceInfo isNil ifTrue:[^ nil].
- components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
- components size == 0 ifTrue:[
- moduleString := 'stx'.
- directoryString := libraryString := ''.
- ^ nil
- ] ifFalse:[
- components size == 1 ifTrue:[
- "/ a single name given - the module becomes 'stx',
- "/ if the component includes slashes, its the directory
- "/ otherwise the library
- "/
- moduleString := 'stx'.
- directoryString := libraryString := components at:1.
- (libraryString includes:$/) ifTrue:[
- libraryString := libraryString asFilename baseName
- ]
- ] ifFalse:[
- components size == 2 ifTrue:[
- "/ two components - assume its the directory and the library
- moduleString := 'stx'.
- directoryString := components at:1.
- libraryString := components at:2.
- ] ifFalse:[
- "/ all components given
- moduleString := components at:1.
- directoryString := components at:2.
- libraryString := components at:3.
- ]
- ]
- ].
- libraryString isEmpty ifTrue:[
- directoryString notEmpty ifTrue:[
- libraryString := directoryString asFilename baseName
- ].
- libraryString isEmpty ifTrue:[
- "/ lets extract the library from the liblist file ...
- libraryString := Smalltalk libraryFileNameOfClass:self.
- libraryString isNil ifTrue:[^ nil].
- ]
- ].
-
- moduleString isEmpty ifTrue:[
- moduleString := 'stx'.
- ].
- directoryString isEmpty ifTrue:[
- directoryString := libraryString.
- ].
-
- ^ IdentityDictionary
- with:(#module->moduleString)
- with:(#directory->directoryString)
- with:(#library->libraryString)
-
- "
- Object sourceCodeInfo
- View sourceCodeInfo
- Model sourceCodeInfo
- BinaryObjectStorage sourceCodeInfo
- MemoryMonitor sourceCodeInfo
- ClockView sourceCodeInfo
- "
-
- "Created: 4.11.1995 / 20:36:53 / cg"
-!
-
-imitiveVariable string"
-
- self setPrimitiveSpecsAt:2 to:aString.
- self addChangeRecordForPrimitiveVariables:self.
- self updateRevisionString.
-
- "Created: 29.10.1995 / 19:41:58 / cg"
-!
-
-om:idx1 + 1 to:idx2 - 1
- ]
- ].
- sourceInfo isNil ifTrue:[^ nil].
- components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
- components size == 0 ifTrue:[
- moduleString := 'stx'.
- directoryString := libraryString := ''.
- ^ nil
- ] ifFalse:[
- components size == 1 ifTrue:[
- "/ a single name given - the module becomes 'stx',
- "/ if the component includes slashes, its the directory
- "/ otherwise the library
- "/
- moduleString := 'stx'.
- directoryString := libraryString := components at:1.
- (libraryString includes:$/) ifTrue:[
- libraryString := libraryString asFilename baseName
- ]
- ] ifFalse:[
- components size == 2 ifTrue:[
- "/ two components - assume its the directory and the library
- moduleString := 'stx'.
- directoryString := components at:1.
- libraryString := components at:2.
- ] ifFalse:[
- "/ all components given
- moduleString := components at:1.
- directoryString := components at:2.
- libraryString := components at:3.
- ]
- ]
- ].
- libraryString isEmpty ifTrue:[
- directoryString notEmpty ifTrue:[
- libraryString := directoryString asFilename baseName
- ].
- libraryString isEmpty ifTrue:[
- "/ lets extract the library from the liblist file ...
- libraryString := Smalltalk libraryFileNameOfClass:self.
- libraryString isNil ifTrue:[^ nil].
- ]
- ].
-
- moduleString isEmpty ifTrue:[
- moduleString := 'stx'.
- ].
- directoryString isEmpty ifTrue:[
- directoryString := libraryString.
- ].
-
- ^ IdentityDictionary
- with:(#module->moduleString)
- with:(#directory->directoryString)
- with:(#library->libraryString)
-
- "
- Object sourceCodeInfo
- View sourceCodeInfo
- Model sourceCodeInfo
- BinaryObjectStorage sourceCodeInfo
- MemoryMonitor sourceCodeInfo
- ClockView sourceCodeInfo
- "
-
- "Created: 4.11.1995 / 20:36:53 / cg"
! !
!Class methodsFor:'adding/removing'!
-od
+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."
@@ -1410,7 +987,8 @@
"Created: 29.10.1995 / 19:42:42 / cg"
!
-elector, aSelector and its associated method
+removeSelector:aSelector
+ "remove the selector, aSelector and its associated method
from the methodDictionary.
Append a change record to the changes file and tell dependents."
@@ -1423,7 +1001,8 @@
"Created: 29.10.1995 / 19:42:47 / cg"
!
-, unload and reinstall it as
+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
@@ -1467,7 +1046,7 @@
!Class methodsFor:'binary storage'!
-nager
+addGlobalsTo: globalDictionary manager: manager
"
classPool == nil ifFalse: [
classPool associationsDo: [:assoc|
@@ -1477,7 +1056,47 @@
"
!
-].
+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]
+!
+
+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 instance 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
@@ -1493,21 +1112,11 @@
Rectangle storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents)
"
-!
-
-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]
! !
!Class methodsFor:'c function interfacing'!
-ionNameString args:argTypeArray returning:returnType
+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
@@ -1544,24 +1153,148 @@
!Class methodsFor:'changes management'!
-urn
- ] do:[
- aBlock value:aStream.
- aStream cr.
- ].
- aStream close
+addChangeRecordForChangeCategory
+ "add a category change record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
+!
+
+addChangeRecordForChangeCategory:category to:aStream
+ "append a category change record to aStream"
+
+ self printClassNameOn:aStream.
+ aStream nextPutAll:(' category:' , category storeString).
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForClass:aClass
+ "add a class-definition-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForClass:to: with:aClass.
+!
+
+addChangeRecordForClass:aClass to:aStream
+ "append a class-definition-record to aStream"
+
+ aClass isLoaded ifTrue:[
+ aClass fileOutDefinitionOn:aStream.
+ aStream nextPutChunkSeparator.
]
!
-' removeSelector:#' , aSelector).
+addChangeRecordForClassComment:aClass
+ "add a class-comment-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForClassComment:to: with:aClass.
+!
+
+addChangeRecordForClassComment:aClass to:aStream
+ "append a class-comment-record to aStream"
+
+ aClass fileOutCommentOn:aStream.
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForClassFileOut:aClass
+ "append a class-was-filedOut-record to the changes file"
+
+ self addInfoRecord:('fileOut ' , aClass name)
+!
+
+addChangeRecordForClassInstvars:aClass
+ "add a class-instvars-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForClassInstvars:to: with:aClass.
+!
+
+addChangeRecordForClassInstvars:aClass to:aStream
+ "append a class-instvars-record to aStream"
+
+ aClass fileOutClassInstVarDefinitionOn:aStream.
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForClassRemove:oldName
+ "add a class-remove-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForClassRemove:to: with:oldName.
+!
+
+addChangeRecordForClassRemove:oldName to:aStream
+ "append a class-remove-record to aStream"
+
+ aStream nextPutAll:('Smalltalk removeClass:' , oldName).
aStream nextPutChunkSeparator.
!
-geRecordForRenameCategory:oldCategory to:newCategory to:aStream.
+addChangeRecordForClassRename:oldName to:newName
+ "add a class-rename-record to the changes file"
+
+ self writingChangeDo:[:aStream |
+ self addChangeRecordForClassRename:oldName to:newName to:aStream
+ ]
+!
+
+addChangeRecordForClassRename:oldName to:newName to:aStream
+ "append a class-rename-record to aStream"
+
+ aStream nextPutAll:('Smalltalk renameClass:' , oldName , ' to:''' , newName , '''').
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForMethod:aMethod
+ "add a method-change-record to the changes file"
+
+ (UpdateChangeFileQuerySignal raise) "UpdatingChanges" ifTrue:[
+ self writingChangePerform:#addChangeRecordForMethod:to: with:aMethod.
+ "this test allows a smalltalk without Projects/ChangeSets"
+ Project notNil ifTrue:[
+ Project addMethodChange:aMethod in:self
+ ]
]
!
-.
+addChangeRecordForMethod:aMethod to:aStream
+ "append a method-change-record to aStream"
+
+ self fileOutMethod:aMethod on:aStream.
+!
+
+addChangeRecordForMethodCategory:aMethod category:aString
+ "add a methodCategory-change-record to the changes file"
+
+ (UpdateChangeFileQuerySignal raise) "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
+ ]
+ ]
+!
+
+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 nextPutChunkSeparator.
+ ]
+!
+
+addChangeRecordForMethodPrivacy:aMethod
+ "add a method-privacy-change-record to the changes file"
+
+ (UpdateChangeFileQuerySignal raise) "UpdatingChanges" ifTrue:[
+ self writingChangePerform:#addChangeRecordForMethodPrivacy:to: with:aMethod.
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodPrivacyChange:aMethod in:self
@@ -1571,20 +1304,14 @@
"Modified: 27.8.1995 / 22:47:32 / claus"
!
-aStream isNil ifTrue:[
- self warn:'cannot create/update the changes file'.
- ^ nil
- ]
- ].
- aStream setToEnd
- ].
- ^ aStream
-
- "Created: 28.10.1995 / 16:53:43 / cg"
- "Modified: 28.10.1995 / 16:55:03 / cg"
-!
-
-am nextPutAll:'('.
+addChangeRecordForMethodPrivacy:aMethod to:aStream
+ "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).
@@ -1594,19 +1321,120 @@
"Modified: 27.8.1995 / 22:59:56 / claus"
!
-am notNil ifTrue:[
- FileStream writeErrorSignal handle:[:ex |
- self warn:('could not update the changes-file\\' , ex errorString) withCRs.
- ex return
- ] do:[
- aBlock value:aStream.
- aStream cr.
- ].
- aStream close
+addChangeRecordForPrimitiveDefinitions:aClass
+ "add a primitiveDefinitions-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForPrimitiveDefinitions:to: with:aClass.
+!
+
+addChangeRecordForPrimitiveDefinitions:aClass to:aStream
+ "append a primitiveDefinitions-record to aStream"
+
+ aStream nextPutAll:aClass name
+ , ' primitiveDefinitions:'
+ , aClass primitiveDefinitionsString storeString.
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForPrimitiveFunctions:aClass
+ "add a primitiveFunctions-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForPrimitiveFunctions:to: with:aClass.
+!
+
+addChangeRecordForPrimitiveFunctions:aClass to:aStream
+ "append a primitiveFunctions-record to aStream"
+
+ aStream nextPutAll:aClass name
+ , ' primitiveFunctions:'
+ , aClass primitiveFunctionsString storeString.
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForPrimitiveVariables:aClass
+ "add a primitiveVariables-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForPrimitiveVariables:to: with:aClass.
+!
+
+addChangeRecordForPrimitiveVariables:aClass to:aStream
+ "append a primitiveVariables-record to aStream"
+
+ aStream nextPutAll:aClass name
+ , ' primitiveVariables:'
+ , aClass primitiveVariablesString storeString.
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForRemoveSelector:aSelector
+ "add a method-remove-record to the changes file"
+
+ self writingChangePerform:#addChangeRecordForRemoveSelector:to: with:aSelector.
+!
+
+addChangeRecordForRemoveSelector:aSelector to:aStream
+ "append a method-remove-record to aStream"
+
+ self printClassNameOn:aStream.
+ aStream nextPutAll:(' removeSelector:#' , aSelector).
+ aStream nextPutChunkSeparator.
+!
+
+addChangeRecordForRenameCategory:oldCategory to:newCategory
+ "add a category-rename record to the changes file"
+
+ self writingChangeDo:[:aStream |
+ self addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream.
]
!
-Stream.
+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 nextPutChunkSeparator.
+!
+
+addChangeRecordForSnapshot:aFileName
+ "add a snapshot-record to the changes file"
+
+ self addInfoRecord:('snapshot ' , aFileName)
+!
+
+addChangeRecordForSnapshot:aFileName to:aStream
+ "add a snapshot-record to aStream"
+
+ self addInfoRecord:('snapshot ' , aFileName) to:aStream
+!
+
+addInfoRecord:aMessage
+ "add an info-record (snapshot, class fileOut etc.) to the changes file"
+
+ self writingChangePerform:#addInfoRecord:to: with:aMessage.
+!
+
+addInfoRecord:aMessage to:aStream
+ "append an info-record (snapshot, class fileOut etc.) to aStream"
+
+ aStream nextPutAll:('''---- ' , aMessage , ' ',
+ Date today printString , ' ' ,
+ Time now printString ,
+ ' ----''').
+ aStream nextPutChunkSeparator.
+!
+
+changesStream
+ "return a Stream for the writing changes file - or nil if no update is wanted"
+
+ |streamType aStream fileName|
+
+ (UpdateChangeFileQuerySignal raise) ifTrue:[
+ fileName := ObjectMemory nameForChanges.
+
+ LockChangesFile ifTrue:[
+ streamType := LockedFileStream.
] ifFalse:[
streamType := FileStream.
].
@@ -1626,94 +1454,10 @@
"Modified: 28.10.1995 / 16:55:03 / cg"
!
-ChangeRecordForMethodPrivacy:aMethod to:aStream
- "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"
-!
-
-in case of an abort or other error."
-
- UpdateChangeFileQuerySignal handle:[:ex |
- ex proceedWith:false
- ] do:[
- aBlock value
- ].
-!
-
-eRecordForPrimitiveVariables:aClass
- "add a primitiveVariables-record to the changes file"
-
- self writingChangePerform:#addChangeRecordForPrimitiveVariables:to: with:aClass.
-!
-
-m
-
- "Created: 28.10.1995 / 16:53:17 / cg"
-!
-
-s:aClass to:aStream
- "append a primitiveFunctions-record to aStream"
-
- aStream nextPutAll:aClass name
- , ' primitiveFunctions:'
- , aClass primitiveFunctionsString storeString.
- aStream nextPutChunkSeparator.
-!
-
-me to:newName
- "add a class-rename-record to the changes file"
-
- self writingChangeDo:[:aStream |
- self addChangeRecordForClassRename:oldName to:newName to:aStream
- ]
-!
-
-a category change record to the changes file"
-
- self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
-!
-
-foRecord:('snapshot ' , aFileName)
-!
-
-Category:aMethod category:aString to:aStream.
- ].
-
- "this test allows a smalltalk without Projects/ChangeSets"
- Project notNil ifTrue:[
- Project addMethodCategoryChange:aMethod category:aString in:self
- ]
- ]
-!
-
-nextPutAll:('''---- ' , aMessage , ' ',
- Date today printString , ' ' ,
- Time now printString ,
- ' ----''').
- aStream nextPutChunkSeparator.
-!
-
-extPutAll:'('.
- self printClassNameOn:aStream.
- aStream nextPutAll:(' compiledMethodAt:' , selector storeString).
- aStream nextPutAll:(') category:' , newCategory storeString).
- aStream nextPutChunkSeparator.
- ]
-!
-
-typically each classes source is kept
+sourcesStream
+ "return a stream for writing the sources file.
+ Notice, in ST/X, it is noncommon to use a single
+ source file; typically each classes source is kept
in a separate file."
|aStream fileName|
@@ -1733,99 +1477,20 @@
"Created: 28.10.1995 / 16:53:17 / cg"
!
-iveDefinitions:to: with:aClass.
-!
-
-Nil ifTrue:[
- aStream := FileStream newFileNamed:fileName.
- aStream isNil ifTrue:[
- Transcript showCr:'cannot update sources file'.
- ^ nil
- ]
+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."
+
+ UpdateChangeFileQuerySignal handle:[:ex |
+ ex proceedWith:false
+ ] do:[
+ aBlock value
].
- aStream setToEnd.
- ^ aStream
-
- "Created: 28.10.1995 / 16:53:17 / cg"
-!
-
-aStream nextPutChunkSeparator.
-!
-
-3 / cg"
- "Modified: 28.10.1995 / 16:55:03 / cg"
-!
-
-oreString).
- aStream nextPutChunkSeparator.
- ]
-
- "Modified: 27.8.1995 / 22:59:56 / claus"
-!
-
-extPutAll:(' to:' , newCategory storeString).
- aStream nextPutChunkSeparator.
!
-odCategory:aMethod category:aString
- "add a methodCategory-change-record to the changes file"
-
- (UpdateChangeFileQuerySignal raise) "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
- ]
- ]
-!
-
-ing.
- 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 warn:('could not update the changes-file\\' , ex errorString) withCRs.
- ex return
- ] do:[
- aBlock value:aStream.
- aStream cr.
- ].
- aStream close
- ]
-!
-
-ordForPrimitiveVariables:aClass to:aStream
- "append a primitiveVariables-record to aStream"
-
- aStream nextPutAll:aClass name
- , ' primitiveVariables:'
- , aClass primitiveVariablesString storeString.
- aStream nextPutChunkSeparator.
-!
-
-rform:aSelector with:anArgument with:stream.
- ]
-
- "Created: 28.10.1995 / 16:50:48 / cg"
-!
-
-gory-rename record to aStream"
-
- self printClassNameOn:aStream.
- aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
- aStream nextPutAll:(' to:' , newCategory storeString).
- aStream nextPutChunkSeparator.
-!
-
-mmon helper to write a change record.
+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
@@ -1847,38 +1512,18 @@
]
!
-to the changes file"
-
- self writingChangePerform:#addChangeRecordForRemoveSelector:to: with:aSelector.
-!
-
-angeRecordForChangeCategory:category to:aStream
- "append a category change record to aStream"
-
- self printClassNameOn:aStream.
- aStream nextPutAll:(' category:' , category storeString).
- aStream nextPutChunkSeparator.
-!
-
-'''').
- aStream nextPutChunkSeparator.
-!
-
-self writingChangePerform:#addChangeRecordForClassRemove:to: with:oldName.
-!
-
-elf writingChangePerform:#addChangeRecordForClassComment:to: with:aClass.
-!
-
-m"
-
- aClass fileOutClassInstVarDefinitionOn:aStream.
- aStream nextPutChunkSeparator.
+writingChangePerform:aSelector with:anArgument
+ self writingChangeDo:[:stream |
+ self perform:aSelector with:anArgument with:stream.
+ ]
+
+ "Created: 28.10.1995 / 16:50:48 / cg"
! !
!Class methodsFor:'compiling'!
-r this class;
+compile:code
+ "compile code, aString for this class;
if sucessful update the method dictionary."
self compilerClass
@@ -1886,7 +1531,8 @@
forClass:self
!
-ile code, aString for this class;
+compile:code classified:category
+ "compile code, aString for this class;
if sucessful update the method dictionary.
The method is classified under category."
@@ -1896,7 +1542,8 @@
inCategory:category
!
-ile code, aString for this class; on any error, notify
+compile:code notifying:requestor
+ "compile code, aString for this class; on any error, notify
requestor, anObject with the error reason."
self compilerClass
@@ -1905,45 +1552,9 @@
notifying:requestor
!
-]) ifTrue:[
- self recompile:aSelector
- ]
- ]
-!
-
-leAll
- "recompile this class and all subclasses"
-
- |classes|
-
- classes := self subclasses.
- self recompile.
- classes do:[:aClass |
- aClass recompileAll
- ]
-!
-
-Names orSuper:false
-!
-
-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
- ]
- ]
-!
-
-used when a class changes instances and therefore all methods
+recompile
+ "recompile all methods
+ used when a class changes instances and therefore all methods
have to be recompiled"
selectorArray do:[:aSelector |
@@ -1951,7 +1562,7 @@
]
!
-elector
+recompile:aSelector
"recompile the method associated with the argument, aSelector;
used when a superclass changes instances and we have to recompile
subclasses"
@@ -1967,458 +1578,144 @@
self compilerClass compile:code forClass:self inCategory:cat
]
]
+!
+
+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
+ ]
+ ]
+!
+
+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
+ ]
+ ]
! !
!Class methodsFor:'fileIn interface'!
-s the next chunks"
-
- ^ ClassCategoryReader class:self primitiveSpec:#primitiveFunctions:
-!
-
-primitiveSpec:#primitiveVariables:
-!
-
-speciality of ST/X - it allows quick commenting of methods
+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
!
-assCategoryReader class:self primitiveSpec:#primitiveDefinitions:
-!
-
-Returns a ClassCategoryReader to read in and compile methods for me."
-
- ^ (self methodsFor:aCategory) privateProtocol
+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'
!
-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
-!
-
-NOT really enforce method visibility yet).
- Returns a ClassCategoryReader to read in and compile methods for me."
-
- ^ (self methodsFor:aCategory) protectedProtocol
-!
-
-a ClassCategoryReader to read in and compile methods for me.
+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
!
-does - it was encountered by some tester.
+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
!
-eader skippingChunks
+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:
+!
+
+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:
+!
+
+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:
+!
+
+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
+!
+
+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
! !
!Class methodsFor:'fileOut'!
-"/ 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:[
- s := ''''''
- ] ifFalse:[
- s := category asString storeString
- ].
- aStream nextPutAll:s.
- aStream cr
-!
-
-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
- ]
-!
-
-e. aStream cr.].
- ].
-
- stampIt ifTrue:[
- "
- first, a timestamp
- "
- aStream nextPutAll:(Smalltalk timeStamp).
- aStream nextPutChunkSeparator.
- aStream cr; cr.
- ].
-
- "
- then the definition
- "
- self fileOutDefinitionOn:aStream.
- aStream nextPutChunkSeparator.
- aStream cr; cr.
- "
- optional classInstanceVariables
- "
- self class instanceVariableString isBlank ifFalse:[
- self fileOutClassInstVarDefinitionOn:aStream.
- aStream nextPutChunkSeparator.
- aStream cr; cr
- ].
-
- "
- a comment - if any
- "
- (comment := self comment) notNil ifTrue:[
- aStream nextPutAll:name; nextPutAll:' comment:'.
- aStream nextPutAll:(comment storeString).
- aStream nextPutChunkSeparator.
- aStream cr; cr
- ].
-
- "
- primitive definitions - if any
- "
- self fileOutPrimitiveSpecsOn:aStream.
-
- "
- methods from all categories in metaclass
- "
- collectionOfCategories := self class categories asSortedCollection.
- 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 asSortedCollection.
- 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 nextPutChunkSeparator.
- aStream cr
- ]
-
- "Created: 15.11.1995 / 12:53:06 / cg"
-!
-
-fileOutCategory:aCategory on:aStream
- "file out all methods belonging to aCategory, aString onto aStream"
-
- |source sortedSelectors first privacy interrestingMethods|
-
- methodArray notNil ifTrue:[
- interrestingMethods := OrderedCollection new.
- methodArray do:[:aMethod |
- (aCategory = aMethod category) ifTrue:[
- interrestingMethods add:aMethod.
- ]
- ].
- interrestingMethods notEmpty ifTrue:[
- first := true.
- privacy := nil.
-
- "/
- "/ sort by selector
- "/
- sortedSelectors := interrestingMethods collect:[:m | self selectorAtMethod:m].
- sortedSelectors sortWith:interrestingMethods.
-
- interrestingMethods 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:'''.
- ].
- aCategory notNil ifTrue:[
- aStream nextPutAll:aCategory
- ].
- aStream nextPut:$'; nextPutChunkSeparator; cr; cr.
- first := false.
- ].
- source := aMethod source.
- source isNil ifTrue:[
- FileOutErrorSignal raiseRequestWith:'no source for method'
- ] ifFalse:[
- aStream nextChunkPut:source.
- ].
- ].
- aStream space.
- aStream nextPutChunkSeparator.
- aStream cr
- ]
- ]
-
- "Modified: 28.8.1995 / 14:30:41 / claus"
- "Modified: 15.11.1995 / 12:45:54 / cg"
-!
-
-d in the browser and filedOut.
- "
- ((cls := self class) selectorArray includes:#copyright) ifTrue:[
- "
- get the copyright methods source,
- and insert at beginning.
- "
- copyrightText := (cls compiledMethodAt:#copyright) source.
- copyrightText isNil ifTrue:[
- "
- no source available - trigger an error
- "
- FileOutErrorSignal
- raiseRequestWith:'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.].
- ].
-
- stampIt ifTrue:[
- "
- first, a timestamp
- "
- aStream nextPutAll:(Smalltalk timeStamp).
- aStream nextPutChunkSeparator.
- aStream cr; cr.
- ].
-
- "
- then the definition
- "
- self fileOutDefinitionOn:aStream.
- aStream nextPutChunkSeparator.
- aStream cr; cr.
- "
- optional classInstanceVariables
- "
- self class instanceVariableString isBlank ifFalse:[
- self fileOutClassInstVarDefinitionOn:aStream.
- aStream nextPutChunkSeparator.
- aStream cr; cr
- ].
-
- "
- a comment - if any
- "
- (comment := self comment) notNil ifTrue:[
- aStream nextPutAll:name; nextPutAll:' comment:'.
- aStream nextPutAll:(comment storeString).
- aStream nextPutChunkSeparator.
- aStream cr; cr
- ].
-
- "
- primitive definitions - if any
- "
- self fileOutPrimitiveSpecsOn:aStream.
-
- "
- methods from all categories in metaclass
- "
- collectionOfCategories := self class categories asSortedCollection.
- 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 asSortedCollection.
- 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 nextPutChunkSeparator.
- aStream cr
- ]
-
- "Created: 15.11.1995 / 12:53:06 / cg"
-!
-
-ue:[
- 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
-!
-
-nd an expression on aStream, which defines myself."
+basicFileOutDefinitionOn:aStream
+ "append an expression on aStream, which defines myself."
|isVar line s|
@@ -2490,97 +1787,329 @@
aStream cr
!
-do:[:aCategory |
- ((aCategory ~= 'documentation')
- and:[(aCategory ~= 'initialization')
- and:[aCategory ~= 'instance creation']]) ifTrue:[
- self class fileOutCategory:aCategory on:aStream.
- aStream cr
- ]
- ]
+checkIn
+ "check my source into the source repository"
+
+ SourceCodeManager notNil ifTrue:[
+ SourceCodeManager checkinClass:self
].
+
+ "Created: 15.11.1995 / 12:54:59 / cg"
+!
+
+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 may not be rewritten."
+
+ |aStream baseName dirName fileName newFileName needRename
+ mySourceFileName sameFile|
+
+ baseName := (Smalltalk fileNameForClass:self name).
+ fileName := baseName , '.st'.
+
"
- methods from all categories in myself
+ 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 ...
"
- collectionOfCategories := self categories asSortedCollection.
- collectionOfCategories notNil ifTrue:[
- collectionOfCategories do:[:aCategory |
- self fileOutCategory:aCategory on:aStream.
- aStream cr
- ]
+ (fileName asFilename exists
+ and:[classFilename notNil]) ifTrue:[
+ "
+ check for overwriting my current source file
+ this is not allowed, since it would clobber my methods source
+ file ... you have to save it to some other place.
+ This happens if you ask for a fileOut into the source-directory
+ (from which my methods get their source)
+ "
+ mySourceFileName := Smalltalk getSourceFileName:classFilename.
+ sameFile := (fileName = mySourceFileName).
+ sameFile ifFalse:[
+ sameFile := (fileName asFilename info at:#id) == (mySourceFileName asFilename info at:#id)
+ ].
+ sameFile ifTrue:[
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('may not overwrite sourcefile:', fileName)
+ ].
+
+ fileName asFilename copyTo:('/tmp/' , baseName , '.sav').
+ newFileName := dirName , baseName , '.new'.
+ needRename := true
+ ] ifFalse:[
+ newFileName := fileName.
+ needRename := false
].
- "
- optionally an initialize message
+
+ aStream := FileStream newFileNamed:newFileName.
+ aStream isNil ifTrue:[
+ ^ FileOutErrorSignal
+ raiseRequestWith:newFileName
+ errorString:('cannot create file:', newFileName)
+ ].
+ self fileOutOn:aStream.
+ aStream close.
+
"
- (self class implements:#initialize) ifTrue:[
- aStream nextPutAll:(name , ' initialize').
- aStream nextPutChunkSeparator.
- aStream cr
- ]
-
- "Created: 15.11.1995 / 12:53:06 / cg"
+ 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
!
-mitiveSpecsOn:aStream.
+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.
+ ].
"
- methods from all categories in metaclass
+ if file exists, save original in a .sav file
"
- collectionOfCategories := self class categories asSortedCollection.
- 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.
+ 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
+!
+
+fileOutCategory:aCategory on:aStream
+ "file out all methods belonging to aCategory, aString onto aStream"
+
+ |source sortedSelectors first privacy interrestingMethods|
+
+ methodArray notNil ifTrue:[
+ interrestingMethods := OrderedCollection new.
+ methodArray do:[:aMethod |
+ (aCategory = aMethod category) ifTrue:[
+ interrestingMethods add:aMethod.
+ ]
].
- "
- 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 asSortedCollection.
- collectionOfCategories notNil ifTrue:[
- collectionOfCategories do:[:aCategory |
- self fileOutCategory:aCategory on:aStream.
+ interrestingMethods notEmpty ifTrue:[
+ first := true.
+ privacy := nil.
+
+ "/
+ "/ sort by selector
+ "/
+ sortedSelectors := interrestingMethods collect:[:m | self selectorAtMethod:m].
+ sortedSelectors sortWith:interrestingMethods.
+
+ interrestingMethods 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:'''.
+ ].
+ aCategory notNil ifTrue:[
+ aStream nextPutAll:aCategory
+ ].
+ aStream nextPut:$'; nextPutChunkSeparator; cr; cr.
+ first := false.
+ ].
+ source := aMethod source.
+ source isNil ifTrue:[
+ FileOutErrorSignal raiseRequestWith:'no source for method'
+ ] ifFalse:[
+ aStream nextChunkPut:source.
+ ].
+ ].
+ aStream space.
+ aStream nextPutChunkSeparator.
aStream cr
]
+ ]
+
+ "Modified: 28.8.1995 / 14:30:41 / claus"
+ "Modified: 15.11.1995 / 12:45:54 / cg"
+!
+
+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; 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.
].
- "
- optionally an initialize message
- "
- (self class implements:#initialize) ifTrue:[
- aStream nextPutAll:(name , ' initialize').
- aStream nextPutChunkSeparator.
- aStream cr
+ aStream nextPut:(Character doubleQuote); cr.
+!
+
+fileOutCommentOn:aStream
+ "append an expression on aStream, which defines my comment"
+
+ |comment s|
+
+ aStream nextPutAll:name; nextPutAll:' comment:'.
+ (comment := self comment) isNil ifTrue:[
+ s := ''''''
+ ] ifFalse:[
+ s := comment storeString
+ ].
+ aStream nextPutAll:s.
+ aStream cr
+!
+
+fileOutDefinitionOn:aStream
+ "append an expression on aStream, which defines myself."
+
+ ^ self basicFileOutDefinitionOn:aStream
+!
+
+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:[
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName)
+ ].
+ self fileOutOn: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
]
-
- "Created: 15.11.1995 / 12:53:06 / cg"
!
-4:59 / cg"
+fileOutMethod:aMethod on:aStream
+ "file out the method, aMethod onto aStream"
+
+ |cat source privacy|
+
+ methodArray 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 notNil ifTrue:[
+ aStream nextPutAll:cat
+ ].
+ aStream nextPut:$'; 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"
!
fileOutOn:aStream
@@ -2726,126 +2255,8 @@
"Created: 15.11.1995 / 12:53:06 / cg"
!
-a sourceFile and which must be
- applied again
- "
- self addChangeRecordForClassFileOut:self
-!
-
-ileOutCategory:aCategory on:aStream
- "file out all methods belonging to aCategory, aString onto aStream"
-
- |source sortedSelectors first privacy interrestingMethods|
-
- methodArray notNil ifTrue:[
- interrestingMethods := OrderedCollection new.
- methodArray do:[:aMethod |
- (aCategory = aMethod category) ifTrue:[
- interrestingMethods add:aMethod.
- ]
- ].
- interrestingMethods notEmpty ifTrue:[
- first := true.
- privacy := nil.
-
- "/
- "/ sort by selector
- "/
- sortedSelectors := interrestingMethods collect:[:m | self selectorAtMethod:m].
- sortedSelectors sortWith:interrestingMethods.
-
- interrestingMethods 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:'''.
- ].
- aCategory notNil ifTrue:[
- aStream nextPutAll:aCategory
- ].
- aStream nextPut:$'; nextPutChunkSeparator; cr; cr.
- first := false.
- ].
- source := aMethod source.
- source isNil ifTrue:[
- FileOutErrorSignal raiseRequestWith:'no source for method'
- ] ifFalse:[
- aStream nextChunkPut:source.
- ].
- ].
- aStream space.
- aStream nextPutChunkSeparator.
- aStream cr
- ]
- ]
-
- "Modified: 28.8.1995 / 14:30:41 / claus"
- "Modified: 15.11.1995 / 12:45:54 / cg"
-! !
-
-!Class methodsFor:'printOut'!
-
-ally an initialize message
- "
- (self class implements:#initialize) ifTrue:[
- aStream nextPutAll:(name , ' initialize').
- aStream nextPutChunkSeparator.
- aStream cr
- ]
-
- "Created: 15.11.1995 / 12:53:06 / cg"
-!
-
-tAll:s.
- aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
- ].
-!
-
-[:aSubclass |
- aSubclass printFullHierarchyOn:aStream indent:(indent + 2)
- ]
-
- "|printStream|
- printStream := Printer new.
- Object printFullHierarchyOn:printStream indent:0.
- printStream close"
-!
-
-s indented and breaking at line end"
-
- self printNameArray:(self classVarNames) on:aStream indent:indent
-!
-
-fFalse:[
- name printOn:aStream
- ]
-!
-
-I am not a Metaclass;
- otherwise my name without -class followed by space-class"
-
- self isMeta ifTrue:[
- aStream nextPutAll:(name copyTo:(name size - 5)); nextPutAll:' class'
- ] ifFalse:[
- name printOn:aStream
- ]
-!
-
-itive defs (if any) to aStream."
+fileOutPrimitiveDefinitionsOn:aStream
+ "append primitive defs (if any) to aStream."
|s|
@@ -2870,7 +2281,197 @@
].
!
-ition"
+fileOutPrimitiveSpecsOn:aStream
+ "append primitive defs (if any) to aStream."
+
+ |s|
+
+ "
+ primitive definitions - if any
+ "
+ self fileOutPrimitiveDefinitionsOn:aStream.
+ "
+ primitive functions - if any
+ "
+ (s := self primitiveFunctionsString) notNil ifTrue:[
+ aStream nextPutChunkSeparator;
+ nextPutAll:name; nextPutAll:' primitiveFunctions';
+ nextPutChunkSeparator;
+ cr.
+ aStream nextPutAll:s.
+ aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+ ].
+! !
+
+!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)); nextPutAll:' class'
+ ] ifFalse:[
+ name printOn:aStream
+ ]
+!
+
+printClassVarNamesOn:aStream indent:indent
+ "print the class variable names indented and breaking at line end"
+
+ self printNameArray:(self classVarNames) on:aStream indent: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; bold; nextPutAll:name; normal; 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"
+!
+
+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; nextPutAll:' ('.
+ self printInstVarNamesOn:aStream indent:(indent + name size + 2).
+ aStream nextPutAll:')'.
+ aStream cr.
+ ^ indent
+!
+
+printHierarchyOn:aStream
+ "print my class hierarchy on aStream"
+
+ self printHierarchyAnswerIndentOn:aStream
+!
+
+printInstVarNamesOn:aStream indent:indent
+ "print the instance variable names indented and breaking at line end"
+
+ self printNameArray:(self instVarNames) on:aStream indent:indent
+!
+
+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
+ ]
+!
+
+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; cr.
+ methodArray do:[:aMethod |
+ (aCategory = aMethod category) ifTrue:[
+ self printOutSource:(aMethod source) on:aPrintStream.
+ aPrintStream cr; cr
+ ]
+ ].
+ aPrintStream cr
+ ]
+ ]
+!
+
+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; cr.
+ methodArray do:[:aMethod |
+ (aCategory = aMethod category) ifTrue:[
+ self printOutSourceProtocol:aMethod
+ on:aPrintStream.
+ aPrintStream cr; cr
+ ]
+ ].
+ aPrintStream cr
+ ]
+ ]
+!
+
+printOutDefinitionOn:aPrintStream
+ "print out my definition"
|comment s|
@@ -2902,7 +2503,23 @@
]
!
-collectionOfCategories notNil ifTrue:[
+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; cr.
+ collectionOfCategories do:[:aCategory |
+ self class printOutCategory:aCategory on:aPrintStream
+ ]
+ ].
+ collectionOfCategories := self categories.
+ collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'instance protocol'.
aPrintStream cr; cr.
collectionOfCategories do:[:aCategory |
@@ -2911,22 +2528,16 @@
]
!
-arNamesOn:aStream indent:(indent + name size + 2).
- aStream nextPutAll:')'.
- aStream cr.
- ^ indent
-!
-
-ory '; nextPutAll:(category printString).
- aPrintStream cr
- ].
-
- (comment := self comment) notNil ifTrue:[
- aPrintStream cr; nextPutAll:'comment:'; cr; italic; nextPutAll:comment; normal; cr
- ]
-!
-
-lf class printOutCategoryProtocol:aCategory on:aPrintStream
+printOutProtocolOn:aPrintStream
+ |collectionOfCategories|
+ self printOutDefinitionOn:aPrintStream.
+ aPrintStream cr.
+ collectionOfCategories := self class categories.
+ collectionOfCategories notNil ifTrue:[
+ aPrintStream nextPutAll:'class protocol'.
+ aPrintStream cr; cr.
+ collectionOfCategories do:[:aCategory |
+ self class printOutCategoryProtocol:aCategory on:aPrintStream
]
].
collectionOfCategories := self categories.
@@ -2939,154 +2550,16 @@
]
!
-ory 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; cr.
- methodArray do:[:aMethod |
- (aCategory = aMethod category) ifTrue:[
- self printOutSource:(aMethod source) on:aPrintStream.
- aPrintStream cr; cr
- ]
- ].
- aPrintStream cr
- ]
- ]
-!
-
-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
- ]
-! !
-
-!Class methodsFor:'private'!
-
-ue:[^ nil].
- ^ lines at:idx.
-
- "
- Smalltalk allClassesDo:[:cls |
- Transcript showCr:cls revisionString
- ].
-
- Number revisionString
- FileDirectory revisionString
- "
-
- "Created: 29.10.1995 / 19:28:03 / cg"
- "Modified: 11.11.1995 / 14:11:41 / cg"
-!
-
-:[
- info at:#fileName put:(words at:2).
- info at:#revision put:(words at:3).
- info at:#date put:(words at:4).
- info at:#time put:(words at:5).
- info at:#user put:(words at:6).
- info at:#state put:(words at:7).
- ^ info
- ].
- ].
- ^ nil
-
- "
- Object revisionString
- Object revisionInfo
- "
-
- "Created: 11.11.1995 / 14:27:20 / cg"
- "Modified: 14.11.1995 / 16:00:51 / cg"
-!
-
-version.
- val isString ifTrue:[^ val].
-
- src := m source.
- src isNil ifTrue:[^ nil].
- lines := src asCollectionOfLines.
- idx := lines findFirst:[:l |
- l withoutSpaces startsWith:'$Header'
- ].
- idx == 0 ifTrue:[^ nil].
- ^ lines at:idx.
-
- "
- Smalltalk allClassesDo:[:cls |
- Transcript showCr:cls revisionString
- ].
-
- Number revisionString
- FileDirectory revisionString
- "
-
- "Created: 29.10.1995 / 19:28:03 / cg"
- "Modified: 11.11.1995 / 14:11:41 / cg"
-!
-
-ied: 14.11.1995 / 16:00:51 / cg"
-!
-
-[^ nil].
-
- "the primitiveSpec is either a string, or an integer specifying the
- position within the classes sourcefile ...
- "
- pos isNumber ifTrue:[
- classFilename notNil ifTrue:[
- stream := self sourceStream. "/ Smalltalk sourceFileStreamFor:classFilename.
- stream notNil ifTrue:[
- stream position:pos+1.
- string := stream nextChunk.
- stream close.
- ^ string
- ]
- ].
- ^ nil
- ].
- ^ pos
-!
-
-!
-
-11.11.1995 / 14:11:41 / cg"
-!
-
-am cr.
+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.
@@ -3118,65 +2591,209 @@
aPrintStream cr.
textIndex := textIndex + 1
]
-! !
-
-!Class methodsFor:'queries'!
-
-The returned collection is not sorted by any order."
-
- |coll|
-
- coll := OrderedCollection new.
- self addAllCategoriesTo:coll.
- ^ coll
+!
+
+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
"
- Point categories
- Point allCategories
+ Float printOutProtocolOn:Stdout
"
+! !
+
+!Class methodsFor:'private'!
+
+addAllCategoriesTo:aCollection
+ "helper - add categories and all superclasses categories
+ to the argument, aCollection"
+
+ (superclass notNil) ifTrue:[
+ superclass addAllCategoriesTo:aCollection
+ ].
+ self addCategoriesTo:aCollection
!
-ightPart vsnString|
-
- cls := self.
- self isMeta ifFalse:[
- cls := self class
+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).
].
- m := cls compiledMethodAt:#version.
- m isNil ifTrue:[^ self].
- vs := self revisionString.
- vs isNil ifTrue:[^ self].
-
- "/ search for ,v
- idx := vs indexOfSubCollection:'.st,v'.
- idx == 0 ifTrue:[^ self].
- leftPart := vs copyTo:(idx - 1 + 5).
- rightPart := (vs copyFrom:(idx + 5)) withoutSpaces.
- idx := rightPart indexOfSeparator.
- idx == 0 ifTrue:[^ self].
- vsnString := rightPart copyTo:idx - 1.
- rightPart := rightPart copyFrom:idx + 1.
- vsnString ~= self revision ifTrue:[
- "/ alread a modified class
-"/ ('already modified: ' , vsnString) printNL.
- ^ self
+ ^ aCollection
+!
+
+addCategoriesTo:aCollection
+ "helper - add categories to the argument, aCollection"
+
+ methodArray do:[:aMethod |
+ |cat|
+
+ cat := aMethod category.
+ (aCollection includes:cat) ifFalse:[
+ aCollection add:cat
+ ]
+ ]
+!
+
+getPrimitiveSpecsAt: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 := self sourceStream. "/ Smalltalk sourceFileStreamFor:classFilename.
+ stream notNil ifTrue:[
+ stream position:pos+1.
+ string := stream nextChunk.
+ stream close.
+ ^ string
+ ]
+ ].
+ ^ nil
].
- m source:'version
-^ ''' , leftPart , ' ' , vsnString , 'mod' , ' ' , rightPart , ''''.
-
-"/ ('updated to :' , vsnString , 'mod') printNL.
+ ^ pos
+!
+
+revisionInfo
+ "return a dictionary filled with revision info.
+ This extracts the reevant info from the revisionString."
+
+ |vsnString words info nm|
+
+ info := IdentityDictionary new.
+ vsnString := self revisionString.
+ vsnString notNil ifTrue:[
+ words := vsnString asCollectionOfWords.
+
+ "/
+ "/ supported formats:
+ "/
+ "/ $-Header: pathName rev date time user state $
+ "/ $-Revision: rev $
+ "/ $-Id: fileName rev date time user state $
+ "/
+ ((words at:1) = '$Header:') ifTrue:[
+ nm := words at:2.
+ info at:#repositoryPathName put:nm.
+ (nm endsWith:',v') ifTrue:[
+ nm := nm copyWithoutLast:2
+ ].
+ info at:#fileName put:nm asFilename baseName.
+ info at:#revision put:(words at:3).
+ info at:#date put:(words at:4).
+ info at:#time put:(words at:5).
+ info at:#user put:(words at:6).
+ info at:#state put:(words at:7).
+ ^ info
+ ].
+ ((words at:1) = '$Revision:') ifTrue:[
+ info at:#revision put:(words at:2).
+ ^ info
+ ].
+ ((words at:1) = '$Id:') ifTrue:[
+ info at:#fileName put:(words at:2).
+ info at:#revision put:(words at:3).
+ info at:#date put:(words at:4).
+ info at:#time put:(words at:5).
+ info at:#user put:(words at:6).
+ info at:#state put:(words at:7).
+ ^ info
+ ].
+ ].
+ ^ nil
"
- Class updateRevisionString
- Number updateRevisionString
- ProcessMonitor updateRevisionString
+ Object revisionString
+ Object revisionInfo
"
- "Created: 29.10.1995 / 19:25:15 / cg"
- "Modified: 29.10.1995 / 19:39:38 / cg"
+ "Created: 11.11.1995 / 14:27:20 / cg"
+ "Modified: 14.11.1995 / 16:00:51 / cg"
!
-pdateRevisionString
+revisionString
+ "return my revision string; that one is extracted from the
+ classes #version method. Either this is a method returning that string,
+ or its a comment-only method and the comment defines the version.
+ If the source is not accessable or no such method exists,
+ nil is returned."
+
+ |cls meta m src lines idx val|
+
+ self isMeta ifTrue:[
+ meta := self. cls := meta soleInstance
+ ] ifFalse:[
+ cls := self. meta := self class
+ ].
+
+ m := meta compiledMethodAt:#version.
+ m isNil ifTrue:[^ nil].
+
+ "/ if its a method returning the string,
+ val := cls version.
+ val isString ifTrue:[^ val].
+
+ src := m source.
+ src isNil ifTrue:[^ nil].
+ lines := src asCollectionOfLines.
+ idx := lines findFirst:[:l |
+ l withoutSpaces startsWith:'$Header'
+ ].
+ idx == 0 ifTrue:[^ nil].
+ ^ lines at:idx.
+
+ "
+ Smalltalk allClassesDo:[:cls |
+ Transcript showCr:cls revisionString
+ ].
+
+ Number revisionString
+ FileDirectory revisionString
+ "
+
+ "Created: 29.10.1995 / 19:28:03 / cg"
+ "Modified: 11.11.1995 / 14:11:41 / cg"
+!
+
+setPrimitiveSpecsAt:index to:aString
+ "set a primitiveSpecification component to aString"
+
+ primitiveSpec isNil ifTrue:[
+ primitiveSpec := Array new:3
+ ].
+ primitiveSpec at:index put:aString
+!
+
+updateRevisionString
"update my revision string, to reflect a change w.r.t.
the original source.
The original revision string is kept as a reference i.e.
@@ -3223,41 +2840,29 @@
"Created: 29.10.1995 / 19:25:15 / cg"
"Modified: 29.10.1995 / 19:39:38 / cg"
-!
-
-sMonitor updateRevisionString
- "
-
- "Created: 29.10.1995 / 19:25:15 / cg"
- "Modified: 29.10.1995 / 19:39:38 / cg"
-!
-
-tPart := (vs copyFrom:(idx + 5)) withoutSpaces.
- idx := rightPart indexOfSeparator.
- idx == 0 ifTrue:[^ self].
- vsnString := rightPart copyTo:idx - 1.
- rightPart := rightPart copyFrom:idx + 1.
- vsnString ~= self revision ifTrue:[
- "/ alread a modified class
-"/ ('already modified: ' , vsnString) printNL.
- ^ self
- ].
- m source:'version
-^ ''' , leftPart , ' ' , vsnString , 'mod' , ' ' , rightPart , ''''.
-
-"/ ('updated to :' , vsnString , 'mod') printNL.
+! !
+
+!Class methodsFor:'queries'!
+
+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
"
- Class updateRevisionString
- Number updateRevisionString
- ProcessMonitor updateRevisionString
+ Point categories
+ Point allCategories
"
-
- "Created: 29.10.1995 / 19:25:15 / cg"
- "Modified: 29.10.1995 / 19:39:38 / cg"
!
-is not sorted by any order."
+categories
+ "Return a Collection of all method-category strings known in class.
+ The returned collection is not sorted by any order."
|newList cat|
@@ -3271,11 +2876,28 @@
"
Point categories
"
-! !
-
-!Class methodsFor:'subclass creation'!
-
-"return true, if this class came into the system via an
+!
+
+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
+ "
+!
+
+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."
@@ -3283,109 +2905,52 @@
^ Autoload wasAutoloaded:self
!
-ames: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
-!
-
-on-float class'
- ].
+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
].
-
- ^ 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
+ ^ nil
+
+ "
+ StandardSystemView whichClassDefinesClassVar:'ErrorSignal'
+ StandardSystemView whichClassDefinesClassVar:'Foo'
+ "
!
--double class'
- ].
+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
].
-
- ^ 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
-!
-
-lass'
- ].
- ].
-
- ^ 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
-!
-
-:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
+ ^ nil
+
+ "
+ StandardSystemView whichClassDefinesInstVar:'label'
+ StandardSystemView whichClassDefinesInstVar:'paint'
+ StandardSystemView whichClassDefinesInstVar:'foo'
+ "
+! !
+
+!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."
@@ -3452,18 +3017,162 @@
category:cat
!
-riableWordSubclass:t
- instanceVariableNames:f
- classVariableNames:d
- poolDictionaries:s
- category:cat
+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
+!
+
+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
- variableSubclass:t
+
+ ^ 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
+!
+
+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
+!
+
+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
+!
+
+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
+!
+
+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
! !
Class initialize!