hg/stx-libtool2: comparison SnapShotImageMemory.st

equal deleted inserted replaced

-:7466259d8bb5
+:f808d17ff6f5
-'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:''
 	privateIn:SnapShotImageMemory
 !
+SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
+	instanceVariableNames:''
+	classVariableNames:''
+	poolDictionaries:''
+	privateIn:SnapShotImageMemory
+!
 Object subclass:#SpaceInfo
 	instanceVariableNames:'start end size flags imageBase'
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
 SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject
-	instanceVariableNames:''
+	instanceVariableNames:'cachedContents'
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
 SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject
-	instanceVariableNames:''
-	classVariableNames:''
-	poolDictionaries:''
-	privateIn:SnapShotImageMemory
-!
-SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
 	instanceVariableNames:''
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:SnapShotImageMemory
 !
 globalEntries isNil ifTrue:[
 self readHeader.
 self readGlobals.
 ].
 !
+fetchByteArrayFor:aByteArrayRef
+|nBytes|
+(aByteArrayRef isImageBytes) ifFalse:[self halt].
+nBytes := aByteArrayRef byteSize - (intSize * 3).
+^ ((ByteArray new:nBytes) replaceFrom:1 to:nBytes-1 with:aByteArrayRef startingAt:1).!
 fetchStringFor:aStringRef
 |nBytes|
 (aStringRef isImageBytes) ifFalse:[self halt].
 ^ category
 ].
 self halt.
 !
+isBehavior
+^ self isImageBehavior!
 isImageBehavior
 |flags|
 flags := classRef flags.
 ^ flags bitTest:Behavior flagBehavior
 |flags|
 flags := classRef flags.
 ^ flags bitTest:Behavior flagSymbol
 !
+isLazyMethod
+^ classRef name = 'LazyMethod'!
 isMeta
 ^ false
 !
 isString
 ^ classRef name = 'String'
 ! !
+!SnapShotImageMemory::ImageByteObject methodsFor:'queries'!
+size
+^ byteSize
+! !
 !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:'object protocol'!
+!SnapShotImageMemory::ImageObject methodsFor:'method protocol'!
-at:aSelector ifAbsent:exceptionValue
+byteCode
-|symPtr symRef mthdPtr mthdRef s|
+|byteCodeSlotOffset byteCodePtr byteCodeRef byteCode|
-self isMethodDictionary ifTrue:[
+self isMethod ifTrue:[
-1 to:self size by:2 do:[:idx |
+byteCodeSlotOffset := Method instVarOffsetOf:'byteCode'.
-symPtr := self at:idx.
+].
-symRef := memory fetchObjectAt:symPtr.
+byteCodeSlotOffset notNil ifTrue:[
-symRef isImageSymbol ifFalse:[self halt].
+byteCodePtr := self at:byteCodeSlotOffset.
-s := memory fetchStringFor:symRef.
+byteCodeRef := memory fetchObjectAt:byteCodePtr.
-mthdPtr := self at:idx + 1.
+byteCodeRef isNil ifTrue:[^ nil].
-mthdRef := memory fetchObjectAt:mthdPtr.
-^ mthdRef.
+byteCode := memory fetchByteArrayFor:byteCodeRef.
-].
+^ byteCode
 ].
-^ exceptionValue value
-!
+self halt.
+!
-do:aBlock
-|mthdPtr mthdRef|
+comment
+|src comment comments parser|
-self isMethodDictionary ifTrue:[
-2 to:self size by:2 do:[:idx |
+self isMethod ifTrue:[
-mthdPtr := self at:idx.
+src := self source.
-mthdRef := memory fetchObjectAt:mthdPtr.
+src isNil ifTrue:[^ nil].
-aBlock value:mthdRef.
-].
+parser := Parser for:src in:nil.
-].
+parser ignoreErrors; ignoreWarnings; saveComments:true.
-!
+parser parseMethodSpec.
+comments := parser comments.
+comments size ~~ 0 ifTrue:[
+comment := comments first string.
+(comment withoutSpaces endsWith:'}') ifTrue:[
+"if first comment is a pragma, take next comment"
+comment := comments at:2 ifAbsent:nil.
+comment notNil ifTrue:[
+comment := comment string.
+].
+].
+].
+^ comment.
+].
+self isLazyMethod ifTrue:[
+^ ''
+].
+self halt.
+!
+containingClass
+self isMethodOrLazyMethod ifTrue:[
+^ self mclass
+].
+self halt.!
+hasCode
+^ false!
+isBreakpointed
+^ false!
+isCounting
+^ false!
+isCountingMemoryUsage
+^ false!
+isDynamic
+^ false!
+isExecutable
+self isMethod ifTrue:[
+^ false
+].
+self halt.!
+isIgnored
+^ false!
+isJavaMethod
+^ self class name = 'JavaMethod'!
+isPrivate
+^ false!
+isProtected
+^ false!
+isPublic
+^ true!
+isTimed
+^ false!
+isTraced
+^ false!
 isWrapped
 ^ false
 !
-keysAndValuesDo:aBlock
+mclass
-|symPtr symRef mthdPtr mthdRef s|
+|mclassSlotOffset mclassPtr mclass|
-self isMethodDictionary ifTrue:[
+self isMethod ifTrue:[
-1 to:self size by:2 do:[:idx |
+mclassSlotOffset := Method instVarOffsetOf:'mclass'.
-symPtr := self at:idx.
+mclassPtr := self at:mclassSlotOffset.
-symRef := memory fetchObjectAt:symPtr.
+mclassPtr ~~ 0 ifTrue:[
-symRef isImageSymbol ifFalse:[self halt].
+mclass := memory fetchObjectAt:mclassPtr.
-s := memory fetchStringFor:symRef.
+mclass isImageBehavior ifFalse:[
-mthdPtr := self at:idx + 1.
+self halt
-mthdRef := memory fetchObjectAt:mthdPtr.
+].
-aBlock value:s asSymbol value:mthdRef.
+^ mclass
 ].
-].
-!
+"/ search my class ...
+memory image allClassesDo:[:eachClass |
+eachClass theNonMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
+mthdRef == self ifTrue:[
+self at:mclassSlotOffset put:eachClass theNonMetaclass.
+^ eachClass theNonMetaclass
+].
+].
+eachClass theMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
+mthdRef == self ifTrue:[
+self at:mclassSlotOffset put:eachClass theMetaclass.
+^ eachClass theMetaclass
+].
+]
+].
+self halt.
+].
+self halt.
+!
+numArgs
+|flagsSlotOffset flagsPtr flags|
+self isMethod ifTrue:[
+flagsSlotOffset := Method instVarOffsetOf:'flags'.
+].
+flagsSlotOffset notNil ifTrue:[
+flagsPtr := self at:flagsSlotOffset.
+flags := memory fetchObjectAt:flagsPtr.
+^ (flags bitAnd:(Method numArgsMaskInFlags)) bitShift:(Method numArgsShiftInFlags negated)
+].
+self halt.
+!
+package
+|packageSlotOffset packagePtr packageRef package|
+self isImageBehavior ifTrue:[
+self isMeta ifTrue:[
+^ self theNonMetaclass package
+].
+packageSlotOffset := Class instVarOffsetOf:'package'.
+].
+self isMethod ifTrue:[
+packageSlotOffset := Method instVarOffsetOf:'package'.
+].
+packageSlotOffset notNil ifTrue:[
+packagePtr := self at:packageSlotOffset.
+packageRef := memory fetchObjectAt:packagePtr.
+packageRef isNil ifTrue:[^ nil].
+packageRef isImageSymbol ifFalse:[
+self halt.
+].
+package := memory fetchStringFor:packageRef.
+^ package asSymbol
+].
+self isMeta ifTrue:[
+self halt
+].
+self halt.
+!
+previousVersion
+^ nil!
 printStringForBrowserWithSelector:selector
 ^ selector
 !
