diff -r eec0911414fe -r 28d6026fe30c SnapShotImageMemory.st --- 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