--- a/SnapShotImageMemory.st Mon Oct 23 19:41:18 2000 +0200
+++ b/SnapShotImageMemory.st Tue Oct 24 13:17:22 2000 +0200
@@ -1,13 +1,22 @@
+'From Smalltalk/X, Version:4.1.1 on 24-Okt-2000 at 12:50:47' !
+
"{ Package: 'cg:private' }"
Object subclass:#SnapShotImageMemory
- instanceVariableNames:'stream msb ptrSize intSize intTag spaceInfos symbolEntries
+ instanceVariableNames:'image stream msb ptrSize intSize intTag spaceInfos symbolEntries
globalEntries addrToObjectMapping'
classVariableNames:''
poolDictionaries:''
category:'System-Support'
!
+Object subclass:#ImageHeader
+ instanceVariableNames:'memory classRef bits byteSize'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:SnapShotImageMemory
+!
+
Object subclass:#SpaceInfo
instanceVariableNames:'start end size flags imageBase'
classVariableNames:''
@@ -15,8 +24,8 @@
privateIn:SnapShotImageMemory
!
-Object variableSubclass:#ImageObject
- instanceVariableNames:'classRef size bits'
+SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject
+ instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:SnapShotImageMemory
@@ -29,6 +38,13 @@
privateIn:SnapShotImageMemory
!
+SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:SnapShotImageMemory
+!
+
!SnapShotImageMemory class methodsFor:'instance creation'!
@@ -60,12 +76,43 @@
globalEntries:something
"set the value of the instance variable 'globalEntries' (automatically generated)"
- globalEntries := something.! !
+ globalEntries := something.!
+
+image
+
+ ^ image
+!
+
+image:something
+
+ image := something.
+!
+
+ptrSize
+ "return the value of the instance variable 'ptrSize' (automatically generated)"
+
+ ^ ptrSize!
+
+ptrSize:something
+ "set the value of the instance variable 'ptrSize' (automatically generated)"
+
+ ptrSize := something.! !
!SnapShotImageMemory methodsFor:'object access'!
+fetchByteAt:addr
+ |byte imgAddr|
+
+ imgAddr := self imageAddressOf:addr.
+ stream position:imgAddr.
+ byte := stream next.
+ ^ byte
+!
+
fetchClassObjectAt:baseAddr
- |addr classPtr size bits o|
+ |addr classPtr size bits o classRef nInsts|
+
+ (baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
o := addrToObjectMapping at:baseAddr ifAbsent:nil.
o notNil ifTrue:[^ o].
@@ -78,22 +125,41 @@
bits := self fetchUnboxedIntegerAt:addr.
addr := addr + ptrSize.
- o := ImageClassObject new:(size - intSize - intSize - intSize).
- o classRef:classPtr.
- o size:size.
+ nInsts := (size - (intSize *3)) // intSize.
+ o := ImageClassObject new:nInsts.
+ addrToObjectMapping at:baseAddr put:o.
+
+ (self class isPointerOOP:classPtr) ifFalse:[
+ self halt
+ ].
+
+ classRef := self fetchClassObjectAt:classPtr.
+
+ o classRef:classRef.
+size > 8000 ifTrue:[self halt].
+ o byteSize:size.
o bits:bits.
- 1 to:size // intSize do:[:idx |
+ 1 to:nInsts do:[:idx |
o at:idx put:(self fetchUnboxedIntegerAt:addr).
- addr := addr + 1.
+"/ o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
+ addr := addr + ptrSize.
].
-
- addrToObjectMapping at:baseAddr put:o.
+ o memory:self.
^ o
!
fetchObjectAt:baseAddr
- |addr classPtr classRef size bits o|
+ |addr classPtr classRef size bits o nBytes nInsts flags imgAddr|
+
+ baseAddr == 0 ifTrue:[^ nil].
+ (baseAddr bitAnd:1) == 1 ifTrue:[(baseAddr bitTest:16r80000000) ifTrue:[
+ ^ (baseAddr - 16r100000000) bitShift32:-1
+ ] ifFalse:[
+ ^ baseAddr bitShift32:-1
+ ]
+ ].
+ (baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
o := addrToObjectMapping at:baseAddr ifAbsent:nil.
o notNil ifTrue:[^ o].
@@ -111,30 +177,59 @@
].
classRef := self fetchClassObjectAt:classPtr.
- classRef isImageBehavior ifFalse:[
- self halt.
- ].
+
+ flags := classRef flags bitAnd:Behavior maskIndexType.
+ (flags = Behavior flagBytes) ifTrue:[
+ nBytes := (size - (intSize * 3)).
+ o := ImageByteObject new:nBytes.
+ o classRef:classRef.
+size > 8000 ifTrue:[self halt].
+ o byteSize:size.
+ o bits:bits.
- o := ImageObject new:(size - intSize - intSize - intSize).
- o classRef:classRef.
- o size:size.
- o bits:bits.
+ imgAddr := self imageAddressOf:addr.
+ stream position:imgAddr.
- self halt.
-!
+ 1 to:nBytes do:[:idx |
+ o at:idx put:(stream next).
+ addr := addr + 1.
+ ].
+
+"/Transcript show:'#'.
+"/Transcript show:((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:o startingAt:1) asString.
+"/Transcript cr.
-fetchObjectHeaderAt:baseAddr
- |addr class size bits|
+ ] ifFalse:[
+ (flags = Behavior flagNotIndexed) ifFalse:[
+ (flags ~= Behavior flagPointers) ifTrue:[
+ (flags ~= Behavior flagWeakPointers) ifTrue:[
+ self halt
+ ]
+ ].
+ ].
- addr := baseAddr.
- class := self fetchPointerAt:addr.
- addr := addr + ptrSize.
- size := self fetchUnboxedIntegerAt:addr.
- addr := addr + ptrSize.
- bits := self fetchUnboxedIntegerAt:addr.
- addr := addr + ptrSize.
+ nInsts := (size - (intSize * 3)) // intSize.
+ (classRef flags bitTest:Behavior flagBehavior)
+ "/ classRef isImageBehavior
+ ifTrue:[
+ o := ImageClassObject new:nInsts.
+ ] ifFalse:[
+ o := ImageObject new:nInsts.
+ ].
+ o classRef:classRef.
+size > 8000 ifTrue:[self halt].
+ o byteSize:size.
+ o bits:bits.
+ addrToObjectMapping at:baseAddr put:o.
- self halt.
+ 1 to:nInsts do:[:idx |
+ o at:idx put:(self fetchUnboxedIntegerAt:addr).
+"/ o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
+ addr := addr + ptrSize.
+ ]
+ ].
+ o memory:self.
+ ^ o
!
fetchPointerAt:addr
@@ -142,19 +237,28 @@
!
fetchUnboxedIntegerAt:addr
+ |ptr imgAddr|
+
+ (addr bitAnd:3) ~~ 0 ifTrue:[self halt].
+
+ imgAddr := self imageAddressOf:addr.
+ stream position:imgAddr.
+ ptr := stream nextUnsignedLongMSB:msb.
+ ^ ptr
+!
+
+imageAddressOf:addr
spaceInfos do:[:eachSpace |
- |ptr imgAddr|
+ |byte imgAddr|
addr >= eachSpace start ifTrue:[
addr <= eachSpace end ifTrue:[
imgAddr := eachSpace imageBase + (addr - eachSpace start).
- stream position:imgAddr.
- ptr := stream nextUnsignedLongMSB:msb.
- ^ ptr
+ ^ imgAddr
]
].
].
- self halt:'image fetch error'.
+ self halt:'image address error'.
! !
!SnapShotImageMemory methodsFor:'private'!
@@ -166,35 +270,112 @@
val := self at:eachKey.
val isBehavior ifTrue:[
aBlock value:val
- ]
+ ] ifFalse:[
+ self halt.
+ ].
].
!
allGlobalKeysDo:aBlock
- globals isNil ifTrue:[
+ globalEntries isNil ifTrue:[
self readHeader.
self readGlobals.
].
!
+fetchStringFor:aStringRef
+ |nBytes|
+
+ (aStringRef isImageBytes) ifFalse:[self halt].
+
+ nBytes := aStringRef byteSize - (intSize * 3).
+ ^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aStringRef startingAt:1) asString.
+!
+
for:aFilename
stream := aFilename asFilename readStream binary.
addrToObjectMapping := IdentityDictionary new.
+
+ addrToObjectMapping at:(ObjectMemory addressOf:false) put:false.
+ addrToObjectMapping at:(ObjectMemory addressOf:true) put:true.
+!
+
+printStringOfClass:aClassRef
+ |nameSlot|
+
+ (aClassRef isImageBehavior) ifFalse:[self halt].
+ ((aClassRef byteSize // intSize) - 3) < Class instSize ifTrue:[self halt.].
+
+ nameSlot := aClassRef at:7.
+ nameSlot isInteger ifTrue:[
+ nameSlot := self fetchObjectAt:nameSlot
+ ].
+ nameSlot isImageSymbol ifFalse:[self halt].
+ ^ 'Class: ' , (self printStringOfSymbol:nameSlot)
+!
+
+printStringOfObject:anObjectRef
+ |s nBytes|
+
+ anObjectRef isNil ifTrue:[^ 'nil'].
+ (anObjectRef isInteger) ifTrue:[^ anObjectRef printString].
+ (anObjectRef == true ) ifTrue:[^ anObjectRef printString].
+ (anObjectRef == false) ifTrue:[^ anObjectRef printString].
+
+ (anObjectRef isImageSymbol) ifTrue:[^ self printStringOfSymbol:anObjectRef].
+ (anObjectRef isImageBehavior) ifTrue:[^ self printStringOfClass:anObjectRef].
+
+ ^ 'obj(' , anObjectRef printString , ')'
+!
+
+printStringOfString:aStringRef
+ |nBytes|
+
+ (aStringRef isString) ifFalse:[self halt].
+ ^ self fetchStringFor:aStringRef.
+!
+
+printStringOfSymbol:aSymbolRef
+ |nBytes|
+
+ (aSymbolRef isImageSymbol) ifFalse:[self halt].
+^ self fetchStringFor:aSymbolRef.
+"/ nBytes := aSymbolRef size - (intSize * 3).
+"/ ^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aSymbolRef startingAt:1) asString.
!
readGlobalEntries
- |refPointer theSymbol theValue|
+ |refPointer theSymbolPtr theSymbolRef theValuePtr theValueRef pos|
globalEntries := OrderedCollection new.
[
refPointer := stream nextUnsignedLongMSB:msb.
- theSymbol := stream nextUnsignedLongMSB:msb.
- theValue := stream nextUnsignedLongMSB:msb.
- theSymbol ~~ 0
+ theSymbolPtr := stream nextUnsignedLongMSB:msb.
+ theValuePtr := stream nextUnsignedLongMSB:msb.
+ theSymbolPtr ~~ 0
] whileTrue:[
- globalEntries add:(theSymbol -> theValue).
+ globalEntries add:(theSymbolPtr -> theValuePtr).
].
- globalEntries := globalEntries asArray
+ globalEntries := globalEntries asArray.
+
+"/ globalEntries inspect.
+ pos := stream position.
+ globalEntries do:[:item |
+ theSymbolPtr := item key.
+ theValuePtr := item value.
+ theSymbolRef := self fetchObjectAt:theSymbolPtr.
+
+"/ Transcript show:(self printStringOfSymbol:theSymbolRef).
+"/ Transcript show:'->'.
+
+ theValueRef := self fetchObjectAt:theValuePtr.
+"/ Transcript show:(self printStringOfObject:theValueRef).
+"/ Transcript cr.
+
+ item key:theSymbolRef.
+ item value:theValueRef.
+ ].
+ stream position:pos.
!
readHeader
@@ -206,7 +387,7 @@
lowData hiData charSlots charTableSlots fixMemStart fixMemEnd
symMemStart symMemEnd vmDataAddr sharedMethodCode sharedBlockCode
nContexts contextSpace nRegistered symbolsSeqNr nSpaces
- spaceFlags spaceBase spaceSize classNameSize|
+ classNameSize spaceSize|
stream next:256. "/ skip execCmd
@@ -277,8 +458,6 @@
nSpaces := stream nextUnsignedLongMSB:msb.
spaceInfos := (1 to:nSpaces) collect:[:idx | SpaceInfo new].
- spaceBase := Array new:nSpaces.
- spaceSize := Array new:nSpaces.
1 to:nSpaces do:[:i |
(spaceInfos at:i) flags:(stream nextUnsignedLongMSB:msb).
].
@@ -295,7 +474,8 @@
nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
version >= 8 ifTrue:[
- stream position:(stream class zeroPosition + 4096).
+ stream position:(stream class zeroPosition).
+ stream skip:4096.
].
1 to:nSpaces do:[:i |
@@ -303,15 +483,18 @@
].
1 to:nSpaces do:[:i |
(spaceInfos at:i) imageBase:(stream position).
- stream skip:((spaceInfos at:i) size).
+ spaceSize := (spaceInfos at:i) size.
+ stream skip:spaceSize.
].
"/ registration
self readRegistrationEntries.
+ Transcript showCR:'reading symbols...'.
self readSymbolEntries.
+ self readUGlobalEntries.
+ Transcript showCR:'reading globals...'.
self readGlobalEntries.
- self readUGlobalEntries.
"/struct basicImageHeader {
@@ -454,19 +637,27 @@
!
readSymbolEntries
- |refPointer theSymbol|
+ |refPointer theSymbolPtr theSymbolRef pos|
symbolEntries := OrderedCollection new.
[
refPointer := stream nextUnsignedLongMSB:msb.
- theSymbol := stream nextUnsignedLongMSB:msb.
-
- theSymbol ~~ 0
+ theSymbolPtr := stream nextUnsignedLongMSB:msb.
+ theSymbolPtr ~~ 0
] whileTrue:[
- symbolEntries add:(theSymbol -> refPointer).
+ symbolEntries add:theSymbolPtr.
].
- symbolEntries := symbolEntries asArray
+ symbolEntries := symbolEntries asArray.
+
+ pos := stream position.
+ symbolEntries := symbolEntries collect:[:theSymbolPtr |
+ theSymbolRef := self fetchObjectAt:theSymbolPtr.
+ theSymbolRef isImageSymbol ifFalse:[
+ self halt
+ ].
+ ].
+ stream position:pos
!
readUGlobalEntries
@@ -479,6 +670,114 @@
] whileTrue
! !
+!SnapShotImageMemory::ImageHeader methodsFor:'accessing'!
+
+bits
+ "return the value of the instance variable 'bits' (automatically generated)"
+
+ ^ bits!
+
+bits:something
+ "set the value of the instance variable 'bits' (automatically generated)"
+
+ bits := something.!
+
+byteSize
+ "return the value of the instance variable 'size' (automatically generated)"
+
+ ^ byteSize
+!
+
+byteSize:something
+ "set the value of the instance variable 'size' (automatically generated)"
+
+something > 8000 ifTrue:[self halt].
+ byteSize := something.
+!
+
+classRef
+ "return the value of the instance variable 'classRef' (automatically generated)"
+
+ ^ classRef!
+
+classRef:something
+ "set the value of the instance variable 'classRef' (automatically generated)"
+
+ classRef := something.!
+
+memory
+ "return the value of the instance variable 'memory' (automatically generated)"
+
+ ^ memory!
+
+memory:something
+ "set the value of the instance variable 'memory' (automatically generated)"
+
+ memory := something.! !
+
+!SnapShotImageMemory::ImageHeader methodsFor:'queries'!
+
+category
+ |categoryPtr categoryRef category|
+
+ self isMethodOrLazyMethod ifTrue:[
+ categoryPtr := self at:6.
+ categoryRef := memory fetchObjectAt:categoryPtr.
+ category := memory fetchStringFor:categoryRef.
+ ^ category
+ ].
+self halt.
+!
+
+isImageBehavior
+ |flags|
+
+ flags := classRef flags.
+ ^ flags bitTest:Behavior flagBehavior
+!
+
+isImageBytes
+ |flags|
+
+ flags := classRef flags bitAnd:Behavior maskIndexType.
+ ^ flags = Behavior flagBytes
+!
+
+isImageMethod
+ |flags|
+
+ flags := classRef flags.
+ ^ flags bitTest:Behavior flagMethod
+!
+
+isImageSymbol
+ |flags|
+
+ flags := classRef flags.
+ ^ flags bitTest:Behavior flagSymbol
+!
+
+isMeta
+ ^ false
+!
+
+isMethod
+ ^ classRef name = 'Method'
+!
+
+isMethodDictionary
+ ^ classRef name = 'MethodDictionary'
+!
+
+isMethodOrLazyMethod
+ classRef name = 'LazyMethod' ifTrue:[^ true].
+ ^ classRef name = 'Method'
+!
+
+isString
+ ^ classRef name = 'String'
+! !
+
!SnapShotImageMemory::SpaceInfo methodsFor:'accessing'!
end
@@ -531,66 +830,228 @@
start := something.! !
-!SnapShotImageMemory::ImageObject methodsFor:'accessing'!
-
-bits
- "return the value of the instance variable 'bits' (automatically generated)"
-
- ^ bits!
-
-bits:something
- "set the value of the instance variable 'bits' (automatically generated)"
+!SnapShotImageMemory::ImageObject methodsFor:'object protocol'!
- bits := something.!
-
-classRef
- "return the value of the instance variable 'classRef' (automatically generated)"
-
- ^ classRef!
-
-classRef:something
- "set the value of the instance variable 'classRef' (automatically generated)"
-
- classRef := something.!
+at:aSelector ifAbsent:exceptionValue
+ |symPtr symRef mthdPtr mthdRef s|
-size
- "return the value of the instance variable 'size' (automatically generated)"
-
- ^ size!
-
-size:something
- "set the value of the instance variable 'size' (automatically generated)"
-
- size := something.! !
+ 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.
+ ].
+ ].
+ ^ exceptionValue value
+!
-!SnapShotImageMemory::ImageObject methodsFor:'queries'!
-
-isImageBehavior
- |flags|
+do:aBlock
+ |mthdPtr mthdRef|
- flags := self flagsSlot.
+ self isMethodDictionary ifTrue:[
+ 2 to:self size by:2 do:[:idx |
+ mthdPtr := self at:idx.
+ mthdRef := memory fetchObjectAt:mthdPtr.
+ aBlock value:mthdRef.
+ ].
+ ].
+!
- (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
- self halt
- ].
- flags := flags bitShift:-1.
- ^ flags bitTest:Behavior flagBehavior
+isWrapped
+ ^ false
!
-isImageBytes
+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.
+ ].
+ ].
+!
+
+printStringForBrowserWithSelector:selector
+ ^ selector
+!
+
+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:[
+ self halt.
+ ].
+ source := memory printStringOfString:source.
+ sourcePosition isNil ifTrue:[
+ self halt.
+ ^ source
+ ].
+ sourcePosition := memory fetchObjectAt:sourcePosition.
+
+ aStream := self sourceStream.
+ aStream notNil ifTrue:[
+ Stream positionErrorSignal handle:[:ex |
+ ^ nil
+ ] do:[
+ aStream position:sourcePosition abs.
+ ].
+ junk := aStream nextChunk.
+
+ aStream close.
+ ^ junk
+ ].
+ ].
self halt.
!
-isImageString
- self halt.
-!
+sourceStream
+ |sourcePosition source aStream fileName junk who
+ myClass mgr className sep dir mod package|
+
+ self isMethod ifTrue:[
+ sourcePosition := self at:(Method instVarOffsetOf:'sourcePosition').
+ source := self at:(Method instVarOffsetOf:'source').
+ source := memory fetchObjectAt:source.
+ source isString ifTrue:[
+ source := memory printStringOfString:source.
+ ].
+ sourcePosition notNil ifTrue:[
+ sourcePosition := memory fetchObjectAt:sourcePosition.
+ ].
+
+ source isNil ifTrue:[^ nil].
+ sourcePosition isNil ifTrue:[^ source readStream].
+
+ sourcePosition < 0 ifTrue:[
+ aStream := source asFilename readStream.
+ aStream notNil ifTrue:[
+ ^ aStream
+ ].
+
+ fileName := Smalltalk getSourceFileName:source.
+ fileName notNil ifTrue:[
+ aStream := fileName asFilename readStream.
+ aStream notNil ifTrue:[
+ ^ aStream
+ ].
+ ].
+ ].
+
+ "/
+ "/ if there is no SourceManager, look in local standard places first
+ "/
+ (mgr := Smalltalk at:#SourceCodeManager) isNil ifTrue:[
+ aStream := self localSourceStream.
+ aStream notNil ifTrue:[
+ ^ aStream
+ ].
+ ].
+
+ "/
+ "/ nope - ask my class for the source (this also invokes the SCMgr)
+ "/
+ myClass := self mclass.
-isImageSymbol
+ package := self package.
+ (package notNil and:[package ~= myClass package]) ifTrue:[
+ mgr notNil ifTrue:[
+ "/ try to get the source using my package information ...
+ sep := 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 notNil ifTrue:[
+ ^ aStream
+ ].
+ ].
+ ].
+ ].
+
+ aStream := myClass sourceStreamFor:source.
+ aStream notNil ifTrue:[
+ ^ aStream
+ ].
+
+ "/
+ "/ nope - look in standard places
+ "/ (if there is a source-code manager - otherwise, we already did that)
+ "/
+ mgr notNil ifTrue:[
+ aStream := self localSourceStream.
+ aStream notNil ifTrue:[
+ ^ aStream
+ ].
+ ].
+
+ "/
+ "/ final chance: try current directory
+ "/
+ aStream isNil ifTrue:[
+ aStream := source asFilename readStream.
+ aStream notNil ifTrue:[
+ ^ aStream
+ ].
+ ].
+
+ (who isNil and:[source notNil]) ifTrue:[
+ "/
+ "/ mhmh - seems to be a method which used to be in some
+ "/ class, but has been overwritten by another or removed.
+ "/ (i.e. it has no containing class anyMore)
+ "/ try to guess the class from the sourceFileName.
+ "/ and retry.
+ "/
+ className := Smalltalk classNameForFile:source.
+ className knownAsSymbol ifTrue:[
+ myClass := Smalltalk at:className asSymbol ifAbsent:nil.
+ myClass notNil ifTrue:[
+ aStream := myClass sourceStreamFor:source.
+ aStream notNil ifTrue:[
+ ^ aStream
+ ].
+ ]
+ ]
+ ].
+
+ ^ nil
+ ].
self halt.
! !
!SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!
+category
+ |categoryRef category|
+
+ categoryRef := self categorySlot.
+ categoryRef isInteger ifTrue:[
+ categoryRef := memory fetchObjectAt:categoryRef.
+ ].
+ categoryRef notNil ifTrue:[
+ category := memory fetchStringFor:categoryRef.
+ ].
+ ^ category
+!
+
categorySlot
^ self at:8
!
@@ -599,19 +1060,54 @@
^ self at:12
!
+classVarNames
+ |classVarNamesRef classVarNames s|
+
+ classVarNamesRef := self classVarsSlot.
+ classVarNamesRef isInteger ifTrue:[
+ classVarNamesRef := memory fetchObjectAt:classVarNamesRef.
+ ].
+ classVarNamesRef notNil ifTrue:[
+ classVarNamesRef isImageBytes ifTrue:[
+ "/ a string
+ classVarNames := memory fetchStringFor:classVarNamesRef.
+ classVarNames := classVarNames asCollectionOfWords.
+ ] ifFalse:[
+ classVarNames := Array new:(classVarNamesRef size).
+ 1 to:classVarNames size do:[:idx |
+ s := classVarNamesRef at:idx.
+ s := memory fetchObjectAt:s.
+ s isImageBytes ifFalse:[self halt].
+ s := memory fetchStringFor:s.
+ classVarNames at:idx put:s.
+ ].
+ ].
+ ].
+ ^ classVarNames
+!
+
classVarsSlot
^ self at:9
!
+comment
+ |commentRef comment|
+
+ commentRef := self commentSlot.
+ commentRef isInteger ifTrue:[
+ commentRef := memory fetchObjectAt:commentRef.
+ ].
+ commentRef notNil ifTrue:[
+ comment := memory fetchStringFor:commentRef.
+ ].
+ ^ comment
+!
+
commentSlot
^ self at:10
!
-flagsSlot
- ^ self at:2
-!
-
-flagsValue
+flags
|flags|
flags := self flagsSlot.
@@ -622,18 +1118,75 @@
^ flags bitShift:-1.
!
+flagsSlot
+ ^ self at:2
+!
+
instSizeSlot
^ self at:5
!
+instVarNames
+ |instVarNamesRef instVarNames s|
+
+ instVarNamesRef := self instVarsSlot.
+ instVarNamesRef isInteger ifTrue:[
+ instVarNamesRef := memory fetchObjectAt:instVarNamesRef.
+ ].
+ instVarNamesRef notNil ifTrue:[
+ instVarNamesRef isImageBytes ifTrue:[
+ "/ a string
+ instVarNames := memory fetchStringFor:instVarNamesRef.
+ instVarNames := instVarNames asCollectionOfWords.
+ ] ifFalse:[
+ instVarNames := Array new:(instVarNamesRef size).
+ 1 to:instVarNames size do:[:idx |
+ s := instVarNamesRef at:idx.
+ s := memory fetchObjectAt:s.
+ s isImageBytes ifFalse:[self halt].
+ s := memory fetchStringFor:s.
+ instVarNames at:idx put:s.
+ ].
+ ].
+ ].
+ ^ instVarNames
+!
+
instVarsSlot
^ self at:6
!
+methodDictionary
+ |methodDictionaryRef methodDictionary|
+
+ methodDictionaryRef := self methodDictionarySlot.
+ methodDictionaryRef isInteger ifTrue:[
+ methodDictionaryRef == 0 ifTrue:[^ nil].
+ methodDictionary := memory fetchObjectAt:methodDictionaryRef.
+ ].
+ ^ methodDictionary
+!
+
methodDictionarySlot
^ self at:3
!
+name
+ |nameRef name|
+
+ nameRef := self nameSlot.
+ nameRef isInteger ifTrue:[
+ nameRef := memory fetchObjectAt:nameRef.
+ ].
+ nameRef notNil ifTrue:[
+ name := memory fetchStringFor:nameRef.
+ ].
+ nameRef notNil ifTrue:[
+ name := name asSymbol.
+ ].
+ ^ name
+!
+
nameSlot
^ self at:7
!
@@ -646,10 +1199,536 @@
^ self at:14
!
-superClassSlot
+superclass
+ |superClassRef superClass|
+
+ superClassRef := self superclassSlot.
+ superClassRef isInteger ifTrue:[
+ superClass := memory fetchObjectAt:superClassRef.
+ ].
+ ^ superClass
+!
+
+superclassSlot
^ self at:1
! !
+!SnapShotImageMemory::ImageClassObject methodsFor:'class protocol'!
+
+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:[
+ syntaxHilighting := UserPreferences current syntaxColoring.
+ ].
+
+ owner := self owningClass.
+
+ owner isNil ifTrue:[
+ ns := self nameSpace.
+ ] ifFalse:[
+ ns := self topOwningClass nameSpace
+ ].
+ fullName := Class fileOutNameSpaceQuerySignal query == true.
+
+ (showPackage and:[owner isNil]) ifTrue:[
+ aStream nextPutAll:'"{ Package: '''.
+ aStream nextPutAll:self package asString.
+ aStream nextPutAll:''' }"'; cr; cr.
+ ].
+
+ ((owner isNil and:[fullName not])
+ or:[owner notNil and:[forceNameSpace and:[fullName not]]]) ifTrue:[
+ (ns notNil and:[ns ~~ Smalltalk]) ifTrue:[
+ nsName := ns name.
+ (nsName includes:$:) ifTrue:[
+ nsName := '''' , nsName , ''''
+ ].
+"/ aStream nextPutLine:'"{ NameSpace: ' , nsName , ' }"'; cr.
+ aStream nextPutAll:'"{ NameSpace: '.
+ syntaxHilighting ifTrue:[aStream bold].
+ aStream nextPutAll:nsName.
+ syntaxHilighting ifTrue:[aStream normal].
+ aStream nextPutAll:' }"'; cr; cr.
+ ]
+ ].
+
+ "take care of nil-superclass"
+ superclass isNil ifTrue:[
+ s := 'nil'
+ ] ifFalse:[
+ fullName ifTrue:[
+ superclass == owner ifTrue:[
+ s := superclass nameWithoutNameSpacePrefix
+ ] ifFalse:[
+ s := superclass name
+ ]
+ ] ifFalse:[
+ (ns == superclass nameSpace
+ and:[superclass owningClass isNil]) ifTrue:[
+ "/ superclass is in the same namespace;
+ "/ still prepend namespace prefix, to avoid
+ "/ confusing stc, which needs that information ...
+ s := superclass nameWithoutPrefix
+ ] ifFalse:[
+ "/ a very special (rare) situation:
+ "/ my superclass resides in another nameSpace,
+ "/ but there is something else named like this
+ "/ to be found in my nameSpace (or a private class)
+
+ superName := superclass nameWithoutNameSpacePrefix asSymbol.
+ cls := self privateClassesAt:superName.
+ cls isNil ifTrue:[
+ (topOwner := self topOwningClass) isNil ifTrue:[
+ ns := self nameSpace.
+ ns notNil ifTrue:[
+ cls := ns privateClassesAt:superName
+ ] ifFalse:[
+ "/ self error:'unexpected nil namespace'
+ ]
+ ] ifFalse:[
+ cls := topOwner nameSpace at:superName.
+ ]
+ ].
+ (cls notNil and:[cls ~~ superclass]) ifTrue:[
+ s := superclass nameSpace name , '::' , superName
+ ] ifFalse:[
+ "/ no class with that name found in my namespace ...
+ "/ if the superclass resides in Smalltalk,
+ "/ suppress prefix; otherwise, use full prefix.
+ (superclass nameSpace notNil
+ and:[superclass nameSpace ~~ Smalltalk]) ifTrue:[
+ (owner notNil
+ and:[owner nameSpace == superclass owningClass nameSpace])
+ ifTrue:[
+ s := superclass nameWithoutNameSpacePrefix
+ ] ifFalse:[
+ s := superclass name
+ ]
+ ] ifFalse:[
+ s := superName
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ syntaxHilighting ifTrue:[aStream bold].
+ aStream nextPutAll:s. "/ superclass
+ syntaxHilighting ifTrue:[aStream normal].
+ aStream space.
+ self basicFileOutInstvarTypeKeywordOn:aStream.
+
+ (fullName and:[owner isNil]) ifTrue:[
+ aStream nextPutAll:'#'''.
+ syntaxHilighting ifTrue:[aStream bold].
+ aStream nextPutAll:(self name).
+ syntaxHilighting ifTrue:[aStream normal].
+ aStream nextPutAll:''''.
+ ] ifFalse:[
+ aStream nextPut:$#.
+ syntaxHilighting ifTrue:[aStream bold].
+ aStream nextPutAll:(self nameWithoutPrefix).
+ syntaxHilighting ifTrue:[aStream normal].
+ ].
+
+ aStream crtab.
+ aStream nextPutAll:'instanceVariableNames:'''.
+ syntaxHilighting ifTrue:[aStream bold].
+ self printInstVarNamesOn:aStream indent:16.
+ syntaxHilighting ifTrue:[aStream normal].
+ aStream nextPutAll:''''.
+
+ aStream crtab.
+ aStream nextPutAll:'classVariableNames:'''.
+ syntaxHilighting ifTrue:[aStream bold].
+ self printClassVarNamesOn:aStream indent:16.
+ syntaxHilighting ifTrue:[aStream normal].
+ aStream nextPutAll:''''.
+
+ aStream crtab.
+ aStream nextPutAll:'poolDictionaries:'''''.
+
+ aStream crtab.
+ owner isNil ifTrue:[
+ "/ a public class
+ aStream nextPutAll:'category:'.
+ category isNil ifTrue:[
+ s := ''''''
+ ] ifFalse:[
+ s := category asString storeString
+ ].
+ aStream nextPutAll:s.
+ ] ifFalse:[
+ "/ a private class
+ aStream nextPutAll:'privateIn:'.
+ syntaxHilighting ifTrue:[aStream bold].
+"/ fullName ifTrue:[
+"/ s := owner name.
+"/ ] ifFalse:[
+"/ s := owner nameWithoutNameSpacePrefix.
+"/ ].
+ s := owner nameWithoutNameSpacePrefix.
+ aStream nextPutAll:s.
+ syntaxHilighting ifTrue:[aStream normal].
+ ].
+ aStream cr
+
+ "Created: / 4.1.1997 / 20:38:16 / cg"
+ "Modified: / 8.8.1997 / 10:59:50 / cg"
+ "Modified: / 18.3.1999 / 18:15:46 / stefan"
+!
+
+basicFileOutInstvarTypeKeywordOn:aStream
+ "a helper for fileOutDefinition"
+
+ |isVar s superclass|
+
+ superclass := self superclass.
+ superclass isNil ifTrue:[
+ isVar := self isVariable
+ ] ifFalse:[
+ "I cant remember what this is for ?"
+ isVar := (self isVariable and:[superclass isVariable not])
+ ].
+
+ aStream nextPutAll:(self firstDefinitionSelectorPart).
+
+ "Created: 11.10.1996 / 18:57:29 / cg"
+!
+
+compiledMethodAt:aSelector
+
+ ^ self compiledMethodAt:aSelector ifAbsent:nil
+!
+
+compiledMethodAt:aSelector ifAbsent:exceptionValue
+ |dict|
+
+ dict := self methodDictionary.
+ dict isNil ifTrue:[
+ ('Behavior [warning]: nil methodDictionary in ' , self name printString) errorPrintCR.
+ ^ exceptionValue value
+ ].
+
+ ^ dict at:aSelector ifAbsent:exceptionValue
+!
+
+evaluatorClass
+ ^ Object evaluatorClass
+!
+
+firstDefinitionSelectorPart
+ "return the first part of the selector with which I was (can be) defined in my superclass"
+
+ self isVariable ifFalse:[
+ ^ #'subclass:'
+ ].
+ self isBytes ifTrue:[
+ ^ #'variableByteSubclass:'
+ ].
+ self isLongs ifTrue:[
+ ^ #'variableLongSubclass:'
+ ].
+ self isFloats ifTrue:[
+ ^ #'variableFloatSubclass:'
+ ].
+ self isDoubles ifTrue:[
+ ^ #'variableDoubleSubclass:'
+ ].
+ self isWords ifTrue:[
+ ^ #'variableWordSubclass:'
+ ].
+ self isSignedWords ifTrue:[
+ ^ #'variableSignedWordSubclass:'
+ ].
+ self isSignedLongs ifTrue:[
+ ^ #'variableSignedLongSubclass:'
+ ].
+ self isSignedLongLongs ifTrue:[
+ ^ #'variableSignedLongLongSubclass:'
+ ].
+ self isLongLongs ifTrue:[
+ ^ #'variableLongLongSubclass:'
+ ].
+ ^ #'variableSubclass:'
+!
+
+nameWithoutNameSpacePrefix
+ |nm owner|
+
+ nm := self nameWithoutPrefix.
+ (owner := self owningClass) isNil ifTrue:[
+ ^ nm
+ ].
+
+ ^ (owner nameWithoutNameSpacePrefix , '::' , nm)
+!
+
+nameWithoutPrefix
+ |nm idx|
+
+ nm := self name.
+ idx := nm lastIndexOf:$:.
+ idx == 0 ifTrue:[
+ ^ nm
+ ].
+ ^ nm copyFrom:idx+1.
+!
+
+printClassVarNamesOn:aStream indent:indent
+ "print the class variable names indented and breaking at line end"
+
+ self printNameArray:(self classVarNames) on:aStream indent:indent
+!
+
+printHierarchyAnswerIndentOn:aStream
+ "print my class hierarchy on aStream - return indent
+ recursively calls itself to print superclass and use returned indent
+ for my description - used in the browser"
+
+ |indent nm superclass|
+
+ superclass := self superclass.
+ indent := 0.
+ (superclass notNil) ifTrue:[
+ indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
+ ].
+ aStream spaces:indent.
+ nm := self printNameInHierarchy.
+ aStream nextPutAll:nm; nextPutAll:' ('.
+ self printInstVarNamesOn:aStream indent:(indent + nm size + 2).
+ aStream nextPutLine:')'.
+ ^ indent
+!
+
+printHierarchyOn: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
+
+ "Created: 22.3.1997 / 14:12:00 / cg"
+!
+
+printNameArray:anArray on:aStream indent:indent
+ "print an array of strings separated by spaces; when the stream
+ defines a lineLength, break when this limit is reached; indent
+ every line; used to printOut instance variable names"
+
+ |thisName nextName arraySize lenMax pos mustBreak line spaces|
+
+ arraySize := anArray size.
+ arraySize ~~ 0 ifTrue:[
+ pos := indent.
+ lenMax := aStream lineLength.
+ thisName := anArray at:1.
+ line := ''.
+ 1 to:arraySize do:[:index |
+ line := line , thisName.
+ pos := pos + thisName size.
+ (index == arraySize) ifFalse:[
+ nextName := anArray at:(index + 1).
+ mustBreak := false.
+ (lenMax > 0) ifTrue:[
+ ((pos + nextName size) > lenMax) ifTrue:[
+ mustBreak := true
+ ]
+ ].
+ mustBreak ifTrue:[
+ aStream nextPutLine:line withTabs.
+ spaces isNil ifTrue:[
+ spaces := String new:indent
+ ].
+ line := spaces.
+ pos := indent
+ ] ifFalse:[
+ line := line , ' '.
+ pos := pos + 1
+ ].
+ thisName := nextName
+ ]
+ ].
+ aStream nextPutAll:line withTabs
+ ]
+
+ "Modified: 9.11.1996 / 00:12:06 / cg"
+ "Created: 22.3.1997 / 14:12:12 / cg"
+!
+
+printNameInHierarchy
+ ^ self name
+!
+
+privateClassesAt:aClassNameStringOrSymbol
+ |nmSym|
+
+ nmSym := (self name , '::' , aClassNameStringOrSymbol) asSymbolIfInterned.
+ nmSym isNil ifTrue:[
+ "/ no such symbol - there cannot be a corresponding private class
+ ^ nil
+ ].
+
+ ^ memory at:nmSym.
+!
+
+sourceCodeManager
+ ^ SourceCodeManager
+!
+
+syntaxHighlighterClass
+ ^ Object syntaxHighlighterClass
+!
+
+withAllSuperclassesDo:aBlock
+ |sc|
+
+ aBlock value:self.
+ sc := self superclass.
+ sc notNil ifTrue:[
+ sc withAllSuperclassesDo:aBlock.
+ ]
+! !
+
+!SnapShotImageMemory::ImageClassObject methodsFor:'queries'!
+
+categories
+ |newList|
+
+ newList := Set new.
+ self methodDictionary do:[:aMethod |
+ |cat|
+
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ newList add:cat
+ ].
+ ^ newList
+!
+
+isBytes
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagBytes.
+!
+
+isDoubles
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagDoubles.
+!
+
+isFloats
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagFloats.
+!
+
+isLoaded
+ ^ self superclass name ~= 'Autoload'
+!
+
+isLongLongs
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagLongLongs.
+!
+
+isLongs
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagLongs.
+!
+
+isMeta
+ ^ self size == (Metaclass instSize * memory ptrSize).
+"/ ^ classRef classRef name = 'Metaclass'
+!
+
+isPrivate
+ ^ classRef isPrivateMeta
+!
+
+isPrivateMeta
+ ^ classRef name = 'PrivateMetaclass'
+!
+
+isSignedLongLongs
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedLongLongs.
+!
+
+isSignedLongs
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedLongs.
+!
+
+isSignedWords
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedWords.
+!
+
+isVariable
+ ^ (self flags bitAnd:Behavior maskIndexType) ~= 0.
+!
+
+isWords
+ ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagWords.
+!
+
+nameSpace
+ |env name idx nsName|
+
+"/ (env := self environment) notNil ifTrue:[^ env].
+ name := self name.
+ idx := name lastIndexOf:$:.
+ idx ~~ 0 ifTrue:[
+ (name at:idx-1) == $: ifTrue:[
+ nsName := name copyTo:(idx - 2).
+ env := Smalltalk at:nsName asSymbol.
+ ]
+ ].
+ ^ env
+!
+
+owningClass
+ |ownerPtr owner|
+
+ classRef isPrivateMeta ifFalse:[^ nil].
+ ownerPtr := classRef at:8.
+ owner := memory fetchClassObjectAt:ownerPtr.
+ ^ owner
+!
+
+supportsMethodCategories
+ ^ true
+!
+
+topOwningClass
+ |owner|
+
+ classRef isPrivateMeta ifTrue:[
+ owner := self owningClass.
+ [owner classRef isPrivateMeta] whileTrue:[
+ owner := owner owningClass
+ ].
+ ^ owner
+ ] ifFalse:[
+ ^ nil
+ ].
+ ^ self halt.
+!
+
+wasAutoloaded
+ ^ false
+! !
+
+!SnapShotImageMemory::ImageByteObject methodsFor:'queries'!
+
+size
+ ^ byteSize
+! !
+
!SnapShotImageMemory class methodsFor:'documentation'!
version