+privacy
+^ #public!
 resources
 ^ nil
 !
 source
-|sourcePosition source aStream junk|
+|sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk|
-self isMethod ifTrue:[
+self isMethodOrLazyMethod ifTrue:[
-sourcePosition := self at:(Method instVarOffsetOf:'sourcePosition').
+sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
-source := self at:(Method instVarOffsetOf:'source').
+sourcePtr := self at:(Method instVarOffsetOf:'source').
-source := memory fetchObjectAt:source.
+sourceRef := memory fetchObjectAt:sourcePtr.
-source isString ifFalse:[
+sourceRef isString ifFalse:[
 self halt.
 ].
-source := memory printStringOfString:source.
+source := memory printStringOfString:sourceRef.
+sourcePosition := memory fetchObjectAt:sourcePositionPtr.
 sourcePosition isNil ifTrue:[
-self halt.
 ^ source
 ].
-sourcePosition := memory fetchObjectAt:sourcePosition.
 aStream := self sourceStream.
 aStream notNil ifTrue:[
 Stream positionErrorSignal handle:[:ex |
 ^ nil
 ^ junk
 ].
 ].
 self halt.
 !
+sourceFilename
+"return the sourcefilename if source is extern; nil otherwise"
+self isMethodOrLazyMethod ifTrue:[
+self sourcePosition notNil ifTrue:[^ self source].
+^ nil
+].
+self halt.!
+sourceLineNumber
+self isMethodOrLazyMethod ifTrue:[
+^ 1
+].
+self halt.
+!
+sourcePosition
+|sourcePosition|
+self isMethodOrLazyMethod ifTrue:[
+sourcePosition := self sourcePositionValue.
+sourcePosition isNil ifTrue:[^ sourcePosition].
+^ sourcePosition abs
+].
+self halt.!
+sourcePositionValue
+|sourcePosition sourcePositionPtr|
+self isMethodOrLazyMethod ifTrue:[
+sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
+sourcePosition := memory fetchObjectAt:sourcePositionPtr.
+^ sourcePosition
+].
+self halt.!
 sourceStream
 |sourcePosition source aStream fileName junk who
 myClass mgr className sep dir mod package|
 ^ nil
 ].
 self halt.
 ! !
+!SnapShotImageMemory::ImageObject methodsFor:'methodDictionary protocol'!
+at:aSelector ifAbsent:exceptionValue
+self isMethodDictionary ifTrue:[
+cachedContents isNil ifTrue:[
+self cacheMethodDictionary.
+].
+^ cachedContents at:aSelector ifAbsent:exceptionValue
+].
+self halt.!
+cacheMethodDictionary
+|symPtr symRef mthdPtr mthdRef s|
+cachedContents isNil ifTrue:[
+cachedContents := IdentityDictionary new.
+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.
+cachedContents at:s asSymbol put:mthdRef.
+].
+].!
+do:aBlock
+self isMethodDictionary ifTrue:[
+cachedContents isNil ifTrue:[
+self cacheMethodDictionary.
+].
+cachedContents do:aBlock.
+^ self.
+].
+self halt.
+!
+includesKey:aSelector
+self isMethodDictionary ifTrue:[
+cachedContents isNil ifTrue:[
+self cacheMethodDictionary.
+].
+^ cachedContents includesKey:aSelector
+].
+self halt.!
+keyAtValue:aMethod ifAbsent:exceptionValue
+self isMethodDictionary ifTrue:[
+cachedContents isNil ifTrue:[
+self cacheMethodDictionary.
+].
+^ cachedContents keyAtValue:aMethod ifAbsent:exceptionValue
+].
+self halt.!
+keysAndValuesDo:aBlock
+self isMethodDictionary ifTrue:[
+cachedContents isNil ifTrue:[
+self cacheMethodDictionary.
+].
+cachedContents keysAndValuesDo:[:sel :mthdRef |
+aBlock value:sel value:mthdRef.
+].
+^ self
+].
+self halt.
+! !
 !SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!
 category
 |categoryRef category|
 ].
 ^ category
 !
 categorySlot
-^ self at:8
+^ self at:(Class instVarOffsetOf:'category')!
-!
+classFilename
+|classFilenameRef classFilename|
+classFilenameRef := self classFilenameSlot.
+classFilenameRef isInteger ifTrue:[
+classFilenameRef := memory fetchObjectAt:classFilenameRef.
+].
+classFilenameRef notNil ifTrue:[
+classFilename := memory fetchStringFor:classFilenameRef.
+].
+^ classFilename!
 classFilenameSlot
-^ self at:12
+^ self at:(Class instVarOffsetOf:'classFilename')!
-!
 classVarNames
 |classVarNamesRef classVarNames s|
 classVarNamesRef := self classVarsSlot.
 ].
 ].
 ^ classVarNames
 !
+classVariableString
+|classVarsPtr classVarsRef classVars|
+(classVarsPtr := self classVarsSlot) == 0 ifTrue:[^ ''].
+classVarsRef := memory fetchObjectAt:classVarsPtr.
+classVarsRef isImageBytes ifTrue:[
+"/ a string
+classVars := memory fetchStringFor:classVarsRef.
+^ classVars
+].
+^ self classVarNames asStringWith:(Character space)
+!
 classVarsSlot
 ^ self at:9
 !
 comment
 ].
 ^ comment
 !
 commentSlot
-^ self at:10
+^ self at:(Class instVarOffsetOf:'comment')!
-!
 flags
 |flags|
 flags := self flagsSlot.
 ].
 ^ flags bitShift:-1.
 !
 flagsSlot
-^ self at:2
+^ self at:(Class instVarOffsetOf:'flags')!
-!
+instSize
+|instSizeRef|
+instSizeRef := self instSizeSlot.
+^ memory fetchObjectAt:instSizeRef.!
 instSizeSlot
-^ self at:5
+^ self at:(Class instVarOffsetOf:'instSize')!
-!
 instVarNames
 |instVarNamesRef instVarNames s|
 instVarNamesRef := self instVarsSlot.
 s := memory fetchStringFor:s.
 instVarNames at:idx put:s.
 ].
 ].
 ].
-^ instVarNames
+^ instVarNames ? #()!
-!
 instVarsSlot
 ^ self at:6
 !
 ].
 ^ methodDictionary
 !
 methodDictionarySlot
-^ self at:3
+^ self at:(Class instVarOffsetOf:'methodDictionary')!
-!
 name
 |nameRef name|
+self isMeta ifTrue:[
+^ self theNonMetaclass name , ' class'
+].
 nameRef := self nameSlot.
 nameRef isInteger ifTrue:[
 nameRef := memory fetchObjectAt:nameRef.
 ].
 ].
 ^ name
 !
 nameSlot
-^ self at:7
+^ self at:(Class instVarOffsetOf:'name')!
-!
 packageSlot
-^ self at:13
+^ self at:(Class instVarOffsetOf:'package')!
-!
+primitiveSpec
+|primitiveSpecRef primitiveSpec|
+primitiveSpecRef := self primitiveSpecSlot.
+primitiveSpecRef isInteger ifTrue:[
+primitiveSpecRef := memory fetchObjectAt:primitiveSpecRef.
+].
+primitiveSpecRef notNil ifTrue:[
+primitiveSpec := memory fetchStringFor:primitiveSpecRef.
+].
+^ primitiveSpec
+!
+primitiveSpecSlot
+^ self at:(Class instVarOffsetOf:'primitiveSpec')!
+revision
+|revisionRef revision|
+revisionRef := self revisionSlot.
+revisionRef isInteger ifTrue:[
+revisionRef := memory fetchObjectAt:revisionRef.
+].
+revisionRef notNil ifTrue:[
+revision := memory fetchStringFor:revisionRef.
+].
+^ revision!
 revisionSlot
 ^ self at:14
 !
 ^ self at:1
 ! !
 !SnapShotImageMemory::ImageClassObject methodsFor:'class protocol'!
