hg/stx-libtool2: comparison SnapShotImageMemory.st

equal deleted inserted replaced

-:eec0911414fe
+:28d6026fe30c
+'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:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
-Object variableSubclass:#ImageObject
+SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject
-	instanceVariableNames:'classRef size bits'
+	instanceVariableNames:''
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
+SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
+	instanceVariableNames:''
+	classVariableNames:''
+	poolDictionaries:''
+	privateIn:SnapShotImageMemory
+!
 !SnapShotImageMemory class methodsFor:'instance creation'!
 for:aFilename
 ^ self new for:aFilename
 ^ globalEntries!
 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].
 addr := baseAddr.
 size := self fetchUnboxedIntegerAt:addr.
 addr := addr + ptrSize.
 bits := self fetchUnboxedIntegerAt:addr.
 addr := addr + ptrSize.
-o := ImageClassObject new:(size - intSize - intSize - intSize).
+nInsts := (size - (intSize *3)) // intSize.
-o classRef:classPtr.
+o := ImageClassObject new:nInsts.
-o size:size.
+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].
 addr := baseAddr.
 (self class isPointerOOP:classPtr) ifFalse:[
 self halt
 ].
 classRef := self fetchClassObjectAt:classPtr.
-classRef isImageBehavior ifFalse:[
-self halt.
+flags := classRef flags bitAnd:Behavior maskIndexType.
-].
+(flags = Behavior flagBytes) ifTrue:[
+nBytes := (size - (intSize * 3)).
-o := ImageObject new:(size - intSize - intSize - intSize).
+o := ImageByteObject new:nBytes.
 o classRef:classRef.
-o size:size.
+size > 8000 ifTrue:[self halt].
-o bits:bits.
+o byteSize:size.
+o bits:bits.
-self halt.
-!
+imgAddr := self imageAddressOf:addr.
+stream position:imgAddr.
-fetchObjectHeaderAt:baseAddr
-|addr class size bits|
+1 to:nBytes do:[:idx |
+o at:idx put:(stream next).
-addr := baseAddr.
+addr := addr + 1.
-class := self fetchPointerAt:addr.
+].
-addr := addr + ptrSize.
-size := self fetchUnboxedIntegerAt:addr.
+"/Transcript show:'#'.
-addr := addr + ptrSize.
+"/Transcript show:((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:o startingAt:1) asString.
-bits := self fetchUnboxedIntegerAt:addr.
+"/Transcript cr.
-addr := addr + ptrSize.
+] ifFalse:[
-self halt.
+(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 |
-|ptr imgAddr|
+|byte imgAddr|
 addr >= eachSpace start ifTrue:[
 addr <= eachSpace end ifTrue:[
 imgAddr := eachSpace imageBase + (addr - eachSpace start).
-stream position:imgAddr.
+^ imgAddr
-ptr := stream nextUnsignedLongMSB:msb.
-^ ptr
 ]
 ].
 ].
-self halt:'image fetch error'.
+self halt:'image address error'.
 ! !
 !SnapShotImageMemory methodsFor:'private'!
 allClassesDo:aBlock
 |val|
 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.
+theSymbolPtr := stream nextUnsignedLongMSB:msb.
-theValue := stream nextUnsignedLongMSB:msb.
+theValuePtr := stream nextUnsignedLongMSB:msb.
-theSymbol ~~ 0
+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
 "
 (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
-spaceFlags spaceBase spaceSize classNameSize|
+classNameSize spaceSize|
 stream next:256.        "/ skip execCmd
 msb := false.
 order := stream nextUnsignedLongMSB:msb.
 ].
 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).
 ].
 nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
 (spaceInfos at:i) size:(stream nextUnsignedLongMSB:msb).
 ].
 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 |
 (spaceInfos at:i) end:((spaceInfos at:i) start + (spaceInfos at:i) size - 1).
 ].
 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 {
 "/        char            h_execCmd[256];
 "/
 Transcript showCR:className.
 ].
 !
 readSymbolEntries
-|refPointer theSymbol|
+|refPointer theSymbolPtr theSymbolRef pos|
 symbolEntries := OrderedCollection new.
 [
 refPointer := stream nextUnsignedLongMSB:msb.
-theSymbol := stream nextUnsignedLongMSB:msb.
+theSymbolPtr := stream nextUnsignedLongMSB:msb.
+theSymbolPtr ~~ 0
-theSymbol ~~ 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
 |refPointer theValue|
 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)"
 start:something
 "set the value of the instance variable 'start' (automatically generated)"
 start := something.! !
-!SnapShotImageMemory::ImageObject methodsFor:'accessing'!
+!SnapShotImageMemory::ImageObject methodsFor:'object protocol'!
-bits
+at:aSelector ifAbsent:exceptionValue
-"return the value of the instance variable 'bits' (automatically generated)"
+|symPtr symRef mthdPtr mthdRef s|
-^ bits!
+self isMethodDictionary ifTrue:[
+1 to:self size by:2 do:[:idx |
-bits:something
+symPtr := self at:idx.
-"set the value of the instance variable 'bits' (automatically generated)"
+symRef := memory fetchObjectAt:symPtr.
+symRef isImageSymbol ifFalse:[self halt].
-bits := something.!
+s := memory fetchStringFor:symRef.
+mthdPtr := self at:idx + 1.
-classRef
+mthdRef := memory fetchObjectAt:mthdPtr.
-"return the value of the instance variable 'classRef' (automatically generated)"
+^ mthdRef.
+].
-^ classRef!
+].
+^ exceptionValue value
-classRef:something
+!
-"set the value of the instance variable 'classRef' (automatically generated)"
+do:aBlock
-classRef := something.!
+|mthdPtr mthdRef|
-size
+self isMethodDictionary ifTrue:[
-"return the value of the instance variable 'size' (automatically generated)"
+2 to:self size by:2 do:[:idx |
+mthdPtr := self at:idx.
-^ size!
+mthdRef := memory fetchObjectAt:mthdPtr.
+aBlock value:mthdRef.
-size:something
+].
-"set the value of the instance variable 'size' (automatically generated)"
+].
+!
-size := something.! !
+isWrapped
-!SnapShotImageMemory::ImageObject methodsFor:'queries'!
+^ false
+!
-isImageBehavior
+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 := flags bitShift:-1.
+^ flags bitShift:-1.
-^ flags bitTest:Behavior flagBehavior
-!
-isImageBytes
-self halt.
-!
-isImageString
-self halt.
-!
-isImageSymbol
-self halt.
-! !
-!SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!
-categorySlot
-^ self at:8
-!
-classFilenameSlot
-^ self at:12
-!
-classVarsSlot
-^ self at:9
-!
-commentSlot
-^ self at:10
 !
 flagsSlot
 ^ self at:2
 !
-flagsValue
-|flags|
-flags := self flagsSlot.
-(SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
-self halt
-].
-^ flags bitShift:-1.
-!
 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
 revisionSlot
 ^ 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

changeset 1417	28d6026fe30c
parent 1416	eec0911414fe
child 1419	f808d17ff6f5