--- a/SnapShotImageMemory.st Tue Oct 24 20:23:38 2000 +0200
+++ b/SnapShotImageMemory.st Tue Oct 24 20:23:46 2000 +0200
@@ -1,5 +1,3 @@
-'From Smalltalk/X, Version:4.1.1 on 24-Okt-2000 at 12:50:47' !
-
"{ Package: 'cg:private' }"
Object subclass:#SnapShotImageMemory
@@ -17,6 +15,13 @@
privateIn:SnapShotImageMemory
!
+SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:SnapShotImageMemory
+!
+
Object subclass:#SpaceInfo
instanceVariableNames:'start end size flags imageBase'
classVariableNames:''
@@ -25,7 +30,7 @@
!
SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject
- instanceVariableNames:''
+ instanceVariableNames:'cachedContents'
classVariableNames:''
poolDictionaries:''
privateIn:SnapShotImageMemory
@@ -38,13 +43,6 @@
privateIn:SnapShotImageMemory
!
-SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- privateIn:SnapShotImageMemory
-!
-
!SnapShotImageMemory class methodsFor:'instance creation'!
@@ -283,6 +281,14 @@
].
!
+fetchByteArrayFor:aByteArrayRef
+ |nBytes|
+
+ (aByteArrayRef isImageBytes) ifFalse:[self halt].
+
+ nBytes := aByteArrayRef byteSize - (intSize * 3).
+ ^ ((ByteArray new:nBytes) replaceFrom:1 to:nBytes-1 with:aByteArrayRef startingAt:1).!
+
fetchStringFor:aStringRef
|nBytes|
@@ -729,6 +735,9 @@
self halt.
!
+isBehavior
+ ^ self isImageBehavior!
+
isImageBehavior
|flags|
@@ -757,6 +766,9 @@
^ flags bitTest:Behavior flagSymbol
!
+isLazyMethod
+ ^ classRef name = 'LazyMethod'!
+
isMeta
^ false
!
@@ -778,6 +790,12 @@
^ classRef name = 'String'
! !
+!SnapShotImageMemory::ImageByteObject methodsFor:'queries'!
+
+size
+ ^ byteSize
+! !
+
!SnapShotImageMemory::SpaceInfo methodsFor:'accessing'!
end
@@ -830,81 +848,216 @@
start := something.! !
-!SnapShotImageMemory::ImageObject methodsFor:'object protocol'!
-
-at:aSelector ifAbsent:exceptionValue
- |symPtr symRef mthdPtr mthdRef s|
-
- self isMethodDictionary ifTrue:[
- 1 to:self size by:2 do:[:idx |
- symPtr := self at:idx.
- symRef := memory fetchObjectAt:symPtr.
- symRef isImageSymbol ifFalse:[self halt].
- s := memory fetchStringFor:symRef.
- mthdPtr := self at:idx + 1.
- mthdRef := memory fetchObjectAt:mthdPtr.
- ^ mthdRef.
+!SnapShotImageMemory::ImageObject methodsFor:'method protocol'!
+
+byteCode
+ |byteCodeSlotOffset byteCodePtr byteCodeRef byteCode|
+
+ self isMethod ifTrue:[
+ byteCodeSlotOffset := Method instVarOffsetOf:'byteCode'.
+ ].
+ byteCodeSlotOffset notNil ifTrue:[
+ byteCodePtr := self at:byteCodeSlotOffset.
+ byteCodeRef := memory fetchObjectAt:byteCodePtr.
+ byteCodeRef isNil ifTrue:[^ nil].
+
+ byteCode := memory fetchByteArrayFor:byteCodeRef.
+ ^ byteCode
+ ].
+
+ self halt.
+!
+
+comment
+ |src comment comments parser|
+
+ self isMethod ifTrue:[
+ src := self source.
+ src isNil ifTrue:[^ nil].
+
+ parser := Parser for:src in:nil.
+ parser ignoreErrors; ignoreWarnings; saveComments:true.
+ parser parseMethodSpec.
+ comments := parser comments.
+ comments size ~~ 0 ifTrue:[
+ comment := comments first string.
+ (comment withoutSpaces endsWith:'}') ifTrue:[
+ "if first comment is a pragma, take next comment"
+ comment := comments at:2 ifAbsent:nil.
+ comment notNil ifTrue:[
+ comment := comment string.
+ ].
+ ].
].
+ ^ comment.
].
- ^ exceptionValue value
+ self isLazyMethod ifTrue:[
+ ^ ''
+ ].
+
+ self halt.
!
-do:aBlock
- |mthdPtr mthdRef|
-
- self isMethodDictionary ifTrue:[
- 2 to:self size by:2 do:[:idx |
- mthdPtr := self at:idx.
- mthdRef := memory fetchObjectAt:mthdPtr.
- aBlock value:mthdRef.
- ].
+containingClass
+ self isMethodOrLazyMethod ifTrue:[
+ ^ self mclass
].
-!
+ self halt.!
+
+hasCode
+ ^ false!
+
+isBreakpointed
+ ^ false!
+
+isCounting
+ ^ false!
+
+isCountingMemoryUsage
+ ^ false!
+
+isDynamic
+ ^ false!
+
+isExecutable
+ self isMethod ifTrue:[
+ ^ false
+ ].
+ self halt.!
+
+isIgnored
+ ^ false!
+
+isJavaMethod
+ ^ self class name = 'JavaMethod'!
+
+isPrivate
+ ^ false!
+
+isProtected
+ ^ false!
+
+isPublic
+ ^ true!
+
+isTimed
+ ^ false!
+
+isTraced
+ ^ false!
isWrapped
^ false
!
-keysAndValuesDo:aBlock
- |symPtr symRef mthdPtr mthdRef s|
-
- self isMethodDictionary ifTrue:[
- 1 to:self size by:2 do:[:idx |
- symPtr := self at:idx.
- symRef := memory fetchObjectAt:symPtr.
- symRef isImageSymbol ifFalse:[self halt].
- s := memory fetchStringFor:symRef.
- mthdPtr := self at:idx + 1.
- mthdRef := memory fetchObjectAt:mthdPtr.
- aBlock value:s asSymbol value:mthdRef.
+mclass
+ |mclassSlotOffset mclassPtr mclass|
+
+ self isMethod ifTrue:[
+ mclassSlotOffset := Method instVarOffsetOf:'mclass'.
+ mclassPtr := self at:mclassSlotOffset.
+ mclassPtr ~~ 0 ifTrue:[
+ mclass := memory fetchObjectAt:mclassPtr.
+ mclass isImageBehavior ifFalse:[
+ self halt
+ ].
+ ^ mclass
+ ].
+
+ "/ search my class ...
+ memory image allClassesDo:[:eachClass |
+ eachClass theNonMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
+ mthdRef == self ifTrue:[
+ self at:mclassSlotOffset put:eachClass theNonMetaclass.
+ ^ eachClass theNonMetaclass
+ ].
+ ].
+ eachClass theMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
+ mthdRef == self ifTrue:[
+ self at:mclassSlotOffset put:eachClass theMetaclass.
+ ^ eachClass theMetaclass
+ ].
+ ]
].
+ self halt.
].
+ self halt.
!
+numArgs
+ |flagsSlotOffset flagsPtr flags|
+
+ self isMethod ifTrue:[
+ flagsSlotOffset := Method instVarOffsetOf:'flags'.
+ ].
+ flagsSlotOffset notNil ifTrue:[
+ flagsPtr := self at:flagsSlotOffset.
+ flags := memory fetchObjectAt:flagsPtr.
+ ^ (flags bitAnd:(Method numArgsMaskInFlags)) bitShift:(Method numArgsShiftInFlags negated)
+ ].
+
+ self halt.
+!
+
+package
+ |packageSlotOffset packagePtr packageRef package|
+
+ self isImageBehavior ifTrue:[
+ self isMeta ifTrue:[
+ ^ self theNonMetaclass package
+ ].
+ packageSlotOffset := Class instVarOffsetOf:'package'.
+ ].
+ self isMethod ifTrue:[
+ packageSlotOffset := Method instVarOffsetOf:'package'.
+ ].
+ packageSlotOffset notNil ifTrue:[
+ packagePtr := self at:packageSlotOffset.
+ packageRef := memory fetchObjectAt:packagePtr.
+ packageRef isNil ifTrue:[^ nil].
+
+ packageRef isImageSymbol ifFalse:[
+ self halt.
+ ].
+ package := memory fetchStringFor:packageRef.
+ ^ package asSymbol
+ ].
+ self isMeta ifTrue:[
+ self halt
+ ].
+
+ self halt.
+!
+
+previousVersion
+ ^ nil!
+
printStringForBrowserWithSelector:selector
^ selector
!
+privacy
+ ^ #public!
+
resources
^ nil
!
source
- |sourcePosition source aStream junk|
-
- self isMethod ifTrue:[
- sourcePosition := self at:(Method instVarOffsetOf:'sourcePosition').
- source := self at:(Method instVarOffsetOf:'source').
- source := memory fetchObjectAt:source.
- source isString ifFalse:[
+ |sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk|
+
+ self isMethodOrLazyMethod ifTrue:[
+ sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
+ sourcePtr := self at:(Method instVarOffsetOf:'source').
+ sourceRef := memory fetchObjectAt:sourcePtr.
+ sourceRef isString ifFalse:[
self halt.
].
- source := memory printStringOfString:source.
+ source := memory printStringOfString:sourceRef.
+ sourcePosition := memory fetchObjectAt:sourcePositionPtr.
sourcePosition isNil ifTrue:[
- self halt.
^ source
].
- sourcePosition := memory fetchObjectAt:sourcePosition.
aStream := self sourceStream.
aStream notNil ifTrue:[
@@ -922,6 +1075,42 @@
self halt.
!
+sourceFilename
+ "return the sourcefilename if source is extern; nil otherwise"
+
+ self isMethodOrLazyMethod ifTrue:[
+ self sourcePosition notNil ifTrue:[^ self source].
+ ^ nil
+ ].
+ self halt.!
+
+sourceLineNumber
+ self isMethodOrLazyMethod ifTrue:[
+ ^ 1
+ ].
+ self halt.
+!
+
+sourcePosition
+ |sourcePosition|
+
+ self isMethodOrLazyMethod ifTrue:[
+ sourcePosition := self sourcePositionValue.
+ sourcePosition isNil ifTrue:[^ sourcePosition].
+ ^ sourcePosition abs
+ ].
+ self halt.!
+
+sourcePositionValue
+ |sourcePosition sourcePositionPtr|
+
+ self isMethodOrLazyMethod ifTrue:[
+ sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
+ sourcePosition := memory fetchObjectAt:sourcePositionPtr.
+ ^ sourcePosition
+ ].
+ self halt.!
+
sourceStream
|sourcePosition source aStream fileName junk who
myClass mgr className sep dir mod package|
@@ -1037,6 +1226,77 @@
self halt.
! !
+!SnapShotImageMemory::ImageObject methodsFor:'methodDictionary protocol'!
+
+at:aSelector ifAbsent:exceptionValue
+ self isMethodDictionary ifTrue:[
+ cachedContents isNil ifTrue:[
+ self cacheMethodDictionary.
+ ].
+ ^ cachedContents at:aSelector ifAbsent:exceptionValue
+ ].
+ self halt.!
+
+cacheMethodDictionary
+ |symPtr symRef mthdPtr mthdRef s|
+
+ cachedContents isNil ifTrue:[
+ cachedContents := IdentityDictionary new.
+
+ 1 to:self size by:2 do:[:idx |
+ symPtr := self at:idx.
+ symRef := memory fetchObjectAt:symPtr.
+ symRef isImageSymbol ifFalse:[self halt].
+ s := memory fetchStringFor:symRef.
+ mthdPtr := self at:idx + 1.
+ mthdRef := memory fetchObjectAt:mthdPtr.
+ cachedContents at:s asSymbol put:mthdRef.
+ ].
+ ].!
+
+do:aBlock
+ self isMethodDictionary ifTrue:[
+ cachedContents isNil ifTrue:[
+ self cacheMethodDictionary.
+ ].
+ cachedContents do:aBlock.
+ ^ self.
+ ].
+ self halt.
+!
+
+includesKey:aSelector
+ self isMethodDictionary ifTrue:[
+ cachedContents isNil ifTrue:[
+ self cacheMethodDictionary.
+ ].
+ ^ cachedContents includesKey:aSelector
+ ].
+ self halt.!
+
+keyAtValue:aMethod ifAbsent:exceptionValue
+ self isMethodDictionary ifTrue:[
+ cachedContents isNil ifTrue:[
+ self cacheMethodDictionary.
+ ].
+ ^ cachedContents keyAtValue:aMethod ifAbsent:exceptionValue
+ ].
+ self halt.!
+
+keysAndValuesDo:aBlock
+ self isMethodDictionary ifTrue:[
+ cachedContents isNil ifTrue:[
+ self cacheMethodDictionary.
+ ].
+
+ cachedContents keysAndValuesDo:[:sel :mthdRef |
+ aBlock value:sel value:mthdRef.
+ ].
+ ^ self
+ ].
+ self halt.
+! !
+
!SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!
category
@@ -1053,12 +1313,22 @@
!
categorySlot
- ^ self at:8
-!
+ ^ self at:(Class instVarOffsetOf:'category')!
+
+classFilename
+ |classFilenameRef classFilename|
+
+ classFilenameRef := self classFilenameSlot.
+ classFilenameRef isInteger ifTrue:[
+ classFilenameRef := memory fetchObjectAt:classFilenameRef.
+ ].
+ classFilenameRef notNil ifTrue:[
+ classFilename := memory fetchStringFor:classFilenameRef.
+ ].
+ ^ classFilename!
classFilenameSlot
- ^ self at:12
-!
+ ^ self at:(Class instVarOffsetOf:'classFilename')!
classVarNames
|classVarNamesRef classVarNames s|
@@ -1086,6 +1356,19 @@
^ classVarNames
!
+classVariableString
+ |classVarsPtr classVarsRef classVars|
+
+ (classVarsPtr := self classVarsSlot) == 0 ifTrue:[^ ''].
+ classVarsRef := memory fetchObjectAt:classVarsPtr.
+ classVarsRef isImageBytes ifTrue:[
+ "/ a string
+ classVars := memory fetchStringFor:classVarsRef.
+ ^ classVars
+ ].
+ ^ self classVarNames asStringWith:(Character space)
+!
+
classVarsSlot
^ self at:9
!
@@ -1104,8 +1387,7 @@
!
commentSlot
- ^ self at:10
-!
+ ^ self at:(Class instVarOffsetOf:'comment')!
flags
|flags|
@@ -1119,12 +1401,16 @@
!
flagsSlot
- ^ self at:2
-!
+ ^ self at:(Class instVarOffsetOf:'flags')!
+
+instSize
+ |instSizeRef|
+
+ instSizeRef := self instSizeSlot.
+ ^ memory fetchObjectAt:instSizeRef.!
instSizeSlot
- ^ self at:5
-!
+ ^ self at:(Class instVarOffsetOf:'instSize')!
instVarNames
|instVarNamesRef instVarNames s|
@@ -1149,8 +1435,7 @@
].
].
].
- ^ instVarNames
-!
+ ^ instVarNames ? #()!
instVarsSlot
^ self at:6
@@ -1168,12 +1453,15 @@
!
methodDictionarySlot
- ^ self at:3
-!
+ ^ self at:(Class instVarOffsetOf:'methodDictionary')!
name
|nameRef name|
+ self isMeta ifTrue:[
+ ^ self theNonMetaclass name , ' class'
+ ].
+
nameRef := self nameSlot.
nameRef isInteger ifTrue:[
nameRef := memory fetchObjectAt:nameRef.
@@ -1188,13 +1476,39 @@
!
nameSlot
- ^ self at:7
-!
+ ^ self at:(Class instVarOffsetOf:'name')!
packageSlot
- ^ self at:13
+ ^ self at:(Class instVarOffsetOf:'package')!
+
+primitiveSpec
+ |primitiveSpecRef primitiveSpec|
+
+ primitiveSpecRef := self primitiveSpecSlot.
+ primitiveSpecRef isInteger ifTrue:[
+ primitiveSpecRef := memory fetchObjectAt:primitiveSpecRef.
+ ].
+ primitiveSpecRef notNil ifTrue:[
+ primitiveSpec := memory fetchStringFor:primitiveSpecRef.
+ ].
+ ^ primitiveSpec
!
+primitiveSpecSlot
+ ^ self at:(Class instVarOffsetOf:'primitiveSpec')!
+
+revision
+ |revisionRef revision|
+
+ revisionRef := self revisionSlot.
+ revisionRef isInteger ifTrue:[
+ revisionRef := memory fetchObjectAt:revisionRef.
+ ].
+ revisionRef notNil ifTrue:[
+ revision := memory fetchStringFor:revisionRef.
+ ].
+ ^ revision!
+
revisionSlot
^ self at:14
!
@@ -1215,15 +1529,120 @@
!SnapShotImageMemory::ImageClassObject methodsFor:'class protocol'!
+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"
+
+ |classvars superclass|
+
+ (superclass := self superclass) notNil ifTrue:[
+ superclass addAllClassVarNamesTo:aCollection
+ ].
+ (classvars := self classVariableString) notNil ifTrue:[
+ aCollection addAll:(classvars asCollectionOfWords).
+ ].
+ ^ aCollection!
+
+addAllInstVarNamesTo:aCollection
+ |superInsts instvars superclass|
+
+ (superclass := self superclass) notNil ifTrue:[
+ self superclass addAllInstVarNamesTo:aCollection
+ ].
+ aCollection addAll:self instVarNames.
+ ^ aCollection!
+
+addChangeRecordForClassFileOut:aClass!
+
+allClassVarNames
+ "return a collection of all the class variable name-strings
+ this includes all superclass-class variables"
+
+ ^ self addAllClassVarNamesTo:(OrderedCollection new)!
+
+allInstVarNames
+ self superclass isNil ifTrue:[^ self instVarNames].
+ ^ self addAllInstVarNamesTo:(OrderedCollection new)!
+
+allSubclassesDo:aBlock
+ "evaluate aBlock for all of my subclasses.
+ There is no specific order, in which the entries are enumerated.
+ Warning:
+ This will only enumerate globally known classes - for anonymous
+ behaviors, you have to walk over all instances of Behavior."
+
+ self isMeta ifTrue:[
+ "/ metaclasses are not found via Smalltalk allClassesDo:
+ "/ here, walk over classes and enumerate corresponding metas.
+ self soleInstance allSubclassesDo:[:aSubClass |
+ aBlock value:(aSubClass class)
+ ].
+ ] ifFalse:[
+ Smalltalk allClassesDo:[:aClass |
+ (aClass isSubclassOf:self) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+ ]
+
+ "
+ Collection allSubclassesDo:[:c | Transcript showCR:(c name)]
+ Collection class allSubclassesDo:[:c | Transcript showCR:(c name)]
+ "
+
+ "Modified: / 25.10.1997 / 21:17:13 / cg"
+!
+
+allSuperclasses
+ "return a collection of the receivers accumulated superclasses"
+
+ |aCollection theSuperClass|
+
+ theSuperClass := self superclass.
+ theSuperClass isNil ifTrue:[
+ ^ #()
+ ].
+ aCollection := OrderedCollection new.
+ [theSuperClass notNil] whileTrue:[
+ aCollection add:theSuperClass.
+ theSuperClass := theSuperClass superclass
+ ].
+ ^ aCollection
+
+ "
+ String allSuperclasses
+ "!
+
+allSuperclassesDo:aBlock
+ "evaluate aBlock for all of my superclasses"
+
+ |theClass|
+
+ theClass := self superclass.
+ [theClass notNil] whileTrue:[
+ aBlock value:theClass.
+ theClass := theClass superclass
+ ]
+
+ "
+ String allSuperclassesDo:[:c | Transcript showCR:(c name)]
+ "
+!
+
+basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace
+ "append an expression on aStream, which defines myself."
+
+ self
+ basicFileOutDefinitionOn:aStream
+ withNameSpace:forceNameSpace
+ withPackage:true!
+
basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace withPackage:showPackage
"append an expression on aStream, which defines myself."
|s owner ns nsName fullName superName cls topOwner
syntaxHilighting superclass category|
- superclass := self superclass.
- category := self category.
-
UserPreferences isNil ifTrue:[
syntaxHilighting := false
] ifFalse:[
@@ -1261,6 +1680,9 @@
]
].
+ superclass := self superclass.
+ category := self category.
+
"take care of nil-superclass"
superclass isNil ifTrue:[
s := 'nil'
@@ -1384,8 +1806,7 @@
"Created: / 4.1.1997 / 20:38:16 / cg"
"Modified: / 8.8.1997 / 10:59:50 / cg"
- "Modified: / 18.3.1999 / 18:15:46 / stefan"
-!
+ "Modified: / 18.3.1999 / 18:15:46 / stefan"!
basicFileOutInstvarTypeKeywordOn:aStream
"a helper for fileOutDefinition"
@@ -1405,6 +1826,50 @@
"Created: 11.10.1996 / 18:57:29 / cg"
!
+binaryRevision
+ "return the revision-ID from which the class was stc-compiled;
+ nil if its an autoloaded or filedIn class.
+ If a classes binary is up-to-date w.r.t. the source repository,
+ the returned string is the same as the one returned by #revision."
+
+ |owner info c revision|
+
+ revision := self revision.
+
+ (owner := self owningClass) notNil ifTrue:[^ owner binaryRevision].
+ revision notNil ifTrue:[
+ c := revision first.
+ c == $$ ifTrue:[
+ info := Class revisionInfoFromString:revision.
+ info isNil ifTrue:[^ '0'].
+ ^ info at:#revision ifAbsent:'0'.
+ ].
+ c isDigit ifFalse:[
+ ^ '0'
+ ].
+ ].
+
+ ^ revision
+
+ "
+ Object binaryRevision
+ Object class binaryRevision
+ "
+
+ "
+ to find all classes which are not up-to-date:
+
+ |classes|
+
+ classes := Smalltalk allClasses
+ select:[:cls | cls binaryRevision notNil and:[cls binaryRevision ~= cls revision]].
+ SystemBrowser browseClasses:classes title:'classes which are not up-to-date'
+ "
+
+ "Created: 7.12.1995 / 10:58:47 / cg"
+ "Modified: 1.4.1997 / 23:33:01 / stefan"
+ "Modified: 9.9.1997 / 12:05:41 / cg"!
+
compiledMethodAt:aSelector
^ self compiledMethodAt:aSelector ifAbsent:nil
@@ -1426,6 +1891,713 @@
^ Object evaluatorClass
!
+fileOut
+ |baseName dirName nm fileName|
+
+ baseName := (Smalltalk fileNameForClass:self name).
+ nm := baseName asFilename withSuffix:'st'.
+
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ dirName := Project currentProjectDirectory
+ ] ifFalse:[
+ dirName := Filename currentDirectory
+ ].
+ fileName := (dirName asFilename construct:nm).
+ fileName makeLegalFilename.
+
+ self fileOutAs:fileName name.
+
+"/ "
+"/ 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
+
+ "Modified: / 7.6.1996 / 09:14:43 / stefan"
+ "Modified: / 27.8.1998 / 02:02:57 / cg"!
+
+fileOutAllDefinitionsOn:aStream
+ "append expressions on aStream, which defines myself and all of my private classes."
+
+ self fileOutDefinitionOn:aStream.
+ aStream nextPutChunkSeparator.
+ aStream cr; cr.
+
+ "/
+ "/ optional classInstanceVariables
+ "/
+ self classRef instanceVariableString isBlank ifFalse:[
+ self fileOutClassInstVarDefinitionOn:aStream.
+ aStream nextPutChunkSeparator.
+ aStream cr; cr
+ ].
+
+ "/ here, the full nameSpace prefixes are output,
+ "/ to avoid confusing stc
+ "/ (which otherwise could not find the correct superclass)
+ "/
+ Class fileOutNameSpaceQuerySignal answer:true do:[
+ self privateClassesSorted do:[:aClass |
+ aClass fileOutAllDefinitionsOn:aStream
+ ]
+ ].
+
+ "Created: 15.10.1996 / 11:15:19 / cg"
+ "Modified: 22.3.1997 / 16:11:56 / cg"!
+
+fileOutAs:fileNameString
+ "create a file consisting of all methods in myself in
+ sourceForm, from which the class can be reconstructed (by filing in).
+ The given fileName should be a full path, including suffix.
+ 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 fileName newFileName savFilename needRename
+ mySourceFileName sameFile s mySourceFileID anySourceRef|
+
+ self isLoaded ifFalse:[
+ ^ Class fileOutErrorSignal
+ raiseRequestWith:self
+ errorString:'will not fileOut unloaded classes'
+ ].
+
+ fileName := fileNameString asFilename.
+
+ "
+ if file exists, copy the existing to a .sav-file,
+ create the new file as XXX.new-file,
+ and, if that worked rename afterwards ...
+ "
+ (fileName exists) ifTrue:[
+ sameFile := false.
+
+ "/ check carefully - maybe, my source does not really come from that
+ "/ file (i.e. all of my methods have their source as string)
+
+ anySourceRef := false.
+ self methodDictionary do:[:m|
+ m sourcePosition notNil ifTrue:[
+ anySourceRef := true
+ ]
+ ].
+ self classRef methodDictionary do:[:m|
+ m sourcePosition notNil ifTrue:[
+ anySourceRef := true
+ ]
+ ].
+
+ anySourceRef ifTrue:[
+ s := self sourceStream.
+ s notNil ifTrue:[
+ mySourceFileID := s pathName asFilename info id.
+ sameFile := (fileName info id) == mySourceFileID.
+ s close.
+ ] ifFalse:[
+ self 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:self classFilename.
+ sameFile := (fileNameString = mySourceFileName).
+ sameFile ifFalse:[
+ mySourceFileName notNil ifTrue:[
+ sameFile := (fileName info id) == (mySourceFileName asFilename info id)
+ ]
+ ].
+ ]
+ ].
+ ].
+
+ sameFile ifTrue:[
+ ^ Class fileOutErrorSignal
+ raiseRequestWith:fileNameString
+ errorString:('may not overwrite sourcefile:', fileNameString)
+ ].
+
+ savFilename := Filename newTemporary.
+ fileName copyTo:savFilename.
+ newFileName := fileName withSuffix:'new'.
+ needRename := true
+ ] ifFalse:[
+ "/ another possible trap: if my sourceFileName is
+ "/ the same as the written one AND the new files directory
+ "/ is along the sourcePath, we also need a temporary file
+ "/ first, to avoid accessing the newly written file.
+
+ anySourceRef := false.
+ self methodDictionary do:[:m|
+ |mSrc|
+
+ (mSrc := m sourceFilename) notNil ifTrue:[
+ mSrc asFilename baseName = fileName baseName ifTrue:[
+ anySourceRef := true
+ ]
+ ]
+ ].
+ self classRef methodDictionary do:[:m|
+ |mSrc|
+
+ (mSrc := m sourceFilename) notNil ifTrue:[
+ mSrc asFilename baseName = fileName baseName ifTrue:[
+ anySourceRef := true
+ ]
+ ]
+ ].
+ anySourceRef ifTrue:[
+ newFileName := fileName withSuffix:'new'.
+ needRename := true
+ ] ifFalse:[
+ newFileName := fileName.
+ needRename := false
+ ]
+ ].
+
+ aStream := newFileName writeStream.
+ aStream isNil ifTrue:[
+ savFilename notNil ifTrue:[
+ savFilename delete
+ ].
+ ^ Class fileOutErrorSignal
+ raiseRequestWith:newFileName
+ errorString:('cannot create file:', newFileName name)
+ ].
+ self fileOutOn:aStream.
+ aStream close.
+
+ "
+ finally, replace the old-file
+ be careful, if the old one is a symbolic link; in this case,
+ we have to do a copy ...
+ "
+ needRename ifTrue:[
+ newFileName copyTo:fileName.
+ newFileName delete
+ ].
+ savFilename notNil ifTrue:[
+ savFilename 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
+
+ "Modified: / 7.6.1996 / 09:14:43 / stefan"
+ "Created: / 16.4.1997 / 20:44:05 / cg"
+ "Modified: / 12.8.1998 / 11:14:56 / cg"!
+
+fileOutCategory:aCategory
+ "create a file 'class-category.st' consisting of all methods in aCategory.
+ If the current project is not nil, create the file in the projects
+ directory."
+
+ |aStream fileName|
+
+ fileName := (self name , '-' , aCategory , '.st') asFilename.
+ fileName makeLegalFilename.
+
+ "/
+ "/ this test allows a smalltalk to be built without Projects/ChangeSets
+ "/
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory asFilename construct:(fileName name).
+ ].
+
+ "/
+ "/ if the file exists, save original in a .sav file
+ "/
+ fileName exists ifTrue:[
+ fileName copyTo:(fileName withSuffix:'sav')
+ ].
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ Class fileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName pathName)
+ ].
+
+ self fileOutCategory:aCategory on:aStream.
+ aStream close
+
+ "Modified: / 1.4.1997 / 16:00:24 / stefan"
+ "Created: / 1.4.1997 / 16:04:18 / stefan"
+ "Modified: / 28.10.1997 / 14:40:28 / cg"!
+
+fileOutCategory:aCategory except:skippedMethods only:savedMethods methodFilter:methodFilter on:aStream
+ |dict source sortedSelectors first privacy interestingMethods cat|
+
+ dict := self methodDictionary.
+ dict notNil ifTrue:[
+ interestingMethods := OrderedCollection new.
+ dict do:[:aMethod |
+ |wanted|
+
+ (methodFilter isNil
+ or:[methodFilter value:aMethod]) ifTrue:[
+ (aCategory = aMethod category) ifTrue:[
+ skippedMethods notNil ifTrue:[
+ wanted := (skippedMethods includesIdentical:aMethod) not
+ ] ifFalse:[
+ savedMethods notNil ifTrue:[
+ wanted := (savedMethods includesIdentical:aMethod).
+ ] ifFalse:[
+ wanted := true
+ ]
+ ].
+ wanted ifTrue:[interestingMethods add:aMethod].
+ ]
+ ]
+ ].
+ interestingMethods notEmpty ifTrue:[
+ first := true.
+ privacy := nil.
+
+ "/
+ "/ sort by selector
+ "/
+ sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m].
+ sortedSelectors sortWith:interestingMethods.
+
+ interestingMethods do:[:aMethod |
+ first ifFalse:[
+ privacy ~~ aMethod privacy ifTrue:[
+ first := true.
+ aStream space.
+ aStream nextPutChunkSeparator.
+ ].
+ aStream cr; cr
+ ].
+
+ privacy := aMethod privacy.
+
+ first ifTrue:[
+ aStream nextPutChunkSeparator.
+ self printClassNameOn:aStream.
+ privacy ~~ #public ifTrue:[
+ aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
+ ] ifFalse:[
+ aStream nextPutAll:' methodsFor:'.
+ ].
+ cat := aCategory.
+ cat isNil ifTrue:[ cat := '' ].
+ aStream nextPutAll:aCategory asString storeString.
+ aStream nextPutChunkSeparator; cr; cr.
+ first := false.
+ ].
+ source := aMethod source.
+ source isNil ifTrue:[
+ Class fileOutErrorSignal
+ raiseRequestWith:self
+ errorString:'no source for method: ', (aMethod displayString)
+ ] ifFalse:[
+ aStream nextChunkPut:source.
+ ].
+ ].
+ aStream space.
+ aStream nextPutChunkSeparator.
+ aStream cr
+ ]
+ ]
+
+ "Modified: 28.8.1995 / 14:30:41 / claus"
+ "Modified: 12.6.1996 / 11:37:33 / stefan"
+ "Modified: 15.11.1996 / 11:32:21 / cg"
+ "Created: 1.4.1997 / 16:04:33 / stefan"!
+
+fileOutCategory:aCategory methodFilter:methodFilter on:aStream
+ "file out all methods belonging to aCategory, aString onto aStream"
+
+ self fileOutCategory:aCategory except:nil only:nil methodFilter:methodFilter on:aStream!
+
+fileOutCategory:aCategory on:aStream
+ Class fileOutNameSpaceQuerySignal answer:true do:[
+ self fileOutCategory:aCategory except:nil only:nil methodFilter:nil on:aStream
+ ]!
+
+fileOutClassInstVarDefinitionOn:aStream withNameSpace:withNameSpace
+ "append an expression to define my classInstanceVariables on aStream"
+
+ |anySuperClassInstVar|
+
+ self isLoaded ifFalse:[
+ ^ self basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
+ ].
+
+ withNameSpace ifTrue:[
+ self name printOn:aStream.
+ ] ifFalse:[
+ self printClassNameOn:aStream.
+ ].
+ aStream nextPutAll:' class instanceVariableNames:'''.
+ self class printInstVarNamesOn:aStream indent:8.
+ aStream nextPutAll:''''.
+
+ "mhmh - good idea; saw this in SmallDraw sourcecode ..."
+
+ anySuperClassInstVar := false.
+ self allSuperclassesDo:[:aSuperClass |
+ aSuperClass class instVarNames do:[:ignored | anySuperClassInstVar := true].
+ ].
+
+ aStream cr; cr; nextPut:(Character doubleQuote); cr; space.
+ anySuperClassInstVar ifFalse:[
+ aStream
+ nextPutLine:'No other class instance variables are inherited by this class.'.
+ ] ifTrue:[
+ aStream
+ nextPutLine:'The following class instance variables are inherited by this class:'.
+ aStream cr.
+ self allSuperclassesDo:[:aSuperClass |
+ aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
+ aStream nextPutLine:(aSuperClass class instanceVariableString).
+ ].
+
+ ].
+ aStream nextPut:(Character doubleQuote); cr.
+
+ "Created: / 10.12.1995 / 16:31:25 / cg"
+ "Modified: / 1.4.1997 / 16:00:33 / stefan"
+ "Modified: / 3.2.2000 / 23:05:28 / cg"
+!
+
+fileOutDefinitionOn:aStream
+ "append an expression on aStream, which defines myself."
+
+ ^ self basicFileOutDefinitionOn:aStream withNameSpace:false!
+
+fileOutMethod:aMethod
+ |aStream fileName selector|
+
+ selector := self selectorAtMethod:aMethod.
+ selector notNil ifTrue:[
+ fileName := (self name , '-' , selector, '.st') asFilename.
+ fileName makeLegalFilename.
+
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory asFilename construct:fileName name.
+ ].
+
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName exists ifTrue:[
+ fileName copyTo:(fileName withSuffix: 'sav')
+ ].
+
+ fileName := fileName name.
+
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ Class fileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName)
+ ].
+ self fileOutMethod:aMethod on:aStream.
+ aStream close
+ ]
+
+ "Modified: / 1.4.1997 / 16:00:57 / stefan"
+ "Created: / 2.4.1997 / 00:24:28 / stefan"
+ "Modified: / 28.10.1997 / 14:40:34 / cg"!
+
+fileOutMethod:aMethod on:aStream
+ |dict cat source privacy|
+
+ dict := self methodDictionary.
+ dict notNil ifTrue:[
+ aStream nextPutChunkSeparator.
+ self name printOn:aStream.
+"/ self printClassNameOn:aStream.
+
+ (privacy := aMethod privacy) ~~ #public ifTrue:[
+ aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
+ ] ifFalse:[
+ aStream nextPutAll:' methodsFor:'.
+ ].
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := ''
+ ].
+ aStream nextPutAll:cat asString storeString.
+ aStream nextPutChunkSeparator; cr; cr.
+ source := aMethod source.
+ source isNil ifTrue:[
+ Class fileOutErrorSignal
+ raiseRequestWith:self
+ errorString:('no source for method: ' ,
+ self name , '>>' ,
+ (self selectorAtMethod:aMethod))
+ ] ifFalse:[
+ aStream nextChunkPut:source.
+ ].
+ aStream space.
+ aStream nextPutChunkSeparator.
+ aStream cr
+ ]
+
+ "Modified: 27.8.1995 / 01:23:19 / claus"
+ "Modified: 12.6.1996 / 11:44:41 / stefan"
+ "Modified: 15.11.1996 / 11:32:43 / cg"
+ "Created: 2.4.1997 / 00:24:33 / stefan"!
+
+fileOutOn:aStream
+
+ ^ self fileOutOn:aStream withTimeStamp:true!
+
+fileOutOn:aStream withTimeStamp:stampIt
+ "file out my definition and all methods onto aStream.
+ If stampIt is true, a timeStamp comment is prepended."
+
+ self fileOutOn:aStream withTimeStamp:stampIt withInitialize:true!
+
+fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt
+ "file out my definition and all methods onto aStream.
+ If stampIt is true, a timeStamp comment is prepended.
+ If initIt is true, and the class implements a class-initialize method,
+ append a corresponding doIt expression for initialization."
+
+ self
+ fileOutOn:aStream
+ withTimeStamp:stampIt
+ withInitialize:initIt
+ withDefinition:true
+ methodFilter:nil!
+
+fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter
+ "file out my definition and all methods onto aStream.
+ If stampIt is true, a timeStamp comment is prepended.
+ If initIt is true, and the class implements a class-initialize method,
+ append a corresponding doIt expression for initialization.
+ The order by which the fileOut is done is used to put the version string at the end.
+ Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
+
+ |collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods
+ meta|
+
+ self isLoaded ifFalse:[
+ ^ Class fileOutErrorSignal
+ raiseRequestWith:self
+ errorString:'will not fileOut unloaded classes'
+ ].
+
+ meta := self classRef.
+
+ "
+ if there is a copyright method, add a copyright comment
+ at the beginning, taking the string from the copyright method.
+ We cannot do this unconditionally - that would lead to my copyrights
+ being put on your code ;-).
+ On the other hand: I want every file created by myself to have the
+ copyright string at the beginning be preserved .... even if the
+ code was edited in the browser and filedOut.
+ "
+ (copyrightMethod := meta compiledMethodAt:#copyright) notNil ifTrue:[
+ "
+ get the copyright methods source,
+ and insert at beginning.
+ "
+ copyrightText := copyrightMethod source.
+ copyrightText isNil ifTrue:[
+ "
+ no source available - trigger an error
+ "
+ Class fileOutErrorSignal
+ raiseRequestWith:'no source for class ' , self name , ' available. Cannot fileOut'.
+ ^ self
+ ].
+ "
+ strip off the selector-line
+ "
+ copyrightText := copyrightText asCollectionOfLines asStringCollection.
+ copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
+"/ copyrightText do:[:line | aStream nextPutAll:line. aStream cr.].
+ copyrightText := copyrightText asString.
+ aStream nextPutAllAsChunk:copyrightText.
+ ].
+
+ stampIt ifTrue:[
+ "/
+ "/ first, a timestamp
+ "/
+ aStream nextPutAll:(Smalltalk timeStamp).
+ aStream nextPutChunkSeparator.
+ aStream cr; cr.
+ ].
+
+ withDefinition ifTrue:[
+ "/
+ "/ then the definition
+ "/
+ self fileOutAllDefinitionsOn:aStream.
+ "/
+ "/ a comment - if any
+ "/
+ (comment := self comment) notNil ifTrue:[
+ self fileOutCommentOn:aStream.
+ aStream cr.
+ ].
+ "/
+ "/ primitive definitions - if any
+ "/
+ self fileOutPrimitiveSpecsOn:aStream.
+ ].
+
+ "/
+ "/ methods from all categories in metaclass (i.e. class methods)
+ "/ EXCEPT: the version method is placed at the very end, to
+ "/ avoid sourcePosition-shifts when checked out later.
+ "/ (RCS expands this string, so its size is not constant)
+ "/
+ collectionOfCategories := meta categories asSortedCollection.
+ collectionOfCategories notNil ifTrue:[
+ "/
+ "/ documentation first (if any), but not the version method
+ "/
+ (collectionOfCategories includes:'documentation') ifTrue:[
+ versionMethod := meta compiledMethodAt:#version.
+ versionMethod notNil ifTrue:[
+ skippedMethods := Array with:versionMethod
+ ].
+ meta fileOutCategory:'documentation' except:skippedMethods only:nil methodFilter:methodFilter on:aStream.
+ aStream cr.
+ ].
+
+ "/
+ "/ initialization next (if any)
+ "/
+ (collectionOfCategories includes:'initialization') ifTrue:[
+ meta fileOutCategory:'initialization' methodFilter:methodFilter on:aStream.
+ aStream cr.
+ ].
+
+ "/
+ "/ instance creation next (if any)
+ "/
+ (collectionOfCategories includes:'instance creation') ifTrue:[
+ meta fileOutCategory:'instance creation' methodFilter:methodFilter on:aStream.
+ aStream cr.
+ ].
+ collectionOfCategories do:[:aCategory |
+ ((aCategory ~= 'documentation')
+ and:[(aCategory ~= 'initialization')
+ and:[aCategory ~= 'instance creation']]) ifTrue:[
+ meta fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
+ aStream cr
+ ]
+ ]
+ ].
+
+ "/
+ "/ methods from all categories in myself
+ "/
+ collectionOfCategories := self categories asSortedCollection.
+ collectionOfCategories notNil ifTrue:[
+ collectionOfCategories do:[:aCategory |
+ self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
+ aStream cr
+ ]
+ ].
+
+ "/
+ "/ any private classes' methods
+ "/
+ self privateClassesSorted do:[:aClass |
+ aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
+ ].
+
+
+ "/
+ "/ finally, the previously skipped version method
+ "/
+ versionMethod notNil ifTrue:[
+ meta fileOutCategory:'documentation' except:nil only:skippedMethods methodFilter:methodFilter on:aStream.
+ ].
+
+ initIt ifTrue:[
+ "/
+ "/ optionally an initialize message
+ "/
+ (meta implements:#initialize) ifTrue:[
+ self printClassNameOn:aStream. aStream nextPutAll:' initialize'.
+ aStream nextPutChunkSeparator.
+ aStream cr
+ ]
+ ]
+
+ "Created: / 15.11.1995 / 12:53:06 / cg"
+ "Modified: / 1.4.1997 / 16:01:05 / stefan"
+ "Modified: / 13.3.1998 / 12:23:59 / cg"!
+
+fileOutPrimitiveDefinitionsOn:aStream
+ "append primitive defs (if any) to aStream."
+
+ |s|
+
+ "
+ primitive definitions - if any
+ "
+ (s := self primitiveDefinitionsString) notNil ifTrue:[
+ aStream nextPutChunkSeparator.
+ self printClassNameOn:aStream.
+ aStream nextPutAll:' primitiveDefinitions';
+ nextPutChunkSeparator;
+ cr.
+ aStream nextPutAll:s.
+ aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+ ].
+ (s := self primitiveVariablesString) notNil ifTrue:[
+ aStream nextPutChunkSeparator.
+ self printClassNameOn:aStream.
+ aStream nextPutAll:' primitiveVariables';
+ nextPutChunkSeparator;
+ cr.
+ aStream nextPutAll:s.
+ aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+ ].
+
+ "Modified: 8.1.1997 / 17:45:40 / cg"!
+
+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.
+ self printClassNameOn:aStream.
+ aStream nextPutAll:' primitiveFunctions';
+ nextPutChunkSeparator;
+ cr.
+ aStream nextPutAll:s.
+ aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+ ].
+
+ "Modified: 8.1.1997 / 17:45:51 / cg"!
+
firstDefinitionSelectorPart
"return the first part of the selector with which I was (can be) defined in my superclass"
@@ -1462,6 +2634,89 @@
^ #'variableSubclass:'
!
+getPrimitiveSpecsAt:index
+ "{ Pragma: +optSpace }"
+
+ "return a primitiveSpecification component as string or nil"
+
+ |owner pos stream string primitiveSpec classFilename|
+
+ (owner := self owningClass) notNil ifTrue:[^ owner getPrimitiveSpecsAt:index].
+
+ primitiveSpec := self primitiveSpec.
+
+ 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 := self classFilename.
+ classFilename notNil ifTrue:[
+ stream := self sourceStream.
+ stream notNil ifTrue:[
+ stream position:pos+1.
+ string := stream nextChunk.
+ stream close.
+ ^ string
+ ]
+ ].
+ ^ nil
+ ].
+ ^ pos
+
+ "Modified: 15.1.1997 / 15:29:30 / stefan"!
+
+hasMethods
+ "return true, if there are any (local) methods in this class"
+
+ ^ (self methodDictionary size ~~ 0)!
+
+implements:aSelector
+ ^ self includesSelector:aSelector!
+
+includesSelector:aSelector
+ ^ self methodDictionary includesKey:aSelector!
+
+instanceVariableString
+ "return a string of the instance variable names"
+
+ |instvars|
+
+ instvars := self instVarNames.
+ instvars isNil ifTrue:[^ ''].
+ instvars isString ifTrue:[
+ ^ instvars
+ ].
+
+ ^ instvars asStringWith:(Character space)
+
+ "
+ Point instanceVariableString
+ "
+
+ "Modified: 22.8.1997 / 14:59:14 / cg"
+!
+
+isObsolete
+ ^ false
+!
+
+isSubclassOf:aClass
+ "return true, if I am a subclass of the argument, aClass"
+
+ |theClass|
+
+ theClass := self superclass.
+ [theClass notNil] whileTrue:[
+ (theClass == aClass) ifTrue:[^ true].
+ theClass := theClass superclass.
+ ].
+ ^ false
+!
+
nameWithoutNameSpacePrefix
|nm owner|
@@ -1484,6 +2739,194 @@
^ nm copyFrom:idx+1.
!
+packageSourceCodeInfo
+ "{ Pragma: +optSpace }"
+
+ "return the sourceCodeInfo, which defines the module and the subdirectory
+ in which the receiver class was built.
+ This info is extracted from the package id (which is added to stc-compiled classes).
+ This method is to be obsoleted soon, since the same info is now found
+ in the versionString.
+
+ 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.
+ (this happens with autoloaded and filed-in classes)
+ Auotloaded classes set their package from the revisionInfo, if present.
+
+ By convention, this info is encoded in the classes package
+ string (which is given as argument to stc) as the last word in parenthesis.
+ 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
+ '....(stx:foo:libbfoo)' -> module: stx directory: foo library: libfoo
+ '....(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.
+ "
+
+ |owner sourceInfo packageString idx1 idx2
+ moduleString directoryString libraryString components component1 component2 dirComponents mgr
+ package|
+
+ (owner := self owningClass) notNil ifTrue:[^ owner packageSourceCodeInfo].
+
+ package := self package.
+ 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
+ ]
+ ] ifFalse:[
+ sourceInfo := packageString
+ ].
+
+ sourceInfo isNil ifTrue:[^ nil].
+ components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
+ components size == 0 ifTrue:[
+"/ moduleString := 'stx'.
+"/ directoryString := libraryString := ''.
+ ^ nil
+ ].
+
+ component1 := components at:1.
+ components size == 1 ifTrue:[
+ "/ a single name given - the module becomes 'stx' or
+ "/ the very first directory component (if such a module exists).
+ "/ If the component includes slashes, its the directory
+ "/ otherwise the library.
+ "/
+ dirComponents := Filename concreteClass components:component1.
+ (dirComponents size > 1
+ and:[(mgr := self sourceCodeManager) notNil
+ and:[mgr checkForExistingModule:dirComponents first]]) ifTrue:[
+ moduleString := dirComponents first.
+ directoryString := libraryString := (Filename fromComponents:(dirComponents copyFrom:2)) asString.
+ ] ifFalse:[
+ "/ non-existing; assume directory under the stx package.
+ moduleString := 'stx'.
+ (component1 startsWith:'stx/') ifTrue:[
+ component1 := component1 copyFrom:5
+ ].
+ directoryString := libraryString := component1.
+ ].
+
+ (libraryString includes:$/) ifTrue:[
+ libraryString := libraryString asFilename baseName
+ ]
+ ] ifFalse:[
+ component2 := components at:2.
+ components size == 2 ifTrue:[
+ "/ two components - assume its the module and the directory;
+ "/ the library is assumed to be named after the directory
+ "/ except, if slashes are in the name; then the libraryname
+ "/ is the last component.
+ "/
+ moduleString := component1.
+ directoryString := libraryString := component2.
+ (libraryString includes:$/) ifTrue:[
+ libraryString := libraryString asFilename baseName
+ ]
+ ] ifFalse:[
+ "/ all components given
+ moduleString := component1.
+ directoryString := component2.
+ 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 packageSourceCodeInfo
+ View packageSourceCodeInfo
+ Model packageSourceCodeInfo
+ BinaryObjectStorage packageSourceCodeInfo
+ MemoryMonitor packageSourceCodeInfo
+ ClockView packageSourceCodeInfo
+ "
+
+ "Created: 4.11.1995 / 20:36:53 / cg"
+ "Modified: 19.9.1997 / 10:42:25 / cg"!
+
+primitiveDefinitionsString
+ "{ Pragma: +optSpace }"
+
+ "return the primitiveDefinition string or nil"
+
+ ^ self getPrimitiveSpecsAt:1
+
+ "
+ Object primitiveDefinitionsString
+ String primitiveDefinitionsString
+ "!
+
+primitiveFunctionsString
+ "{ Pragma: +optSpace }"
+
+ "return the primitiveFunctions string or nil"
+
+ ^ self getPrimitiveSpecsAt:3!
+
+primitiveVariablesString
+ "{ Pragma: +optSpace }"
+
+ "return the primitiveVariables string or nil"
+
+ ^ self getPrimitiveSpecsAt:2!
+
+printClassNameOn:aStream
+ |nm|
+
+ Class fileOutNameSpaceQuerySignal query == false ifTrue:[
+ nm := self nameWithoutNameSpacePrefix
+ ] ifFalse:[
+ nm := self name.
+ ].
+
+ aStream nextPutAll:nm.!
+
printClassVarNamesOn:aStream indent:indent
"print the class variable names indented and breaking at line end"
@@ -1571,6 +3014,14 @@
^ self name
!
+privateClasses
+ "{ Pragma: +optSpace }"
+
+ "return a collection of my private classes (if any).
+ The classes are in any order."
+
+ ^ self privateClassesOrAll:false!
+
privateClassesAt:aClassNameStringOrSymbol
|nmSym|
@@ -1583,14 +3034,427 @@
^ memory at:nmSym.
!
+privateClassesOrAll:allOfThem
+ "{ Pragma: +optSpace }"
+
+ "return a collection of my direct private classes (if any)
+ or direct plus indirect private classes (if allOfThem).
+ An empty collection if there are none.
+ The classes are in any order."
+
+ |classes myName myNamePrefix myNamePrefixLen|
+
+ myName := self name.
+ myNamePrefix := myName , '::'.
+ myNamePrefixLen := myNamePrefix size.
+
+ Smalltalk keysDo:[:nm |
+ |cls|
+
+ (nm startsWith:myNamePrefix) ifTrue:[
+ (allOfThem
+ or:[(nm indexOf:$: startingAt:myNamePrefixLen + 1) == 0]) ifTrue:[
+ cls := Smalltalk at:nm.
+
+ (cls isBehavior and:[cls isMeta not]) ifTrue:[
+ classes isNil ifTrue:[
+ classes := IdentitySet new:10.
+ ].
+ classes add:cls.
+ ]
+ ]
+ ]
+ ].
+
+ ^ classes ? #()
+
+ "
+ UILayoutTool privateClassesOrAll:true
+ UILayoutTool privateClassesOrAll:false
+ "
+
+ "Modified: / 29.5.1998 / 23:23:18 / cg"!
+
+privateClassesSorted
+ "{ Pragma: +optSpace }"
+
+ "return a collection of my private classes (if any).
+ The classes are sorted by inheritance."
+
+ |classes|
+
+ classes := self privateClasses.
+ (classes size > 0) ifTrue:[
+ classes := classes asOrderedCollection topologicalSort:[:a :b | b isSubclassOf:a].
+ ].
+ ^ classes.
+
+ "
+ Object privateClassesSorted
+ "
+
+ "Created: 22.3.1997 / 16:10:42 / cg"
+ "Modified: 22.3.1997 / 16:11:20 / cg"!
+
+revisionInfo
+ "return a dictionary filled with revision info.
+ This extracts the relevant info from the revisionString.
+ The revisionInfo contains all or a subset of:
+ #binaryRevision - the revision upon which the binary of this class is based
+ #revision - the revision upon which the class is based logically
+ (different, if a changed class was checked in, but not yet recompiled)
+ #user - the user who checked in the logical revision
+ #date - the date when the logical revision was checked in
+ #time - the time when the logical revision was checked in
+ #fileName - the classes source file name
+ #repositoryPath - the classes source container
+ "
+
+ |vsnString info mgr|
+
+ vsnString := self revisionString.
+ vsnString notNil ifTrue:[
+ mgr := self sourceCodeManager.
+ mgr notNil ifTrue:[
+ info := mgr revisionInfoFromString:vsnString
+ ] ifFalse:[
+ info := Class revisionInfoFromString:vsnString.
+ ].
+ info notNil ifTrue:[
+ info at:#binaryRevision put:self binaryRevision.
+ ]
+ ].
+ ^ info!
+
+revisionString
+ "{ Pragma: +optSpace }"
+
+ "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."
+
+ |owner cls meta m src val|
+
+ (owner := self owningClass) notNil ifTrue:[^ owner revisionString].
+
+ thisContext isRecursive ifTrue:[^ nil ].
+
+ self isMeta ifTrue:[
+ meta := self. cls := self soleInstance
+ ] ifFalse:[
+ cls := self. meta := self classRef
+ ].
+
+ m := meta compiledMethodAt:#version.
+ m isNil ifTrue:[
+ m := cls compiledMethodAt:#version.
+ m isNil ifTrue:[^ nil].
+ ].
+
+ m isExecutable ifTrue:[
+ "/
+ "/ if its a method returning the string,
+ "/ thats the returned value
+ "/
+ val := cls version.
+ val isString ifTrue:[^ val].
+ ].
+
+ "/
+ "/ if its a method consisting of a comment only
+ "/ extract it - this may lead to a recursive call
+ "/ to myself (thats what the #isRecursive is for)
+ "/ in case we need to access the source code manager
+ "/ for the source ...
+ "/
+ src := m source.
+ src isNil ifTrue:[^ nil].
+ ^ Class revisionStringFromSource:src
+
+ "
+ Smalltalk allClassesDo:[:cls |
+ Transcript showCR:cls revisionString
+ ].
+
+ Number revisionString
+ FileDirectory revisionString
+ Metaclass revisionString
+ "
+
+ "Created: 29.10.1995 / 19:28:03 / cg"
+ "Modified: 23.10.1996 / 18:23:56 / cg"
+ "Modified: 1.4.1997 / 23:37:25 / stefan"!
+
+selectorAtMethod:aMethod
+ ^ self selectorAtMethod:aMethod ifAbsent:[nil]!
+
+selectorAtMethod:aMethod ifAbsent:failBlock
+ |md|
+
+ md := self methodDictionary.
+ md isNil ifTrue:[
+ 'OOPS - nil methodDictionary' errorPrintCR.
+ ^ nil
+ ].
+ ^ md keyAtValue:aMethod ifAbsent:failBlock.!
+
+soleInstance
+ self isMeta ifFalse:[self halt].
+ ^ self theNonMetaclass.
+!
+
sourceCodeManager
^ SourceCodeManager
!
+sourceStreamFor:source
+ "return an open stream on a sourcefile, nil if that is not available"
+
+ |owner fileName aStream mgr validated guessedFileName sep mod dir classFilename package name|
+
+ self isMeta ifTrue:[
+ ^ self theNonMetaclass sourceStreamFor:source
+ ].
+
+ (owner := self owningClass) notNil ifTrue:[^ owner sourceStreamFor:source].
+ validated := false.
+
+ classFilename := self classFilename.
+ package := self package.
+ name := self name.
+
+ "/
+ "/ if there is no SourceCodeManager,
+ "/ or TryLocalSourceFirst is true,
+ "/ look in standard places first
+ "/
+ ((mgr := self sourceCodeManager) isNil
+ or:[Class tryLocalSourceFirst == true]) ifTrue:[
+ aStream := self localSourceStreamFor:source.
+ ].
+
+ 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.
+ "/ if that one does not know about the source, look in
+ "/ standard places
+
+ mgr notNil ifTrue:[
+ self classFilename ~= source ifTrue:[
+ sep := self package indexOfAny:'/\:'.
+ sep ~~ 0 ifTrue:[
+ mod := package copyTo:sep - 1.
+ dir := package copyFrom:sep + 1.
+ aStream := mgr streamForClass:nil fileName:source revision:nil directory:dir module:mod cache:true.
+ ].
+ ].
+ aStream isNil ifTrue:[
+ classFilename isNil ifTrue:[
+ classFilename := guessedFileName := (Smalltalk fileNameForClass:self) , '.st'.
+ ].
+ source asFilename baseName = classFilename asFilename baseName ifTrue:[
+ aStream := mgr getSourceStreamFor:self.
+ ]
+ ].
+ aStream notNil ifTrue:[
+ (self validateSourceStream:aStream) ifFalse:[
+ ('Class [info]: repositories source for `'
+ , (self isMeta ifTrue:[self soleInstance name]
+ ifFalse:[name])
+ , ''' is invalid.') infoPrintCR.
+ aStream close.
+ aStream := nil
+ ] ifTrue:[
+ validated := true.
+ ].
+ ].
+ ]
+ ].
+
+ aStream isNil ifTrue:[
+ "/
+ "/ hard case - there is no source file for this class
+ "/ (in the source-dir-path).
+ "/
+
+ "/
+ "/ 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 classes|
+
+ aStream isNil ifTrue:[
+ (classes := h classes) size > 0 ifTrue:[
+ (classes includes:self) ifTrue:[
+ f := h pathName.
+ f := f asFilename directory.
+ f := f construct:source.
+ f exists ifTrue:[
+ aStream := f readStream.
+ ].
+ ].
+ ].
+ ]
+ ].
+ ].
+ ].
+
+ "/
+ "/ try along sourcePath
+ "/
+ aStream isNil ifTrue:[
+ aStream := self localSourceStreamFor:source.
+ ].
+
+ "/
+ "/ final chance: try current directory
+ "/
+ aStream isNil ifTrue:[
+ aStream := source asFilename readStream.
+ ].
+
+ (aStream notNil and:[validated not]) ifTrue:[
+ (self validateSourceStream:aStream) ifFalse:[
+ (Smalltalk releaseIdentification = 'ST/X_free_demo_vsn') ifTrue:[
+"/ ('Class [info]: source for ''' , self name , ''' is not available in the demo version.') infoPrintCR
+ ] ifFalse:[
+ ('Class [warning]: source for ''' , self name , ''' is invalid or stripped. Take care.') errorPrintCR
+ ]
+ ].
+ ].
+ (aStream notNil and:[aStream isFileStream]) ifTrue:[
+ guessedFileName notNil ifTrue:[
+ classFilename := aStream pathName asFilename baseName.
+ ]
+ ].
+ ^ aStream
+
+ "
+ Object sourceStream
+ Clock sourceStream
+ Autoload sourceStream
+ "
+
+ "Created: / 10.11.1995 / 21:05:13 / cg"
+ "Modified: / 22.4.1998 / 19:20:50 / ca"
+ "Modified: / 23.4.1998 / 15:53:54 / cg"
+!
+
+subclasses
+ "return a collection of the direct subclasses of the receiver"
+
+ |newColl|
+
+"/ "/ use cached information (avoid class hierarchy search)
+"/ "/ if possible
+"/
+"/ SubclassInfo notNil ifTrue:[
+"/ newColl := SubclassInfo at:self ifAbsent:nil.
+"/ newColl notNil ifTrue:[^ newColl asOrderedCollection]
+"/ ].
+
+ newColl := OrderedCollection new.
+ self subclassesDo:[:aClass |
+ newColl add:aClass
+ ].
+"/ SubclassInfo notNil ifTrue:[
+"/ SubclassInfo at:self put:newColl.
+"/ ].
+ ^ newColl
+!
+
+subclassesDo:aBlock
+ "evaluate the argument, aBlock for all immediate subclasses.
+ This will only enumerate globally known classes - for anonymous
+ behaviors, you have to walk over all instances of Behavior."
+
+ |coll|
+
+ self isMeta ifTrue:[
+ self halt.
+ "/ metaclasses are not found via Smalltalk allClassesDo:
+ "/ here, walk over classes and enumerate corresponding metas.
+ self soleInstance subclassesDo:[:aSubClass |
+ aBlock value:(aSubClass class)
+ ].
+ ^ self
+ ].
+
+ "/ use cached information (avoid class hierarchy search)
+ "/ if possible
+
+"/ SubclassInfo isNil ifTrue:[
+"/ Behavior subclassInfo
+"/ ].
+"/ SubclassInfo notNil ifTrue:[
+"/ coll := SubclassInfo at:self ifAbsent:nil.
+"/ coll notNil ifTrue:[
+"/ coll do:aBlock.
+"/ ].
+"/ ^ self
+"/ ].
+
+ Smalltalk allClassesDo:[:aClass |
+ (aClass superclass == self) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+
+ "
+ Collection subclassesDo:[:c | Transcript showCR:(c name)]
+ "
+
+ "Modified: 22.1.1997 / 18:44:01 / cg"
+!
+
syntaxHighlighterClass
^ Object syntaxHighlighterClass
!
+theMetaclass
+ self isMeta ifTrue:[^ self].
+ ^ self classRef.!
+
+theNonMetaclass
+ |instSlotOffs clsPtr|
+
+ self isMeta ifFalse:[^ self].
+ instSlotOffs := Metaclass instVarOffsetOf:'myClass'.
+ clsPtr := self at:instSlotOffs.
+ ^ memory fetchObjectAt:clsPtr.
+!
+
+validateSourceStream:aStream
+ "check if aStream really contains my source.
+ This is done by checking the version methods return value
+ against the version string as contained in the version method"
+
+ ^ true!
+
+withAllSuperclasses
+ "return a collection containing the receiver and all
+ of the receivers accumulated superclasses"
+
+ |aCollection theSuperClass|
+
+ aCollection := OrderedCollection with:self.
+ theSuperClass := self superclass.
+ [theSuperClass notNil] whileTrue:[
+ aCollection add:theSuperClass.
+ theSuperClass := theSuperClass superclass
+ ].
+ ^ aCollection
+
+ "
+ String withAllSuperclasses
+ "!
+
withAllSuperclassesDo:aBlock
|sc|
@@ -1644,9 +3508,8 @@
!
isMeta
- ^ self size == (Metaclass instSize * memory ptrSize).
-"/ ^ classRef classRef name = 'Metaclass'
-!
+ ^ self size == (Metaclass instSize).
+"/ ^ classRef classRef name = 'Metaclass'!
isPrivate
^ classRef isPrivateMeta
@@ -1680,6 +3543,7 @@
|env name idx nsName|
"/ (env := self environment) notNil ifTrue:[^ env].
+ env := Smalltalk. "/ default
name := self name.
idx := name lastIndexOf:$:.
idx ~~ 0 ifTrue:[
@@ -1723,12 +3587,6 @@
^ false
! !
-!SnapShotImageMemory::ImageByteObject methodsFor:'queries'!
-
-size
- ^ byteSize
-! !
-
!SnapShotImageMemory class methodsFor:'documentation'!
version