+addAllClassVarNamesTo:aCollection
+"helper - add the name-strings of the class variables and of the class-vars
+of all superclasses to the argument, aCollection. Return aCollection"
+|classvars superclass|
+(superclass := self superclass) notNil ifTrue:[
+superclass addAllClassVarNamesTo:aCollection
+].
+(classvars := self classVariableString) notNil ifTrue:[
+aCollection addAll:(classvars asCollectionOfWords).
+].
+^ aCollection!
+addAllInstVarNamesTo:aCollection
+|superInsts instvars superclass|
+(superclass := self superclass) notNil ifTrue:[
+self superclass addAllInstVarNamesTo:aCollection
+].
+aCollection addAll:self instVarNames.
+^ aCollection!
+addChangeRecordForClassFileOut:aClass!
+allClassVarNames
+"return a collection of all the class variable name-strings
+this includes all superclass-class variables"
+^ self addAllClassVarNamesTo:(OrderedCollection new)!
+allInstVarNames
+self superclass isNil ifTrue:[^ self instVarNames].
+^ self addAllInstVarNamesTo:(OrderedCollection new)!
+allSubclassesDo:aBlock
+"evaluate aBlock for all of my subclasses.
+There is no specific order, in which the entries are enumerated.
+Warning:
+This will only enumerate globally known classes - for anonymous
+behaviors, you have to walk over all instances of Behavior."
+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)
+].
+] ifFalse:[
+Smalltalk allClassesDo:[:aClass |
+(aClass isSubclassOf:self) ifTrue:[
+aBlock value:aClass
+]
+]
+]
+"
+Collection allSubclassesDo:[:c | Transcript showCR:(c name)]
+Collection class allSubclassesDo:[:c | Transcript showCR:(c name)]
+"
+"Modified: / 25.10.1997 / 21:17:13 / cg"
+!
+allSuperclasses
+"return a collection of the receivers accumulated superclasses"
+|aCollection theSuperClass|
+theSuperClass := self superclass.
+theSuperClass isNil ifTrue:[
+^ #()
+].
+aCollection := OrderedCollection new.
+[theSuperClass notNil] whileTrue:[
+aCollection add:theSuperClass.
+theSuperClass := theSuperClass superclass
+].
+^ aCollection
+"
+String allSuperclasses
+"!
+allSuperclassesDo:aBlock
+"evaluate aBlock for all of my superclasses"
+|theClass|
+theClass := self superclass.
+[theClass notNil] whileTrue:[
+aBlock value:theClass.
+theClass := theClass superclass
+]
+"
+String allSuperclassesDo:[:c | Transcript showCR:(c name)]
+"
+!
+basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace
+"append an expression on aStream, which defines myself."
+self
+basicFileOutDefinitionOn:aStream
+withNameSpace:forceNameSpace
+withPackage:true!
 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.
 aStream nextPutAll:nsName.
 syntaxHilighting ifTrue:[aStream normal].
 aStream nextPutAll:' }"'; cr; cr.
 ]
 ].
+superclass := self superclass.
+category := self category.
 "take care of nil-superclass"
 superclass isNil ifTrue:[
 s := 'nil'
 ] ifFalse:[
 ].
 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"
+"Modified: / 18.3.1999 / 18:15:46 / stefan"!
-!
 basicFileOutInstvarTypeKeywordOn:aStream
 "a helper for fileOutDefinition"
 |isVar s superclass|
 aStream nextPutAll:(self firstDefinitionSelectorPart).
 "Created: 11.10.1996 / 18:57:29 / cg"
 !
+binaryRevision
+"return the revision-ID from which the class was stc-compiled;
+nil if its an autoloaded or filedIn class.
+If a classes binary is up-to-date w.r.t. the source repository,
+the returned string is the same as the one returned by #revision."
+|owner info c revision|
+revision := self revision.
+(owner := self owningClass) notNil ifTrue:[^ owner binaryRevision].
+revision notNil ifTrue:[
+c := revision first.
+c == $$ ifTrue:[
+info := Class revisionInfoFromString:revision.
+info isNil ifTrue:[^ '0'].
+^ info at:#revision ifAbsent:'0'.
+].
+c isDigit ifFalse:[
+^ '0'
+].
+].
+^ revision
+"
+Object binaryRevision
+Object class binaryRevision
+"
+"
+to find all classes which are not up-to-date:
+|classes|
+classes := Smalltalk allClasses
+select:[:cls | cls binaryRevision notNil and:[cls binaryRevision ~= cls revision]].
+SystemBrowser browseClasses:classes title:'classes which are not up-to-date'
+"
+"Created: 7.12.1995 / 10:58:47 / cg"
+"Modified: 1.4.1997 / 23:33:01 / stefan"
+"Modified: 9.9.1997 / 12:05:41 / cg"!
 compiledMethodAt:aSelector
 ^ self compiledMethodAt:aSelector ifAbsent:nil
 !
 evaluatorClass
 ^ Object evaluatorClass
 !
