'From Smalltalk/X, Version:4.1.1 on 24-Okt-2000 at 12:50:47' !
"{ Package: 'cg:private' }"
Object subclass:#SnapShotImageMemory
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:''
poolDictionaries:''
privateIn:SnapShotImageMemory
!
SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:SnapShotImageMemory
!
SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:SnapShotImageMemory
!
SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:SnapShotImageMemory
!
!SnapShotImageMemory class methodsFor:'instance creation'!
for:aFilename
^ self new for:aFilename
! !
!SnapShotImageMemory class methodsFor:'private'!
isNilOOP:anOOP
^ anOOP == 0
!
isPointerOOP:anOOP
^ (anOOP bitTest:1) not
!
isSmallIntegerOOP:anOOP
^ anOOP bitTest:1
! !
!SnapShotImageMemory methodsFor:'accessing'!
globalEntries
"return the value of the instance variable 'globalEntries' (automatically generated)"
^ globalEntries!
globalEntries:something
"set the value of the instance variable 'globalEntries' (automatically generated)"
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 classRef nInsts|
(baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
o := addrToObjectMapping at:baseAddr ifAbsent:nil.
o notNil ifTrue:[^ o].
addr := baseAddr.
classPtr := 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.
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: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
!
fetchObjectAt:baseAddr
|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].
addr := baseAddr.
classPtr := self fetchPointerAt:addr.
addr := addr + ptrSize.
size := self fetchUnboxedIntegerAt:addr.
addr := addr + ptrSize.
bits := self fetchUnboxedIntegerAt:addr.
addr := addr + ptrSize.
(self class isPointerOOP:classPtr) ifFalse:[
self halt
].
classRef := self fetchClassObjectAt:classPtr.
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.
imgAddr := self imageAddressOf:addr.
stream position:imgAddr.
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.
] ifFalse:[
(flags = Behavior flagNotIndexed) ifFalse:[
(flags ~= Behavior flagPointers) ifTrue:[
(flags ~= Behavior flagWeakPointers) ifTrue:[
self halt
]
].
].
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.
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
^ self fetchUnboxedIntegerAt:addr
!
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 |
|byte imgAddr|
addr >= eachSpace start ifTrue:[
addr <= eachSpace end ifTrue:[
imgAddr := eachSpace imageBase + (addr - eachSpace start).
^ imgAddr
]
].
].
self halt:'image address error'.
! !
!SnapShotImageMemory methodsFor:'private'!
allClassesDo:aBlock
self allGlobalKeysDo:[:eachKey |
|val|
val := self at:eachKey.
val isBehavior ifTrue:[
aBlock value:val
] ifFalse:[
self halt.
].
].
!
allGlobalKeysDo:aBlock
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 theSymbolPtr theSymbolRef theValuePtr theValueRef pos|
globalEntries := OrderedCollection new.
[
refPointer := stream nextUnsignedLongMSB:msb.
theSymbolPtr := stream nextUnsignedLongMSB:msb.
theValuePtr := stream nextUnsignedLongMSB:msb.
theSymbolPtr ~~ 0
] whileTrue:[
globalEntries add:(theSymbolPtr -> theValuePtr).
].
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
"
(self for:'stmeas.img') readHeader
"
|order magic version timeStamp snapID last_util_addr hiText_addr flags
lowData hiData charSlots charTableSlots fixMemStart fixMemEnd
symMemStart symMemEnd vmDataAddr sharedMethodCode sharedBlockCode
nContexts contextSpace nRegistered symbolsSeqNr nSpaces
classNameSize spaceSize|
stream next:256. "/ skip execCmd
msb := false.
order := stream nextUnsignedLongMSB:msb.
order = 16r076543210 ifTrue:[
] ifFalse:[
order = 16r01234567 ifTrue:[
msb := true.
] ifFalse:[
self error:'unhandled byteorder'
].
].
magic := (stream next:8) asString.
magic ~= 'ST/X-IMG' ifTrue:[
self error:'not an st/x image'
].
version := stream nextUnsignedLongMSB:msb.
timeStamp := stream nextUnsignedLongMSB:msb.
ptrSize := stream nextByte.
ptrSize ~~ 4 ifTrue:[
self error:'unhandled ptr format'
].
stream next:7. "/ filler
intSize := stream nextUnsignedLongMSB:msb.
intSize == 9 ifTrue:[
intSize := 4.
intTag := 1.
] ifFalse:[
self error:'unhandled int format'
].
snapID := stream nextUnsignedLongMSB:msb.
last_util_addr := stream next:intSize.
hiText_addr := stream next:intSize.
flags := stream next:intSize.
stream next:8. "/ info, debug & filler
lowData := stream nextUnsignedLongMSB:msb.
hiData := stream nextUnsignedLongMSB:msb.
charSlots := stream nextUnsignedLongMSB:msb.
charTableSlots := stream nextUnsignedLongMSB:msb.
version >= 8 ifTrue:[
fixMemStart := stream nextUnsignedLongMSB:msb.
fixMemEnd := stream nextUnsignedLongMSB:msb.
symMemStart := stream nextUnsignedLongMSB:msb.
symMemEnd := stream nextUnsignedLongMSB:msb.
vmDataAddr := stream nextUnsignedLongMSB:msb.
].
stream next:(128 * intSize). "/ skip sharedMethodCode ptrs
stream next:(128 * intSize). "/ skip sharedBlockCode ptrs
nContexts := stream nextUnsignedLongMSB:msb.
contextSpace := stream nextUnsignedLongMSB:msb.
nRegistered := stream nextUnsignedLongMSB:msb.
version >= 8 ifTrue:[
version >= 9 ifTrue:[
symbolsSeqNr := stream nextUnsignedLongMSB:msb.
stream next:(intSize * 31).
] ifFalse:[
stream next:(intSize * 32).
]
].
nSpaces := stream nextUnsignedLongMSB:msb.
spaceInfos := (1 to:nSpaces) collect:[:idx | SpaceInfo new].
1 to:nSpaces do:[:i |
(spaceInfos at:i) flags:(stream nextUnsignedLongMSB:msb).
].
nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
1 to:nSpaces do:[:i |
(spaceInfos at:i) start:(stream nextUnsignedLongMSB:msb).
].
nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
1 to:nSpaces do:[:i |
(spaceInfos at:i) size:(stream nextUnsignedLongMSB:msb).
].
nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
version >= 8 ifTrue:[
stream position:(stream class zeroPosition).
stream skip:4096.
].
1 to:nSpaces do:[:i |
(spaceInfos at:i) end:((spaceInfos at:i) start + (spaceInfos at:i) size - 1).
].
1 to:nSpaces do:[:i |
(spaceInfos at:i) imageBase:(stream position).
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.
"/struct basicImageHeader {
"/ char h_execCmd[256];
"/
"/ int h_orderWord;
"/ char h_magic[8];
"/ int h_version;
"/ int h_timeStamp;
"/ char h_ptrSize;
"/ char h_filler1[7];
"/ int h_intSize;
"/ int h_snapID;
"/ INT h_last_util_addr;
"/ INT h_hiText_addr;
"/ INT h_flags;
"/ char h_infoPrinting;
"/ char h_debugPrinting;
"/ char h_filler2[6];
"/
"/ /*
"/ * these are to verify compatibility of the image with
"/ * myself ...
"/ * this is now obsolete.
"/ */
"/ INT h_lowData, h_hiData;
"/
"/ /*
"/ * base address of character- and characterTable slots
"/ */
"/ INT h_charSlots;
"/ INT h_charTableSlots;
"/
"/#if HEADER_VERSION >= 8
"/ /*
"/ * the fixBase (VMDATA address)
"/ */
"/ INT h_fixMemStart;
"/ INT h_fixMemEnd;
"/ INT h_symMemStart;
"/ INT h_symMemEnd;
"/
"/ INT h_vmDataAddr;
"/#endif
"/
"/ INT h_sharedMethodCode[128];
"/ INT h_sharedBlockCode[128];
"/
"/ /*
"/ * space needed to restore contexts
"/ */
"/ INT h_nContexts;
"/ INT h_contextSpace;
"/
"/ /*
"/ * number of class registration info records
"/ */
"/ INT h_nRegistered;
"/
"/#if HEADER_VERSION >= 8
"/ /*
"/ * reserved slots, for future versions
"/ * (can add additional info, without affecting position of following stuff)
"/ * If you add slots, you MUST DECREMENT the fillcount.
"/ */
"/# if HEADER_VERSION >= 9
"/ INT h_symbolsSeqNr;
"/ INT h_reserved[31];
"/# else
"/ INT h_reserved[32];
"/# endif
"/#endif
"/
"/ /*
"/ * number of spaces, base and size of each
"/ */
"/ INT h_nSpaces;
"/ INT h_spaceFlags[MAXSPACES];
"/ INT h_spaceBase[MAXSPACES];
"/ INT h_spaceSize[MAXSPACES];
"/
"/ /*
"/ * here come nSpaces object spaces
"/ */
"/
"/ /*
"/ * here comes registration info
"/ */
"/
"/ /*
"/ * here come nSymbols symbolEntries
"/ * followed by a zero/zero entry
"/ */
"/
"/ /*
"/ * here come nGlobal globalEntries
"/ * followed by a zero/zero entry
"/ */
"/
"/ /*
"/ * here come nUnnamedGlobal globalEntries
"/ * followed by a zero/zero entry
"/ */
"/
"/ /*
"/ * here come stack contexts
"/ */
"/};
!
readRegistrationEntries
|classNameSize|
[
classNameSize := stream nextUnsignedLongMSB:msb.
classNameSize ~~ 0
] whileTrue:[
|className flags moduleTimestamp signature nMethods nBlocks oldLitRefs nLitRefs
oldConstTable nConsts|
className := (stream next:classNameSize) asString.
stream next. "/ 0-byte
flags := stream nextUnsignedLongMSB:msb.
moduleTimestamp := stream nextUnsignedLongMSB:msb.
signature := stream nextUnsignedLongMSB:msb.
nMethods := stream nextUnsignedLongMSB:msb.
nMethods timesRepeat:[ stream nextUnsignedLongMSB:msb ].
nBlocks := stream nextUnsignedLongMSB:msb.
nBlocks timesRepeat:[ stream nextUnsignedLongMSB:msb ].
oldLitRefs := stream nextUnsignedLongMSB:msb.
nLitRefs := stream nextUnsignedLongMSB:msb.
nLitRefs timesRepeat:[ stream nextUnsignedLongMSB:msb ].
stream nextUnsignedLongMSB:msb. "/ 0-litRef
oldConstTable := stream nextUnsignedLongMSB:msb.
nConsts := stream nextUnsignedLongMSB:msb.
nConsts timesRepeat:[ stream nextUnsignedLongMSB:msb ].
Transcript showCR:className.
].
!
readSymbolEntries
|refPointer theSymbolPtr theSymbolRef pos|
symbolEntries := OrderedCollection new.
[
refPointer := stream nextUnsignedLongMSB:msb.
theSymbolPtr := stream nextUnsignedLongMSB:msb.
theSymbolPtr ~~ 0
] whileTrue:[
symbolEntries add:theSymbolPtr.
].
symbolEntries := symbolEntries asArray.
pos := stream position.
symbolEntries := symbolEntries collect:[:theSymbolPtr |
theSymbolRef := self fetchObjectAt:theSymbolPtr.
theSymbolRef isImageSymbol ifFalse:[
self halt
].
].
stream position:pos
!
readUGlobalEntries
|refPointer theValue|
[
refPointer := stream nextUnsignedLongMSB:msb.
theValue := stream nextUnsignedLongMSB:msb.
refPointer ~~ 0
] 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
"return the value of the instance variable 'end' (automatically generated)"
^ end!
end:something
"set the value of the instance variable 'end' (automatically generated)"
end := something.!
flags
"return the value of the instance variable 'flags' (automatically generated)"
^ flags!
flags:something
"set the value of the instance variable 'flags' (automatically generated)"
flags := something.!
imageBase
"return the value of the instance variable 'imageBase' (automatically generated)"
^ imageBase!
imageBase:something
"set the value of the instance variable 'imageBase' (automatically generated)"
imageBase := something.!
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.!
start
"return the value of the instance variable 'start' (automatically generated)"
^ start!
start:something
"set the value of the instance variable 'start' (automatically generated)"
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.
].
].
^ exceptionValue value
!
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.
].
].
!
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.
].
].
!
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.
!
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.
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
!
classFilenameSlot
^ 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
!
flags
|flags|
flags := self flagsSlot.
(SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
self halt
].
^ 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
!
packageSlot
^ self at:13
!
revisionSlot
^ self at:14
!
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
^ '$Header$'
! !