--- a/SnapShotImage.st Thu Aug 23 10:33:10 2001 +0200
+++ b/SnapShotImage.st Wed Sep 05 18:45:04 2001 +0200
@@ -1,7 +1,7 @@
"{ Package: 'stx:libtool2' }"
Object subclass:#SnapShotImage
- instanceVariableNames:'memory globals'
+ instanceVariableNames:'memory globals cachedBehaviors'
classVariableNames:''
poolDictionaries:''
category:'System-Support'
@@ -71,19 +71,24 @@
!SnapShotImage methodsFor:'smalltalk protocol'!
allClassesDo:aBlock
- self keysAndValuesDo:[:key :valRef |
- valRef isInteger ifFalse:[
- valRef ~~ true ifTrue:[
- valRef ~~ false ifTrue:[
- valRef notNil ifTrue:[
- valRef isImageBehavior ifTrue:[
- aBlock value:valRef
+ cachedBehaviors isNil ifTrue:[
+ cachedBehaviors := OrderedCollection new.
+
+ self keysAndValuesDo:[:key :valRef |
+ valRef isInteger ifFalse:[
+ valRef ~~ true ifTrue:[
+ valRef ~~ false ifTrue:[
+ valRef notNil ifTrue:[
+ valRef isImageBehavior ifTrue:[
+ cachedBehaviors add:valRef
+ ]
]
]
]
]
- ]
+ ].
].
+ cachedBehaviors do:aBlock
!
allClassesInCategory:aCategory
--- a/SnapShotImageMemory.st Thu Aug 23 10:33:10 2001 +0200
+++ b/SnapShotImageMemory.st Wed Sep 05 18:45:04 2001 +0200
@@ -29,8 +29,15 @@
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
@@ -166,7 +173,8 @@
!
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:[
@@ -194,8 +202,9 @@
classRef := self fetchClassObjectAt:classPtr.
- flags := classRef flags bitAnd:Behavior maskIndexType.
- (flags = Behavior flagBytes) ifTrue:[
+ flags := classRef flags.
+ indexTypeFlags := flags bitAnd:Behavior maskIndexType.
+ (indexTypeFlags = Behavior flagBytes) ifTrue:[
nBytes := (size - (intSize * 3)).
o := ImageByteObject new:nBytes.
o classRef:classRef.
@@ -216,21 +225,25 @@
"/Transcript cr.
] ifFalse:[
- (flags = Behavior flagNotIndexed) ifFalse:[
- (flags ~= Behavior flagPointers) ifTrue:[
- (flags ~= Behavior flagWeakPointers) ifTrue:[
+ (indexTypeFlags = Behavior flagNotIndexed) ifFalse:[
+ (indexTypeFlags ~= Behavior flagPointers) 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].
@@ -937,6 +950,10 @@
^ false
!
+isObsolete
+ ^ false
+!
+
isPrivate
^ false
!
@@ -1071,35 +1088,7 @@
!
source
- |sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk|
-
- 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.
+ self halt:'unimplemented'.
!
sourceFilename
@@ -1337,19 +1326,81 @@
^ 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 := self categorySlot.
- categoryRef isInteger ifTrue:[
- categoryRef := memory fetchObjectAt:categoryRef.
+ |categoryRef|
+
+ cachedCategory isNil ifTrue:[
+ categoryRef := self categorySlot.
+ categoryRef isInteger ifTrue:[
+ categoryRef := memory fetchObjectAt:categoryRef.
+ ].
+ categoryRef notNil ifTrue:[
+ cachedCategory := memory fetchStringFor:categoryRef.
+ ].
].
- categoryRef notNil ifTrue:[
- category := memory fetchStringFor:categoryRef.
- ].
- ^ category
+ ^ cachedCategory
!
categorySlot
@@ -1396,7 +1447,7 @@
].
].
].
- ^ classVarNames
+ ^ classVarNames ? #()
!
classVariableString
@@ -1436,13 +1487,16 @@
flags
|flags amount|
- flags := self flagsSlot.
-
- (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
- self halt
+ cachedFlags isNil ifTrue:[
+ flags := self flagsSlot.
+
+ (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
+ self halt
+ ].
+ amount := -1.
+ cachedFlags := flags bitShift:amount.
].
- amount := -1.
- ^ flags bitShift:amount.
+ ^ cachedFlags
!
flagsSlot
@@ -1506,23 +1560,23 @@
!
name
- |nameRef name|
-
- self isMeta ifTrue:[
- ^ self theNonMetaclass name , ' class'
+ |nameRef|
+
+ cachedName isNil ifTrue:[
+ self isMeta ifTrue:[
+ cachedName := self theNonMetaclass name , ' class'
+ ] ifFalse:[
+ nameRef := self nameSlot.
+ nameRef isInteger ifTrue:[
+ nameRef := memory fetchObjectAt:nameRef.
+ ].
+ nameRef notNil ifTrue:[
+ cachedName := memory fetchStringFor:nameRef.
+ cachedName := cachedName asSymbol
+ ].
+ ].
].
-
- nameRef := self nameSlot.
- nameRef isInteger ifTrue:[
- nameRef := memory fetchObjectAt:nameRef.
- ].
- nameRef notNil ifTrue:[
- name := memory fetchStringFor:nameRef.
- ].
- nameRef notNil ifTrue:[
- name := name asSymbol.
- ].
- ^ name
+ ^ cachedName
!
nameSlot
@@ -1634,7 +1688,7 @@
"/ 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 |
@@ -2313,14 +2367,14 @@
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.
@@ -2333,7 +2387,7 @@
aStream cr.
self allSuperclassesDo:[:aSuperClass |
aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
- aStream nextPutLine:(aSuperClass class instanceVariableString).
+ aStream nextPutLine:(aSuperClass theMetaclass instanceVariableString).
].
].
@@ -2783,8 +2837,19 @@
"Modified: 22.8.1997 / 14:59:14 / cg"
!
-isObsolete
- ^ false
+isObsolete
+ "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
@@ -2914,6 +2979,24 @@
"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|
@@ -3590,7 +3673,7 @@
"/ 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
].
@@ -3648,6 +3731,36 @@
^ 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"
@@ -3661,10 +3774,6 @@
theSuperClass := theSuperClass superclass
].
^ aCollection
-
- "
- String withAllSuperclasses
- "
!
withAllSuperclassesDo:aBlock
@@ -3707,6 +3816,10 @@
^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagFloats.
!
+isImageBehavior
+ ^ true
+!
+
isLoaded
|superclass|