+fileOut
+|baseName dirName nm fileName|
+baseName := (Smalltalk fileNameForClass:self name).
+nm := baseName asFilename withSuffix:'st'.
+"
+this test allows a smalltalk to be built without Projects/ChangeSets
+"
+Project notNil ifTrue:[
+dirName := Project currentProjectDirectory
+] ifFalse:[
+dirName := Filename currentDirectory
+].
+fileName := (dirName asFilename construct:nm).
+fileName makeLegalFilename.
+self fileOutAs:fileName name.
+"/    "
+"/     add a change record; that way, administration is much easier,
+"/     since we can see in that changeBrowser, which changes have
+"/     already found their way into a sourceFile and which must be
+"/     applied again
+"/    "
+"/    self addChangeRecordForClassFileOut:self
+"Modified: / 7.6.1996 / 09:14:43 / stefan"
+"Modified: / 27.8.1998 / 02:02:57 / cg"!
+fileOutAllDefinitionsOn:aStream
+"append expressions on aStream, which defines myself and all of my private classes."
+self fileOutDefinitionOn:aStream.
+aStream nextPutChunkSeparator.
+aStream cr; cr.
+"/
+"/ optional classInstanceVariables
+"/
+self classRef instanceVariableString isBlank ifFalse:[
+self fileOutClassInstVarDefinitionOn:aStream.
+aStream nextPutChunkSeparator.
+aStream cr; cr
+].
+"/ here, the full nameSpace prefixes are output,
+"/ to avoid confusing stc
+"/ (which otherwise could not find the correct superclass)
+"/
+Class fileOutNameSpaceQuerySignal answer:true do:[
+self privateClassesSorted do:[:aClass |
+aClass fileOutAllDefinitionsOn:aStream
+]
+].
+"Created: 15.10.1996 / 11:15:19 / cg"
+"Modified: 22.3.1997 / 16:11:56 / cg"!
+fileOutAs:fileNameString
+"create a file consisting of all methods in myself in
+sourceForm, from which the class can be reconstructed (by filing in).
+The given fileName should be a full path, including suffix.
+Care is taken, to not clobber any existing file in
+case of errors (for example: disk full).
+Also, since the classes methods need a valid sourcefile, the current
+sourceFile may not be rewritten."
+|aStream fileName newFileName savFilename needRename
+mySourceFileName sameFile s mySourceFileID anySourceRef|
+self isLoaded ifFalse:[
+^ Class fileOutErrorSignal
+raiseRequestWith:self
+errorString:'will not fileOut unloaded classes'
+].
+fileName := fileNameString asFilename.
+"
+if file exists, copy the existing to a .sav-file,
+create the new file as XXX.new-file,
+and, if that worked rename afterwards ...
+"
+(fileName exists) ifTrue:[
+sameFile := false.
+"/ check carefully - maybe, my source does not really come from that
+"/ file (i.e. all of my methods have their source as string)
+anySourceRef := false.
+self methodDictionary do:[:m|
+m sourcePosition notNil ifTrue:[
+anySourceRef := true
+]
+].
+self classRef methodDictionary do:[:m|
+m sourcePosition notNil ifTrue:[
+anySourceRef := true
+]
+].
+anySourceRef ifTrue:[
+s := self sourceStream.
+s notNil ifTrue:[
+mySourceFileID := s pathName asFilename info id.
+sameFile := (fileName info id) == mySourceFileID.
+s close.
+] ifFalse:[
+self classFilename notNil ifTrue:[
+"
+check for overwriting my current source file
+this is not allowed, since it would clobber my methods source
+file ... you have to save it to some other place.
+This happens if you ask for a fileOut into the source-directory
+(from which my methods get their source)
+"
+mySourceFileName := Smalltalk getSourceFileName:self classFilename.
+sameFile := (fileNameString = mySourceFileName).
+sameFile ifFalse:[
+mySourceFileName notNil ifTrue:[
+sameFile := (fileName info id) == (mySourceFileName asFilename info id)
+]
+].
+]
+].
+].
+sameFile ifTrue:[
+^ Class fileOutErrorSignal
+raiseRequestWith:fileNameString
+errorString:('may not overwrite sourcefile:', fileNameString)
+].
+savFilename := Filename newTemporary.
+fileName copyTo:savFilename.
+newFileName := fileName withSuffix:'new'.
+needRename := true
+] ifFalse:[
+"/ another possible trap: if my sourceFileName is
+"/ the same as the written one AND the new files directory
+"/ is along the sourcePath, we also need a temporary file
+"/ first, to avoid accessing the newly written file.
+anySourceRef := false.
+self methodDictionary do:[:m|
+|mSrc|
+(mSrc := m sourceFilename) notNil ifTrue:[
+mSrc asFilename baseName = fileName baseName ifTrue:[
+anySourceRef := true
+]
+]
+].
+self classRef methodDictionary do:[:m|
+|mSrc|
+(mSrc := m sourceFilename) notNil ifTrue:[
+mSrc asFilename baseName = fileName baseName ifTrue:[
+anySourceRef := true
+]
+]
+].
+anySourceRef ifTrue:[
+newFileName := fileName withSuffix:'new'.
+needRename := true
+] ifFalse:[
+newFileName := fileName.
+needRename := false
+]
+].
+aStream := newFileName writeStream.
+aStream isNil ifTrue:[
+savFilename notNil ifTrue:[
+savFilename delete
+].
+^ Class fileOutErrorSignal
+raiseRequestWith:newFileName
+errorString:('cannot create file:', newFileName name)
+].
+self fileOutOn:aStream.
+aStream close.
+"
+finally, replace the old-file
+be careful, if the old one is a symbolic link; in this case,
+we have to do a copy ...
+"
+needRename ifTrue:[
+newFileName copyTo:fileName.
+newFileName delete
+].
+savFilename notNil ifTrue:[
+savFilename delete
+].
+"
+add a change record; that way, administration is much easier,
+since we can see in that changeBrowser, which changes have
+already found their way into a sourceFile and which must be
+applied again
+"
+self addChangeRecordForClassFileOut:self
+"Modified: / 7.6.1996 / 09:14:43 / stefan"
+"Created: / 16.4.1997 / 20:44:05 / cg"
+"Modified: / 12.8.1998 / 11:14:56 / cg"!
+fileOutCategory:aCategory
+"create a file 'class-category.st' consisting of all methods in aCategory.
+If the current project is not nil, create the file in the projects
+directory."
+|aStream fileName|
+fileName := (self name , '-' , aCategory , '.st') asFilename.
+fileName makeLegalFilename.
+"/
+"/ this test allows a smalltalk to be built without Projects/ChangeSets
+"/
+Project notNil ifTrue:[
+fileName := Project currentProjectDirectory asFilename construct:(fileName name).
+].
+"/
+"/ if the file exists, save original in a .sav file
+"/
+fileName exists ifTrue:[
+fileName copyTo:(fileName withSuffix:'sav')
+].
+aStream := FileStream newFileNamed:fileName.
+aStream isNil ifTrue:[
+^ Class fileOutErrorSignal
+raiseRequestWith:fileName
+errorString:('cannot create file:', fileName pathName)
+].
+self fileOutCategory:aCategory on:aStream.
+aStream close
+"Modified: / 1.4.1997 / 16:00:24 / stefan"
+"Created: / 1.4.1997 / 16:04:18 / stefan"
+"Modified: / 28.10.1997 / 14:40:28 / cg"!
+fileOutCategory:aCategory except:skippedMethods only:savedMethods methodFilter:methodFilter on:aStream
+|dict source sortedSelectors first privacy interestingMethods cat|
+dict := self methodDictionary.
+dict notNil ifTrue:[
+interestingMethods := OrderedCollection new.
+dict do:[:aMethod |
+|wanted|
+(methodFilter isNil
+or:[methodFilter value:aMethod]) ifTrue:[
+(aCategory = aMethod category) ifTrue:[
+skippedMethods notNil ifTrue:[
+wanted := (skippedMethods includesIdentical:aMethod) not
+] ifFalse:[
+savedMethods notNil ifTrue:[
+wanted := (savedMethods includesIdentical:aMethod).
+] ifFalse:[
+wanted := true
+]
+].
+wanted ifTrue:[interestingMethods add:aMethod].
+]
+]
+].
+interestingMethods notEmpty ifTrue:[
+first := true.
+privacy := nil.
+"/
+"/ sort by selector
+"/
+sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m].
+sortedSelectors sortWith:interestingMethods.
+interestingMethods do:[:aMethod |
+first ifFalse:[
+privacy ~~ aMethod privacy ifTrue:[
+first := true.
+aStream space.
+aStream nextPutChunkSeparator.
+].
+aStream cr; cr
+].
+privacy := aMethod privacy.
+first ifTrue:[
+aStream nextPutChunkSeparator.
+self printClassNameOn:aStream.
+privacy ~~ #public ifTrue:[
+aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
+] ifFalse:[
+aStream nextPutAll:' methodsFor:'.
+].
+cat := aCategory.
+cat isNil ifTrue:[ cat := '' ].
+aStream nextPutAll:aCategory asString storeString.
+aStream nextPutChunkSeparator; cr; cr.
+first := false.
+].
+source := aMethod source.
+source isNil ifTrue:[
+Class fileOutErrorSignal
+raiseRequestWith:self
+errorString:'no source for method: ', (aMethod displayString)
+] ifFalse:[
+aStream nextChunkPut:source.
+].
+].
+aStream space.
+aStream nextPutChunkSeparator.
+aStream cr
+]
+]
+"Modified: 28.8.1995 / 14:30:41 / claus"
+"Modified: 12.6.1996 / 11:37:33 / stefan"
+"Modified: 15.11.1996 / 11:32:21 / cg"
+"Created: 1.4.1997 / 16:04:33 / stefan"!
+fileOutCategory:aCategory methodFilter:methodFilter on:aStream
+"file out all methods belonging to aCategory, aString onto aStream"
+self fileOutCategory:aCategory except:nil only:nil methodFilter:methodFilter on:aStream!
+fileOutCategory:aCategory on:aStream
+Class fileOutNameSpaceQuerySignal answer:true do:[
+self fileOutCategory:aCategory except:nil only:nil methodFilter:nil on:aStream
+]!
+fileOutClassInstVarDefinitionOn:aStream withNameSpace:withNameSpace
+"append an expression to define my classInstanceVariables on aStream"
+|anySuperClassInstVar|
+self isLoaded ifFalse:[
+^ self basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
+].
+withNameSpace ifTrue:[
+self name printOn:aStream.
+] ifFalse:[
+self printClassNameOn:aStream.
+].
+aStream nextPutAll:' class instanceVariableNames:'''.
+self class 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].
+].
+aStream cr; cr; nextPut:(Character doubleQuote); cr; space.
+anySuperClassInstVar ifFalse:[
+aStream
+nextPutLine:'No other class instance variables are inherited by this class.'.
+] ifTrue:[
+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 nextPut:(Character doubleQuote); cr.
+"Created: / 10.12.1995 / 16:31:25 / cg"
+"Modified: / 1.4.1997 / 16:00:33 / stefan"
+"Modified: / 3.2.2000 / 23:05:28 / cg"
+!
+fileOutDefinitionOn:aStream
+"append an expression on aStream, which defines myself."
+^ self basicFileOutDefinitionOn:aStream withNameSpace:false!
+fileOutMethod:aMethod
+|aStream fileName selector|
+selector := self selectorAtMethod:aMethod.
+selector notNil ifTrue:[
+fileName := (self name , '-' , selector, '.st') asFilename.
+fileName makeLegalFilename.
+"
+this test allows a smalltalk to be built without Projects/ChangeSets
+"
+Project notNil ifTrue:[
+fileName := Project currentProjectDirectory asFilename construct:fileName name.
+].
+"
+if file exists, save original in a .sav file
+"
+fileName exists ifTrue:[
+fileName copyTo:(fileName withSuffix: 'sav')
+].
+fileName := fileName name.
+aStream := FileStream newFileNamed:fileName.
+aStream isNil ifTrue:[
+^ Class fileOutErrorSignal
+raiseRequestWith:fileName
+errorString:('cannot create file:', fileName)
+].
+self fileOutMethod:aMethod on:aStream.
+aStream close
+]
+"Modified: / 1.4.1997 / 16:00:57 / stefan"
+"Created: / 2.4.1997 / 00:24:28 / stefan"
+"Modified: / 28.10.1997 / 14:40:34 / cg"!
+fileOutMethod:aMethod on:aStream
+|dict cat source privacy|
+dict := self methodDictionary.
+dict notNil ifTrue:[
+aStream nextPutChunkSeparator.
+self name printOn:aStream.
+"/        self printClassNameOn:aStream.
+(privacy := aMethod privacy) ~~ #public ifTrue:[
+aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
+] ifFalse:[
+aStream nextPutAll:' methodsFor:'.
+].
+cat := aMethod category.
+cat isNil ifTrue:[
+cat := ''
+].
+aStream nextPutAll:cat asString storeString.
+aStream nextPutChunkSeparator; cr; cr.
+source := aMethod source.
+source isNil ifTrue:[
+Class fileOutErrorSignal
+raiseRequestWith:self
+errorString:('no source for method: ' ,
+self name , '>>' ,
+(self selectorAtMethod:aMethod))
+] ifFalse:[
+aStream nextChunkPut:source.
+].
+aStream space.
+aStream nextPutChunkSeparator.
+aStream cr
+]
+"Modified: 27.8.1995 / 01:23:19 / claus"
+"Modified: 12.6.1996 / 11:44:41 / stefan"
+"Modified: 15.11.1996 / 11:32:43 / cg"
+"Created: 2.4.1997 / 00:24:33 / stefan"!
+fileOutOn:aStream
+^ self fileOutOn:aStream withTimeStamp:true!
+fileOutOn:aStream withTimeStamp:stampIt
+"file out my definition and all methods onto aStream.
+If stampIt is true, a timeStamp comment is prepended."
+self fileOutOn:aStream withTimeStamp:stampIt withInitialize:true!
+fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt
+"file out my definition and all methods onto aStream.
+If stampIt is true, a timeStamp comment is prepended.
+If initIt is true, and the class implements a class-initialize method,
+append a corresponding doIt expression for initialization."
+self
+fileOutOn:aStream
+withTimeStamp:stampIt
+withInitialize:initIt
+withDefinition:true
+methodFilter:nil!
+fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter
+"file out my definition and all methods onto aStream.
+If stampIt is true, a timeStamp comment is prepended.
+If initIt is true, and the class implements a class-initialize method,
+append a corresponding doIt expression for initialization.
+The order by which the fileOut is done is used to put the version string at the end.
+Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
+|collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods
+meta|
+self isLoaded ifFalse:[
+^ Class fileOutErrorSignal
+raiseRequestWith:self
+errorString:'will not fileOut unloaded classes'
+].
+meta := self classRef.
+"
+if there is a copyright method, add a copyright comment
+at the beginning, taking the string from the copyright method.
+We cannot do this unconditionally - that would lead to my copyrights
+being put on your code ;-).
+On the other hand: I want every file created by myself to have the
+copyright string at the beginning be preserved .... even if the
+code was edited in the browser and filedOut.
+"
+(copyrightMethod := meta compiledMethodAt:#copyright) notNil ifTrue:[
+"
+get the copyright methods source,
+and insert at beginning.
+"
+copyrightText := copyrightMethod source.
+copyrightText isNil ifTrue:[
+"
+no source available - trigger an error
+"
+Class fileOutErrorSignal
+raiseRequestWith:'no source for class ' , self name , ' available. Cannot fileOut'.
+^ self
+].
+"
+strip off the selector-line
+"
+copyrightText := copyrightText asCollectionOfLines asStringCollection.
+copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
+"/        copyrightText do:[:line | aStream nextPutAll:line. aStream cr.].
+copyrightText := copyrightText asString.
+aStream nextPutAllAsChunk:copyrightText.
+].
+stampIt ifTrue:[
+"/
+"/ first, a timestamp
+"/
+aStream nextPutAll:(Smalltalk timeStamp).
+aStream nextPutChunkSeparator.
+aStream cr; cr.
+].
+withDefinition ifTrue:[
+"/
+"/ then the definition
+"/
+self fileOutAllDefinitionsOn:aStream.
+"/
+"/ a comment - if any
+"/
+(comment := self comment) notNil ifTrue:[
+self fileOutCommentOn:aStream.
+aStream cr.
+].
+"/
+"/ primitive definitions - if any
+"/
+self fileOutPrimitiveSpecsOn:aStream.
+].
+"/
+"/ methods from all categories in metaclass (i.e. class methods)
+"/ EXCEPT: the version method is placed at the very end, to
+"/         avoid sourcePosition-shifts when checked out later.
+"/         (RCS expands this string, so its size is not constant)
+"/
+collectionOfCategories := meta categories asSortedCollection.
+collectionOfCategories notNil ifTrue:[
+"/
+"/ documentation first (if any), but not the version method
+"/
+(collectionOfCategories includes:'documentation') ifTrue:[
+versionMethod := meta compiledMethodAt:#version.
+versionMethod notNil ifTrue:[
+skippedMethods := Array with:versionMethod
+].
+meta fileOutCategory:'documentation' except:skippedMethods only:nil methodFilter:methodFilter on:aStream.
+aStream cr.
+].
+"/
+"/ initialization next (if any)
+"/
+(collectionOfCategories includes:'initialization') ifTrue:[
+meta fileOutCategory:'initialization' methodFilter:methodFilter on:aStream.
+aStream cr.
+].
+"/
+"/ instance creation next (if any)
+"/
+(collectionOfCategories includes:'instance creation') ifTrue:[
+meta fileOutCategory:'instance creation' methodFilter:methodFilter on:aStream.
+aStream cr.
+].
+collectionOfCategories do:[:aCategory |
+((aCategory ~= 'documentation')
+and:[(aCategory ~= 'initialization')
+and:[aCategory ~= 'instance creation']]) ifTrue:[
+meta fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
+aStream cr
+]
+]
+].
+"/
+"/ methods from all categories in myself
+"/
+collectionOfCategories := self categories asSortedCollection.
+collectionOfCategories notNil ifTrue:[
+collectionOfCategories do:[:aCategory |
+self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
+aStream cr
+]
+].
+"/
+"/ any private classes' methods
+"/
+self privateClassesSorted do:[:aClass |
+aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
+].
+"/
+"/ finally, the previously skipped version method
+"/
+versionMethod notNil ifTrue:[
+meta fileOutCategory:'documentation' except:nil only:skippedMethods methodFilter:methodFilter on:aStream.
+].
+initIt ifTrue:[
+"/
+"/ optionally an initialize message
+"/
+(meta implements:#initialize) ifTrue:[
+self printClassNameOn:aStream. aStream nextPutAll:' initialize'.
+aStream nextPutChunkSeparator.
+aStream cr
+]
+]
+"Created: / 15.11.1995 / 12:53:06 / cg"
+"Modified: / 1.4.1997 / 16:01:05 / stefan"
+"Modified: / 13.3.1998 / 12:23:59 / cg"!
+fileOutPrimitiveDefinitionsOn:aStream
+"append primitive defs (if any) to aStream."
+|s|
+"
+primitive definitions - if any
+"
+(s := self primitiveDefinitionsString) notNil ifTrue:[
+aStream nextPutChunkSeparator.
+self printClassNameOn:aStream.
+aStream nextPutAll:' primitiveDefinitions';
+nextPutChunkSeparator;
+cr.
+aStream nextPutAll:s.
+aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+].
+(s := self primitiveVariablesString) notNil ifTrue:[
+aStream nextPutChunkSeparator.
+self printClassNameOn:aStream.
+aStream nextPutAll:' primitiveVariables';
+nextPutChunkSeparator;
+cr.
+aStream nextPutAll:s.
+aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+].
+"Modified: 8.1.1997 / 17:45:40 / cg"!
+fileOutPrimitiveSpecsOn:aStream
+"append primitive defs (if any) to aStream."
+|s|
+"
+primitive definitions - if any
+"
+self fileOutPrimitiveDefinitionsOn:aStream.
+"
+primitive functions - if any
+"
+(s := self primitiveFunctionsString) notNil ifTrue:[
+aStream nextPutChunkSeparator.
+self printClassNameOn:aStream.
+aStream nextPutAll:' primitiveFunctions';
+nextPutChunkSeparator;
+cr.
+aStream nextPutAll:s.
+aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+].
+"Modified: 8.1.1997 / 17:45:51 / cg"!
 firstDefinitionSelectorPart
 "return the first part of the selector with which I was (can be) defined in my superclass"
 self isVariable ifFalse:[
 ^ #'subclass:'
 ].
 self isLongLongs ifTrue:[
 ^ #'variableLongLongSubclass:'
 ].
 ^ #'variableSubclass:'
