hg/stx-libtool2: comparison SnapShotImageMemory.st

equal deleted inserted replaced

-:32f1fd9d0f15
+:13fe76a0986b
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
+SnapShotImageMemory::ImageObject variableSubclass:#ImageMethodObject
+	instanceVariableNames:'cachedPackage'
+	classVariableNames:''
+	poolDictionaries:''
+	privateIn:SnapShotImageMemory
+!
 SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject
-	instanceVariableNames:''
+	instanceVariableNames:'cachedCategory cachedFlags cachedName'
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
 o memory:self.
 ^ o
 !
 fetchObjectAt:baseAddr
-|addr classPtr classRef size bits o nBytes nInsts flags imgAddr|
+|addr classPtr classRef size bits o nBytes nInsts flags indexTypeFlags imgAddr
+|
 baseAddr == 0 ifTrue:[^ nil].
 (baseAddr bitAnd:1) == 1 ifTrue:[(baseAddr bitTest:16r80000000) ifTrue:[
 ^ (baseAddr - 16r100000000) bitShift32:-1
 ] ifFalse:[
 self halt
 ].
 classRef := self fetchClassObjectAt:classPtr.
-flags := classRef flags bitAnd:Behavior maskIndexType.
+flags := classRef flags.
-(flags = Behavior flagBytes) ifTrue:[
+indexTypeFlags := flags bitAnd:Behavior maskIndexType.
+(indexTypeFlags = Behavior flagBytes) ifTrue:[
 nBytes := (size - (intSize * 3)).
 o := ImageByteObject new:nBytes.
 o classRef:classRef.
 size > 8000 ifTrue:[self halt].
 o byteSize:size.
 "/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:[
+(indexTypeFlags = Behavior flagNotIndexed) ifFalse:[
-(flags ~= Behavior flagPointers) ifTrue:[
+(indexTypeFlags ~= Behavior flagPointers) ifTrue:[
-(flags ~= Behavior flagWeakPointers) ifTrue:[
+(indexTypeFlags ~= Behavior flagWeakPointers) ifTrue:[
 self halt
 ]
 ].
 ].
 nInsts := (size - (intSize * 3)) // intSize.
-(classRef flags bitTest:Behavior flagBehavior)
+(flags bitTest:Behavior flagBehavior)
 "/ classRef isImageBehavior
 ifTrue:[
 o := ImageClassObject new:nInsts.
 ] ifFalse:[
-o := ImageObject new:nInsts.
+(flags bitTest:Behavior flagMethod) ifTrue:[
+o := ImageMethodObject new:nInsts.
+] ifFalse:[
+o := ImageObject new:nInsts.
+]
 ].
 o classRef:classRef.
 size > 8000 ifTrue:[self halt].
 o byteSize:size.
 o bits:bits.
 isIgnored
 ^ false
 !
+isObsolete
+^ false
+!
 isPrivate
 ^ false
 !
 isProtected
 resources
 ^ nil
 !
 source
-|sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk|
+self halt:'unimplemented'.
-self isMethodOrLazyMethod ifTrue:[
-sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
-sourcePtr := self at:(Method instVarOffsetOf:'source').
-sourceRef := memory fetchObjectAt:sourcePtr.
-sourceRef isString ifFalse:[
-self halt.
-].
-source := memory printStringOfString:sourceRef.
-sourcePosition := memory fetchObjectAt:sourcePositionPtr.
-sourcePosition isNil ifTrue:[
-^ source
-].
-aStream := self sourceStream.
-aStream notNil ifTrue:[
-Stream positionErrorSignal handle:[:ex |
-^ nil
-] do:[
-aStream position:sourcePosition abs.
-].
-junk := aStream nextChunk.
-aStream close.
-^ junk
-].
-].
-self halt.
 !
 sourceFilename
 "return the sourcefilename if source is extern; nil otherwise"
 size
 ^ byteSize
 ! !
+!SnapShotImageMemory::ImageMethodObject methodsFor:'method protocol'!
+package
+|packageSlotOffset packagePtr packageRef package|
+cachedPackage isNil ifTrue:[
+packageSlotOffset := Method instVarOffsetOf:'package'.
+packagePtr := self at:packageSlotOffset.
+packageRef := memory fetchObjectAt:packagePtr.
+packageRef isNil ifTrue:[^ nil].
+packageRef isImageSymbol ifFalse:[
+packageRef isImageBytes ifFalse:[
+self halt.
+].
+"/ mhmh - can be a string sometimes ...
+].
+package := memory fetchStringFor:packageRef.
+cachedPackage := package asSymbol
+].
+^ cachedPackage
+!
+source
+|sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk|
+sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
+sourcePtr := self at:(Method instVarOffsetOf:'source').
+sourceRef := memory fetchObjectAt:sourcePtr.
+sourceRef isString ifFalse:[
+self halt.
+].
+source := memory printStringOfString:sourceRef.
+sourcePosition := memory fetchObjectAt:sourcePositionPtr.
+sourcePosition isNil ifTrue:[
+^ source
+].
+aStream := self sourceStream.
+aStream notNil ifTrue:[
+Stream positionErrorSignal handle:[:ex |
+^ nil
+] do:[
+aStream position:sourcePosition abs.
+].
+junk := aStream nextChunk.
+aStream close.
+^ junk
+].
+self halt.
+! !
+!SnapShotImageMemory::ImageMethodObject methodsFor:'queries'!
+isMethod
+^ true
+! !
 !SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!
 category
-|categoryRef category|
+|categoryRef|
-categoryRef := self categorySlot.
+cachedCategory isNil ifTrue:[
-categoryRef isInteger ifTrue:[
+categoryRef := self categorySlot.
-categoryRef := memory fetchObjectAt:categoryRef.
+categoryRef isInteger ifTrue:[
-].
+categoryRef := memory fetchObjectAt:categoryRef.
-categoryRef notNil ifTrue:[
+].
-category := memory fetchStringFor:categoryRef.
+categoryRef notNil ifTrue:[
-].
+cachedCategory := memory fetchStringFor:categoryRef.
-^ category
+].
+].
+^ cachedCategory
 !
 categorySlot
 ^ self at:(Class instVarOffsetOf:'category')
 !
 s := memory fetchStringFor:s.
 classVarNames at:idx put:s.
 ].
 ].
 ].
-^ classVarNames
+^ classVarNames ? #()
 !
 classVariableString
 |classVarsPtr classVarsRef classVars|
 !
 flags
 |flags amount|
-flags := self flagsSlot.
+cachedFlags isNil ifTrue:[
+flags := self flagsSlot.
-(SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
-self halt
+(SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
-].
+self halt
-amount := -1.
+].
-^ flags bitShift:amount.
+amount := -1.
+cachedFlags := flags bitShift:amount.
+].
+^ cachedFlags
 !
 flagsSlot
 ^ self at:(Class instVarOffsetOf:'flags')
 !
 methodDictionarySlot
 ^ self at:(Class instVarOffsetOf:'methodDictionary')
 !
 name
-|nameRef name|
+|nameRef|
-self isMeta ifTrue:[
+cachedName isNil ifTrue:[
-^ self theNonMetaclass name , ' class'
+self isMeta ifTrue:[
-].
+cachedName := self theNonMetaclass name , ' class'
+] ifFalse:[
 nameRef := self nameSlot.
 nameRef isInteger ifTrue:[
 nameRef := memory fetchObjectAt:nameRef.
 ].
 nameRef notNil ifTrue:[
-name := memory fetchStringFor:nameRef.
+cachedName := memory fetchStringFor:nameRef.
-].
+cachedName := cachedName asSymbol
-nameRef notNil ifTrue:[
+].
-name := name asSymbol.
+].
 ].
-^ name
+^ cachedName
 !
 nameSlot
 ^ self at:(Class instVarOffsetOf:'name')
 !
 self isMeta ifTrue:[
 "/ metaclasses are not found via Smalltalk allClassesDo:
 "/ here, walk over classes and enumerate corresponding metas.
 self soleInstance allSubclassesDo:[:aSubClass |
-aBlock value:(aSubClass class)
+aBlock value:(aSubClass theMetaclass)
 ].
 ] ifFalse:[
 Smalltalk allClassesDo:[:aClass |
 (aClass isSubclassOf:self) ifTrue:[
 aBlock value:aClass
 self name printOn:aStream.
 ] ifFalse:[
 self printClassNameOn:aStream.
 ].
 aStream nextPutAll:' class instanceVariableNames:'''.
-self class printInstVarNamesOn:aStream indent:8.
+self theMetaclass printInstVarNamesOn:aStream indent:8.
 aStream nextPutAll:''''.
 "mhmh - good idea; saw this in SmallDraw sourcecode ..."
 anySuperClassInstVar := false.
 self allSuperclassesDo:[:aSuperClass |
-aSuperClass class instVarNames do:[:ignored | anySuperClassInstVar := true].
+aSuperClass theMetaclass instVarNames do:[:ignored | anySuperClassInstVar := true].
 ].
 aStream cr; cr; nextPut:(Character doubleQuote); cr; space.
 anySuperClassInstVar ifFalse:[
 aStream
 aStream
 nextPutLine:'The following class instance variables are inherited by this class:'.
 aStream cr.
 self allSuperclassesDo:[:aSuperClass |
 aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
-aStream nextPutLine:(aSuperClass class instanceVariableString).
+aStream nextPutLine:(aSuperClass theMetaclass instanceVariableString).
 ].
 ].
 aStream nextPut:(Character doubleQuote); cr.
 "
 "Modified: 22.8.1997 / 14:59:14 / cg"
 !
 isObsolete
-^ false
+"return true, if the receiver is obsolete
+(i.e. has been replaced by a different class or was removed,
+but is still referenced by instanced)"
+|cat|
+cat := self category.
+^ cat = 'obsolete'
+or:[cat = 'removed'
+or:[cat = '* removed *'
+or:[cat = '* obsolete *']]]
 !
 isSubclassOf:aClass
 "return true, if I am a subclass of the argument, aClass"
 ]
 ].
 ^ nil
 "Modified: / 18.7.1998 / 22:53:19 / cg"
+!
+lookupMethodFor:aSelector
+"return the method, which would be executed if aSelector was sent to
+an instance of the receiver. I.e. the selector arrays of the receiver
+and all of its superclasses are searched for aSelector.
+Return the method, or nil if instances do not understand aSelector.
+EXPERIMENTAL: take care of multiple superclasses."
+|m cls|
+cls := self.
+[cls notNil] whileTrue:[
+m := cls compiledMethodAt:aSelector.
+m notNil ifTrue:[^ m].
+cls := cls superclass
+].
+^ nil
 !
 nameWithoutNameSpacePrefix
 |nm owner|
 self isMeta ifTrue:[
 self halt.
 "/ metaclasses are not found via Smalltalk allClassesDo:
 "/ here, walk over classes and enumerate corresponding metas.
 self soleInstance subclassesDo:[:aSubClass |
-aBlock value:(aSubClass class)
+aBlock value:(aSubClass theMetaclass)
 ].
 ^ self
 ].
 "/ use cached information (avoid class hierarchy search)
 against the version string as contained in the version method"
 ^ true
 !
+whichClassDefinesClassVar:aVariableName
+"return the class which defines the class variable
+named aVariableName. This method should not be used for
+repeated searches (i.e. in the compiler/parser), since it creates
+many throw away intermediate objects."
+|cls|
+cls := self.
+[cls notNil] whileTrue:[
+(cls classVarNames includes:aVariableName) ifTrue:[ ^ cls].
+cls := cls superclass
+].
+^ nil
+!
+whichClassIncludesSelector:aSelector
+"return the class in the inheritance chain, which implements the method
+for aSelector; return nil if none."
+|cls|
+cls := self.
+[cls notNil] whileTrue:[
+(cls includesSelector:aSelector) ifTrue:[^ cls].
+cls := cls superclass
+].
+^ nil
+!
 withAllSuperclasses
 "return a collection containing the receiver and all
 of the receivers accumulated superclasses"
 |aCollection theSuperClass|
 [theSuperClass notNil] whileTrue:[
 aCollection add:theSuperClass.
 theSuperClass := theSuperClass superclass
 ].
 ^ aCollection
-"
-String withAllSuperclasses
-"
 !
 withAllSuperclassesDo:aBlock
 |sc|
 ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagDoubles.
 !
 isFloats
 ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagFloats.
+!
+isImageBehavior
+^ true
 !
 isLoaded
 |superclass|

changeset 1482	13fe76a0986b
parent 1469	b726d8a4b801
child 1484	089067851973