diff -r 7466259d8bb5 -r f808d17ff6f5 SnapShotImageMemory.st --- a/SnapShotImageMemory.st Tue Oct 24 20:23:38 2000 +0200 +++ b/SnapShotImageMemory.st Tue Oct 24 20:23:46 2000 +0200 @@ -1,5 +1,3 @@ -'From Smalltalk/X, Version:4.1.1 on 24-Okt-2000 at 12:50:47' ! - "{ Package: 'cg:private' }" Object subclass:#SnapShotImageMemory @@ -17,6 +15,13 @@ privateIn:SnapShotImageMemory ! +SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + privateIn:SnapShotImageMemory +! + Object subclass:#SpaceInfo instanceVariableNames:'start end size flags imageBase' classVariableNames:'' @@ -25,7 +30,7 @@ ! SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject - instanceVariableNames:'' + instanceVariableNames:'cachedContents' classVariableNames:'' poolDictionaries:'' privateIn:SnapShotImageMemory @@ -38,13 +43,6 @@ privateIn:SnapShotImageMemory ! -SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - privateIn:SnapShotImageMemory -! - !SnapShotImageMemory class methodsFor:'instance creation'! @@ -283,6 +281,14 @@ ]. ! +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| @@ -729,6 +735,9 @@ self halt. ! +isBehavior + ^ self isImageBehavior! + isImageBehavior |flags| @@ -757,6 +766,9 @@ ^ flags bitTest:Behavior flagSymbol ! +isLazyMethod + ^ classRef name = 'LazyMethod'! + isMeta ^ false ! @@ -778,6 +790,12 @@ ^ classRef name = 'String' ! ! +!SnapShotImageMemory::ImageByteObject methodsFor:'queries'! + +size + ^ byteSize +! ! + !SnapShotImageMemory::SpaceInfo methodsFor:'accessing'! end @@ -830,81 +848,216 @@ start := something.! ! -!SnapShotImageMemory::ImageObject methodsFor:'object protocol'! - -at:aSelector ifAbsent:exceptionValue - |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. - ^ mthdRef. +!SnapShotImageMemory::ImageObject methodsFor:'method protocol'! + +byteCode + |byteCodeSlotOffset byteCodePtr byteCodeRef byteCode| + + self isMethod ifTrue:[ + byteCodeSlotOffset := Method instVarOffsetOf:'byteCode'. + ]. + byteCodeSlotOffset notNil ifTrue:[ + byteCodePtr := self at:byteCodeSlotOffset. + byteCodeRef := memory fetchObjectAt:byteCodePtr. + byteCodeRef isNil ifTrue:[^ nil]. + + byteCode := memory fetchByteArrayFor:byteCodeRef. + ^ byteCode + ]. + + self halt. +! + +comment + |src comment comments parser| + + self isMethod ifTrue:[ + src := self source. + src isNil ifTrue:[^ nil]. + + 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. ]. - ^ exceptionValue value + self isLazyMethod ifTrue:[ + ^ '' + ]. + + self halt. ! -do:aBlock - |mthdPtr mthdRef| - - self isMethodDictionary ifTrue:[ - 2 to:self size by:2 do:[:idx | - mthdPtr := self at:idx. - mthdRef := memory fetchObjectAt:mthdPtr. - aBlock value:mthdRef. - ]. +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 - |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. +mclass + |mclassSlotOffset mclassPtr mclass| + + self isMethod ifTrue:[ + mclassSlotOffset := Method instVarOffsetOf:'mclass'. + mclassPtr := self at:mclassSlotOffset. + mclassPtr ~~ 0 ifTrue:[ + mclass := memory fetchObjectAt:mclassPtr. + mclass isImageBehavior ifFalse:[ + self halt + ]. + ^ 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| - - self isMethod ifTrue:[ - sourcePosition := self at:(Method instVarOffsetOf:'sourcePosition'). - source := self at:(Method instVarOffsetOf:'source'). - source := memory fetchObjectAt:source. - source isString ifFalse:[ + |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: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:[ @@ -922,6 +1075,42 @@ 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| @@ -1037,6 +1226,77 @@ 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 @@ -1053,12 +1313,22 @@ ! 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| @@ -1086,6 +1356,19 @@ ^ 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 ! @@ -1104,8 +1387,7 @@ ! commentSlot - ^ self at:10 -! + ^ self at:(Class instVarOffsetOf:'comment')! flags |flags| @@ -1119,12 +1401,16 @@ ! 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| @@ -1149,8 +1435,7 @@ ]. ]. ]. - ^ instVarNames -! + ^ instVarNames ? #()! instVarsSlot ^ self at:6 @@ -1168,12 +1453,15 @@ ! 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. @@ -1188,13 +1476,39 @@ ! 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 ! @@ -1215,15 +1529,120 @@ !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:[ @@ -1261,6 +1680,9 @@ ] ]. + superclass := self superclass. + category := self category. + "take care of nil-superclass" superclass isNil ifTrue:[ s := 'nil' @@ -1384,8 +1806,7 @@ "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" @@ -1405,6 +1826,50 @@ "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 @@ -1426,6 +1891,713 @@ ^ 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" @@ -1462,6 +2634,89 @@ ^ #'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| @@ -1484,6 +2739,194 @@ ^ 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" @@ -1571,6 +3014,14 @@ ^ 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| @@ -1583,14 +3034,427 @@ ^ 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| @@ -1644,9 +3508,8 @@ ! isMeta - ^ self size == (Metaclass instSize * memory ptrSize). -"/ ^ classRef classRef name = 'Metaclass' -! + ^ self size == (Metaclass instSize). +"/ ^ classRef classRef name = 'Metaclass'! isPrivate ^ classRef isPrivateMeta @@ -1680,6 +3543,7 @@ |env name idx nsName| "/ (env := self environment) notNil ifTrue:[^ env]. + env := Smalltalk. "/ default name := self name. idx := name lastIndexOf:$:. idx ~~ 0 ifTrue:[ @@ -1723,12 +3587,6 @@ ^ false ! ! -!SnapShotImageMemory::ImageByteObject methodsFor:'queries'! - -size - ^ byteSize -! ! - !SnapShotImageMemory class methodsFor:'documentation'! version