+!
+getPrimitiveSpecsAt:index
+"{ Pragma: +optSpace }"
+"return a primitiveSpecification component as string or nil"
+|owner pos stream string primitiveSpec classFilename|
+(owner := self owningClass) notNil ifTrue:[^ owner getPrimitiveSpecsAt:index].
+primitiveSpec := self primitiveSpec.
+primitiveSpec isNil ifTrue:[^ nil].
+pos := primitiveSpec at:index.
+pos isNil ifTrue:[^ nil].
+"the primitiveSpec is either a string, or an integer specifying the
+position within the classes sourcefile ...
+"
+pos isNumber ifTrue:[
+classFilename := self classFilename.
+classFilename notNil ifTrue:[
+stream := self sourceStream.
+stream notNil ifTrue:[
+stream position:pos+1.
+string := stream nextChunk.
+stream close.
+^ string
+]
+].
+^ nil
+].
+^ pos
+"Modified: 15.1.1997 / 15:29:30 / stefan"!
+hasMethods
+"return true, if there are any (local) methods in this class"
+^ (self methodDictionary size ~~ 0)!
+implements:aSelector
+^ self includesSelector:aSelector!
+includesSelector:aSelector
+^ self methodDictionary includesKey:aSelector!
+instanceVariableString
+"return a string of the instance variable names"
+|instvars|
+instvars := self instVarNames.
+instvars isNil ifTrue:[^ ''].
+instvars isString ifTrue:[
+^ instvars
+].
+^ instvars asStringWith:(Character space)
+"
+Point instanceVariableString
+"
+"Modified: 22.8.1997 / 14:59:14 / cg"
+!
+isObsolete
+^ false
+!
+isSubclassOf:aClass
+"return true, if I am a subclass of the argument, aClass"
+|theClass|
+theClass := self superclass.
+[theClass notNil] whileTrue:[
+(theClass == aClass) ifTrue:[^ true].
+theClass := theClass superclass.
+].
+^ false
 !
 nameWithoutNameSpacePrefix
 |nm owner|
 idx == 0 ifTrue:[
 ^ nm
 ].
 ^ nm copyFrom:idx+1.
 !
+packageSourceCodeInfo
+"{ Pragma: +optSpace }"
+"return the sourceCodeInfo, which defines the module and the subdirectory
+in which the receiver class was built.
+This info is extracted from the package id (which is added to stc-compiled classes).
+This method is to be obsoleted soon, since the same info is now found
+in the versionString.
+The info returned consists of a dictionary
+filled with (at least) values at: #module, #directory and #library.
+If no such info is present in the class, nil is returned.
+(this happens with autoloaded and filed-in classes)
+Auotloaded classes set their package from the revisionInfo, if present.
+By convention, this info is encoded in the classes package
+string (which is given as argument to stc) as the last word in parenthesis.
+The info consists of 1 to 3 subcomponents, separated by colons.
+The first defines the classes module (i.e. some application identifier),
+the second defines the subdirectory within that module, the third
+defines the name of the class library.
+If left blank, the module info defaults to 'stx',
+the directory info defaults to library name.
+The library name may not be left blank.
+(this is done for backward compatibility,)
+For example:
+'....(libbasic)'                         -> module: stx directory: libbasic library: libbasic
+'....(stx:libbasic)'                     -> module: stx directory: libbasic library: libbasic
+'....(stx:foo:libbfoo)'                  -> module: stx directory: foo library: libfoo
+'....(aeg:libIECInterface)'              -> module: aeg directory: libIECInterface library:libIECInterface
+'....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase
+The way how the sourceCodeManager uses this to find the source location
+depends on the scheme used. For CVS, the module is taken as the -d arg,
+while the directory is prepended to the file name.
+Other schemes may do things differently - these are not yet specified.
+Caveat:
+Encoding this info in the package string seems somewhat kludgy.
+"
+|owner sourceInfo packageString idx1 idx2
+moduleString directoryString libraryString components component1 component2 dirComponents mgr
+package|
+(owner := self owningClass) notNil ifTrue:[^ owner packageSourceCodeInfo].
+package := self package.
+package isNil ifTrue:[^ nil].
+packageString := package asString.
+idx1 := packageString lastIndexOf:$(.
+idx1 ~~ 0 ifTrue:[
+idx2 := packageString indexOf:$) startingAt:idx1+1.
+idx2 ~~ 0 ifTrue:[
+sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
+]
+] ifFalse:[
+sourceInfo := packageString
+].
+sourceInfo isNil ifTrue:[^ nil].
+components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
+components size == 0 ifTrue:[
+"/        moduleString := 'stx'.
+"/        directoryString := libraryString := ''.
+^ nil
+].
+component1 := components at:1.
+components size == 1 ifTrue:[
+"/ a single name given - the module becomes 'stx' or
+"/ the very first directory component (if such a module exists).
+"/ If the component includes slashes, its the directory
+"/ otherwise the library.
+"/
+dirComponents := Filename concreteClass components:component1.
+(dirComponents size > 1
+and:[(mgr := self sourceCodeManager) notNil
+and:[mgr checkForExistingModule:dirComponents first]]) ifTrue:[
+moduleString := dirComponents first.
+directoryString := libraryString := (Filename fromComponents:(dirComponents copyFrom:2)) asString.
+] ifFalse:[
+"/ non-existing; assume directory under the stx package.
+moduleString := 'stx'.
+(component1 startsWith:'stx/') ifTrue:[
+component1 := component1 copyFrom:5
+].
+directoryString := libraryString := component1.
+].
+(libraryString includes:$/) ifTrue:[
+libraryString := libraryString asFilename baseName
+]
+] ifFalse:[
+component2 := components at:2.
+components size == 2 ifTrue:[
+"/ two components - assume its the module and the directory;
+"/ the library is assumed to be named after the directory
+"/ except, if slashes are in the name; then the libraryname
+"/ is the last component.
+"/
+moduleString := component1.
+directoryString := libraryString := component2.
+(libraryString includes:$/) ifTrue:[
+libraryString := libraryString asFilename baseName
+]
+] ifFalse:[
+"/ all components given
+moduleString := component1.
+directoryString := component2.
+libraryString := components at:3.
+]
+].
+libraryString isEmpty ifTrue:[
+directoryString notEmpty ifTrue:[
+libraryString := directoryString asFilename baseName
+].
+libraryString isEmpty ifTrue:[
+"/ lets extract the library from the liblist file ...
+libraryString := Smalltalk libraryFileNameOfClass:self.
+libraryString isNil ifTrue:[^ nil].
+]
+].
+moduleString isEmpty ifTrue:[
+moduleString := 'stx'.
+].
+directoryString isEmpty ifTrue:[
+directoryString := libraryString.
+].
+^ IdentityDictionary
+with:(#module->moduleString)
+with:(#directory->directoryString)
+with:(#library->libraryString)
+"
+Object packageSourceCodeInfo
+View packageSourceCodeInfo
+Model packageSourceCodeInfo
+BinaryObjectStorage packageSourceCodeInfo
+MemoryMonitor packageSourceCodeInfo
+ClockView packageSourceCodeInfo
+"
+"Created: 4.11.1995 / 20:36:53 / cg"
+"Modified: 19.9.1997 / 10:42:25 / cg"!
+primitiveDefinitionsString
+"{ Pragma: +optSpace }"
+"return the primitiveDefinition string or nil"
+^ self getPrimitiveSpecsAt:1
+"
+Object primitiveDefinitionsString
+String primitiveDefinitionsString
+"!
+primitiveFunctionsString
+"{ Pragma: +optSpace }"
+"return the primitiveFunctions string or nil"
+^ self getPrimitiveSpecsAt:3!
+primitiveVariablesString
+"{ Pragma: +optSpace }"
+"return the primitiveVariables string or nil"
+^ self getPrimitiveSpecsAt:2!
+printClassNameOn:aStream
+|nm|
+Class fileOutNameSpaceQuerySignal query == false ifTrue:[
+nm := self nameWithoutNameSpacePrefix
+] ifFalse:[
+nm := self name.
+].
+aStream nextPutAll:nm.!
 printClassVarNamesOn:aStream indent:indent
 "print the class variable names indented and breaking at line end"
 self printNameArray:(self classVarNames) on:aStream indent:indent
 printNameInHierarchy
 ^ self name
 !
+privateClasses
+"{ Pragma: +optSpace }"
+"return a collection of my private classes (if any).
+The classes are in any order."
+^ self privateClassesOrAll:false!
 privateClassesAt:aClassNameStringOrSymbol
 |nmSym|
 nmSym := (self name , '::' , aClassNameStringOrSymbol) asSymbolIfInterned.
 nmSym isNil ifTrue:[
 ].
 ^ memory at:nmSym.
 !
+privateClassesOrAll:allOfThem
+"{ Pragma: +optSpace }"
+"return a collection of my direct private classes (if any)
+or direct plus indirect private classes (if allOfThem).
+An empty collection if there are none.
+The classes are in any order."
+|classes myName myNamePrefix myNamePrefixLen|
+myName := self name.
+myNamePrefix := myName , '::'.
+myNamePrefixLen := myNamePrefix size.
+Smalltalk keysDo:[:nm |
+|cls|
+(nm startsWith:myNamePrefix) ifTrue:[
+(allOfThem
+or:[(nm indexOf:$: startingAt:myNamePrefixLen + 1) == 0]) ifTrue:[
+cls := Smalltalk at:nm.
+(cls isBehavior and:[cls isMeta not]) ifTrue:[
+classes isNil ifTrue:[
+classes := IdentitySet new:10.
+].
+classes add:cls.
+]
+]
+]
+].
+^ classes ? #()
+"
+UILayoutTool privateClassesOrAll:true
+UILayoutTool privateClassesOrAll:false
+"
+"Modified: / 29.5.1998 / 23:23:18 / cg"!
+privateClassesSorted
+"{ Pragma: +optSpace }"
+"return a collection of my private classes (if any).
+The classes are sorted by inheritance."
+|classes|
+classes := self privateClasses.
+(classes size > 0) ifTrue:[
+classes := classes asOrderedCollection topologicalSort:[:a :b | b isSubclassOf:a].
+].
+^ classes.
+"
+Object privateClassesSorted
+"
+"Created: 22.3.1997 / 16:10:42 / cg"
+"Modified: 22.3.1997 / 16:11:20 / cg"!
+revisionInfo
+"return a dictionary filled with revision info.
+This extracts the relevant info from the revisionString.
+The revisionInfo contains all or a subset of:
+#binaryRevision - the revision upon which the binary of this class is based
+#revision       - the revision upon which the class is based logically
+(different, if a changed class was checked in, but not yet recompiled)
+#user           - the user who checked in the logical revision
+#date           - the date when the logical revision was checked in
+#time           - the time when the logical revision was checked in
+#fileName       - the classes source file name
+#repositoryPath - the classes source container
+"
+|vsnString info mgr|
+vsnString := self revisionString.
+vsnString notNil ifTrue:[
+mgr := self sourceCodeManager.
+mgr notNil ifTrue:[
+info := mgr revisionInfoFromString:vsnString
+] ifFalse:[
+info := Class revisionInfoFromString:vsnString.
+].
+info notNil ifTrue:[
+info at:#binaryRevision put:self binaryRevision.
+]
+].
+^ info!
+revisionString
+"{ Pragma: +optSpace }"
+"return my revision string; that one is extracted from the
+classes #version method. Either this is a method returning that string,
+or its a comment-only method and the comment defines the version.
+If the source is not accessable or no such method exists,
+nil is returned."
+|owner cls meta m src val|
+(owner := self owningClass) notNil ifTrue:[^ owner revisionString].
+thisContext isRecursive ifTrue:[^ nil ].
+self isMeta ifTrue:[
+meta := self. cls := self soleInstance
+] ifFalse:[
+cls := self. meta := self classRef
+].
+m := meta compiledMethodAt:#version.
+m isNil ifTrue:[
+m := cls compiledMethodAt:#version.
+m isNil ifTrue:[^ nil].
+].
+m isExecutable ifTrue:[
+"/
+"/ if its a method returning the string,
+"/ thats the returned value
+"/
+val := cls version.
+val isString ifTrue:[^ val].
+].
+"/
+"/ if its a method consisting of a comment only
+"/ extract it - this may lead to a recursive call
+"/ to myself (thats what the #isRecursive is for)
+"/ in case we need to access the source code manager
+"/ for the source ...
+"/
+src := m source.
+src isNil ifTrue:[^ nil].
+^ Class revisionStringFromSource:src
+"
+Smalltalk allClassesDo:[:cls |
+Transcript showCR:cls revisionString
+].
+Number revisionString
+FileDirectory revisionString
+Metaclass revisionString
+"
+"Created: 29.10.1995 / 19:28:03 / cg"
+"Modified: 23.10.1996 / 18:23:56 / cg"
+"Modified: 1.4.1997 / 23:37:25 / stefan"!
+selectorAtMethod:aMethod
+^ self selectorAtMethod:aMethod ifAbsent:[nil]!
+selectorAtMethod:aMethod ifAbsent:failBlock
+|md|
+md := self methodDictionary.
+md isNil ifTrue:[
+'OOPS - nil methodDictionary' errorPrintCR.
+^ nil
+].
+^ md keyAtValue:aMethod ifAbsent:failBlock.!
+soleInstance
+self isMeta ifFalse:[self halt].
+^ self theNonMetaclass.
+!
 sourceCodeManager
 ^ SourceCodeManager
 !
+sourceStreamFor:source
+"return an open stream on a sourcefile, nil if that is not available"
+|owner fileName aStream mgr validated guessedFileName sep mod dir classFilename package name|
+self isMeta ifTrue:[
+^ self theNonMetaclass sourceStreamFor:source
+].
+(owner := self owningClass) notNil ifTrue:[^ owner sourceStreamFor:source].
+validated := false.
+classFilename := self classFilename.
+package := self package.
+name := self name.
+"/
+"/ if there is no SourceCodeManager,
+"/ or TryLocalSourceFirst is true,
+"/ look in standard places first
+"/
+((mgr := self sourceCodeManager) isNil
+or:[Class tryLocalSourceFirst == true]) ifTrue:[
+aStream := self localSourceStreamFor:source.
+].
+aStream isNil ifTrue:[
+"/ mhmh - still no source file.
+"/ If there is a SourceCodeManager, ask it to aquire the
+"/ the source for my class, and return an open stream on it.
+"/ if that one does not know about the source, look in
+"/ standard places
+mgr notNil ifTrue:[
+self classFilename ~= source ifTrue:[
+sep := self 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 isNil ifTrue:[
+classFilename isNil ifTrue:[
+classFilename := guessedFileName := (Smalltalk fileNameForClass:self) , '.st'.
+].
+source asFilename baseName = classFilename asFilename baseName ifTrue:[
+aStream := mgr getSourceStreamFor:self.
+]
+].
+aStream notNil ifTrue:[
+(self validateSourceStream:aStream) ifFalse:[
+('Class [info]: repositories source for `'
+, (self isMeta ifTrue:[self soleInstance name]
+ifFalse:[name])
+, ''' is invalid.') infoPrintCR.
+aStream close.
+aStream := nil
+] ifTrue:[
+validated := true.
+].
+].
+]
+].
+aStream isNil ifTrue:[
+"/
+"/ hard case - there is no source file for this class
+"/ (in the source-dir-path).
+"/
+"/
+"/ look if my binary is from a dynamically loaded module,
+"/ and, if so, look in the modules directory for the
+"/ source file.
+"/
+ObjectFileLoader notNil ifTrue:[
+ObjectFileLoader loadedObjectHandlesDo:[:h |
+|f classes|
+aStream isNil ifTrue:[
+(classes := h classes) size > 0 ifTrue:[
+(classes includes:self) ifTrue:[
+f := h pathName.
+f := f asFilename directory.
+f := f construct:source.
+f exists ifTrue:[
+aStream := f readStream.
+].
+].
+].
+]
+].
+].
+].
+"/
+"/ try along sourcePath
+"/
+aStream isNil ifTrue:[
+aStream := self localSourceStreamFor:source.
+].
+"/
+"/ final chance: try current directory
+"/
+aStream isNil ifTrue:[
+aStream := source asFilename readStream.
+].
+(aStream notNil and:[validated not]) ifTrue:[
+(self validateSourceStream:aStream) ifFalse:[
+(Smalltalk releaseIdentification = 'ST/X_free_demo_vsn') ifTrue:[
+"/                ('Class [info]: source for ''' , self name , ''' is not available in the demo version.') infoPrintCR
+] ifFalse:[
+('Class [warning]: source for ''' , self name , ''' is invalid or stripped. Take care.') errorPrintCR
+]
+].
+].
+(aStream notNil and:[aStream isFileStream]) ifTrue:[
+guessedFileName notNil ifTrue:[
+classFilename := aStream pathName asFilename baseName.
+]
+].
+^ aStream
+"
+Object sourceStream
+Clock sourceStream
+Autoload sourceStream
+"
+"Created: / 10.11.1995 / 21:05:13 / cg"
+"Modified: / 22.4.1998 / 19:20:50 / ca"
+"Modified: / 23.4.1998 / 15:53:54 / cg"
+!
+subclasses
+"return a collection of the direct subclasses of the receiver"
+|newColl|
+"/    "/ use cached information (avoid class hierarchy search)
+"/    "/ if possible
+"/
+"/    SubclassInfo notNil ifTrue:[
+"/        newColl := SubclassInfo at:self ifAbsent:nil.
+"/        newColl notNil ifTrue:[^ newColl asOrderedCollection]
+"/    ].
+newColl := OrderedCollection new.
+self subclassesDo:[:aClass |
+newColl add:aClass
+].
+"/    SubclassInfo notNil ifTrue:[
+"/        SubclassInfo at:self put:newColl.
+"/    ].
+^ newColl
+!
+subclassesDo:aBlock
+"evaluate the argument, aBlock for all immediate subclasses.
+This will only enumerate globally known classes - for anonymous
+behaviors, you have to walk over all instances of Behavior."
+|coll|
+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)
+].
+^ self
+].
+"/ use cached information (avoid class hierarchy search)
+"/ if possible
+"/    SubclassInfo isNil ifTrue:[
+"/        Behavior subclassInfo
+"/    ].
+"/    SubclassInfo notNil ifTrue:[
+"/        coll := SubclassInfo at:self ifAbsent:nil.
+"/        coll notNil ifTrue:[
+"/            coll do:aBlock.
+"/        ].
+"/        ^ self
+"/    ].
+Smalltalk allClassesDo:[:aClass |
+(aClass superclass == self) ifTrue:[
+aBlock value:aClass
+]
+]
+"
+Collection subclassesDo:[:c | Transcript showCR:(c name)]
+"
+"Modified: 22.1.1997 / 18:44:01 / cg"
+!
 syntaxHighlighterClass
 ^ Object syntaxHighlighterClass
 !
+theMetaclass
+self isMeta ifTrue:[^ self].
+^ self classRef.!
+theNonMetaclass
+|instSlotOffs clsPtr|
+self isMeta ifFalse:[^ self].
+instSlotOffs := Metaclass instVarOffsetOf:'myClass'.
+clsPtr := self at:instSlotOffs.
+^ memory fetchObjectAt:clsPtr.
+!
+validateSourceStream:aStream
+"check if aStream really contains my source.
+This is done by checking the version methods return value
+against the version string as contained in the version method"
+^ true!
+withAllSuperclasses
+"return a collection containing the receiver and all
+of the receivers accumulated superclasses"
+|aCollection theSuperClass|
+aCollection := OrderedCollection with:self.
+theSuperClass := self superclass.
+[theSuperClass notNil] whileTrue:[
+aCollection add:theSuperClass.
+theSuperClass := theSuperClass superclass
+].
+^ aCollection
+"
+String withAllSuperclasses
+"!
 withAllSuperclassesDo:aBlock
 |sc|
 aBlock value:self.
 isLongs
 ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagLongs.
 !
 isMeta
-^ self size == (Metaclass instSize * memory ptrSize).
+^ self size == (Metaclass instSize).
-"/    ^ classRef classRef name = 'Metaclass'
+"/    ^ classRef classRef name = 'Metaclass'!
-!
 isPrivate
 ^ classRef isPrivateMeta
 !
 nameSpace
 |env name idx nsName|
 "/    (env := self environment) notNil ifTrue:[^ env].
+env := Smalltalk. "/ default
 name := self name.
 idx := name lastIndexOf:$:.
 idx ~~ 0 ifTrue:[
 (name at:idx-1) == $: ifTrue:[
 nsName := name copyTo:(idx - 2).
 wasAutoloaded
 ^ false
 ! !
-!SnapShotImageMemory::ImageByteObject methodsFor:'queries'!
-size
-^ byteSize
-! !
 !SnapShotImageMemory class methodsFor:'documentation'!
 version
 ^ '$Header$'
 ! !

changeset 1419	f808d17ff6f5
parent 1417	28d6026fe30c
child 1420	9a649c1bb8cf