ps@1423: "{ Package: 'stx:libtool2' }" cg@1416: mawalch@3250: "{ NameSpace: Smalltalk }" mawalch@3250: cg@1416: Object subclass:#SnapShotImageMemory cg@1417: instanceVariableNames:'image stream msb ptrSize intSize intTag spaceInfos symbolEntries cg@3088: globalEntries addrToObjectMapping fetchINT hdrSize' cg@1416: classVariableNames:'' cg@1416: poolDictionaries:'' cg@1416: category:'System-Support' cg@1416: ! cg@1416: cg@1417: Object subclass:#ImageHeader cg@1864: instanceVariableNames:'memory address classRef bits byteSize' cg@1417: classVariableNames:'' cg@1417: poolDictionaries:'' cg@1417: privateIn:SnapShotImageMemory cg@1417: ! cg@1417: cg@1417: SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject cg@1419: instanceVariableNames:'cachedContents' cg@1416: classVariableNames:'' cg@1416: poolDictionaries:'' cg@1416: privateIn:SnapShotImageMemory cg@1416: ! cg@1416: cg@1448: SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject cg@1448: instanceVariableNames:'' cg@1448: classVariableNames:'' cg@1448: poolDictionaries:'' cg@1448: privateIn:SnapShotImageMemory cg@1448: ! cg@1448: cg@1482: SnapShotImageMemory::ImageObject variableSubclass:#ImageMethodObject cg@1552: instanceVariableNames:'cachedPackage cachedMClass cachedSelector' cg@1482: classVariableNames:'' cg@1482: poolDictionaries:'' cg@1482: privateIn:SnapShotImageMemory cg@1482: ! cg@1482: cg@1416: SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject cg@1482: instanceVariableNames:'cachedCategory cachedFlags cachedName' cg@1416: classVariableNames:'' cg@1416: poolDictionaries:'' cg@1416: privateIn:SnapShotImageMemory cg@1416: ! cg@1416: cg@3326: SnapShotImageMemory::ImageHeader variableWordSubclass:#ImageWordObject cg@3326: instanceVariableNames:'' cg@3326: classVariableNames:'' cg@3326: poolDictionaries:'' cg@3326: privateIn:SnapShotImageMemory cg@3326: ! cg@3326: cg@1440: Object subclass:#SpaceInfo cg@1440: instanceVariableNames:'start end size flags imageBase' cg@1440: classVariableNames:'' cg@1440: poolDictionaries:'' cg@1440: privateIn:SnapShotImageMemory cg@1440: ! cg@1440: cg@1448: !SnapShotImageMemory class methodsFor:'documentation'! cg@1448: cg@1448: documentation cg@1448: " cg@1448: I represent the memory as contained in a snapshot image. cg@1448: cg@1448: I am not used directly; instead, via the SystemBrowsers entry: cg@1448: SystemBrowser openOnSnapShotImage:'/export/home/cg/work/stx/projects/smalltalk/st.img' cg@1864: SystemBrowser openOnSnapShotImage:'crash.img' cg@1448: cg@1448: [author:] cg@1448: Claus Gittinger cg@1448: cg@1448: " cg@1448: ! ! cg@1416: cg@1416: !SnapShotImageMemory class methodsFor:'instance creation'! cg@1416: cg@1416: for:aFilename cg@1416: ^ self new for:aFilename cg@1416: ! ! cg@1416: cg@1416: !SnapShotImageMemory class methodsFor:'private'! cg@1416: cg@1416: isNilOOP:anOOP cg@1416: ^ anOOP == 0 cg@1416: ! cg@1416: cg@1416: isPointerOOP:anOOP cg@1416: ^ (anOOP bitTest:1) not cg@1416: ! cg@1416: cg@1416: isSmallIntegerOOP:anOOP cg@1416: ^ anOOP bitTest:1 cg@1416: ! ! cg@1416: cg@1416: !SnapShotImageMemory methodsFor:'accessing'! cg@1416: cg@1416: globalEntries cg@1416: "return the value of the instance variable 'globalEntries' (automatically generated)" cg@1416: cg@1440: ^ globalEntries cg@1440: ! cg@1416: cg@1416: globalEntries:something cg@1416: "set the value of the instance variable 'globalEntries' (automatically generated)" cg@1416: cg@1440: globalEntries := something. cg@1440: ! cg@1417: cg@1417: image cg@1417: cg@1417: ^ image cg@1417: ! cg@1417: cg@1417: image:something cg@1417: cg@1417: image := something. cg@1417: ! cg@1417: cg@1417: ptrSize cg@1417: "return the value of the instance variable 'ptrSize' (automatically generated)" cg@1417: cg@1440: ^ ptrSize cg@1440: ! cg@1417: cg@1417: ptrSize:something cg@1417: "set the value of the instance variable 'ptrSize' (automatically generated)" cg@1417: cg@1440: ptrSize := something. cg@1440: ! ! cg@1416: cg@1416: !SnapShotImageMemory methodsFor:'object access'! cg@1416: cg@1417: fetchByteAt:addr cg@1417: |byte imgAddr| cg@1417: cg@1417: imgAddr := self imageAddressOf:addr. cg@1417: stream position:imgAddr. cg@1417: byte := stream next. cg@1417: ^ byte cg@1417: ! cg@1417: cg@1416: fetchClassObjectAt:baseAddr cg@1417: |addr classPtr size bits o classRef nInsts| cg@1417: cg@3088: (baseAddr bitAnd:ptrSize-1) ~~ 0 ifTrue:[self halt]. cg@1416: cg@1864: o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil. cg@1416: o notNil ifTrue:[^ o]. cg@1416: cg@1416: addr := baseAddr. cg@1416: classPtr := self fetchPointerAt:addr. cg@1416: addr := addr + ptrSize. cg@3088: size := self fetchUnboxedInteger4At:addr. cg@3088: addr := addr + 4. cg@3088: bits := self fetchUnboxedInteger4At:addr. cg@3088: addr := addr + 4. cg@3088: cg@3088: nInsts := (size - hdrSize) // intSize. cg@1417: o := ImageClassObject new:nInsts. cg@1864: o memory:self. cg@1864: o address:baseAddr. cg@1864: addrToObjectMapping at:(baseAddr bitShift:-2) put:o. cg@1417: cg@1417: (self class isPointerOOP:classPtr) ifFalse:[ cg@1417: self halt cg@1417: ]. cg@1417: cg@3088: "/ size > 8000 ifTrue:[self halt]. cg@1417: o byteSize:size. cg@1416: o bits:bits. cg@1416: cg@1417: 1 to:nInsts do:[:idx | cg@3088: o at:idx put:(fetchINT value). cg@1417: "/ o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)). cg@1417: addr := addr + ptrSize. cg@1416: ]. cg@1864: cg@1864: classRef := self fetchClassObjectAt:classPtr. cg@1864: o classRef:classRef. cg@1864: cg@1416: ^ o cg@1416: ! cg@1416: cg@1416: fetchObjectAt:baseAddr cg@3088: |addr classPtr classRef size bits o nBytes nInsts flags indexTypeFlags imgAddr| cg@1417: cg@1417: baseAddr == 0 ifTrue:[^ nil]. cg@1864: (baseAddr bitAnd:1) == 1 ifTrue:[ cg@3088: "/ sign extent integer cg@3088: ptrSize == 8 ifTrue:[ cg@3088: (baseAddr bitTest:16r8000000000000000) ifTrue:[ cg@3088: ^ (baseAddr - 16r10000000000000000) bitShift:-1 cg@3088: ]. cg@3088: ^ baseAddr bitShift:-1 cg@3088: ] ifFalse:[ cg@3088: (baseAddr bitTest:16r80000000) ifTrue:[ cg@3088: ^ (baseAddr - 16r100000000) bitShift32:-1 cg@3088: ]. cg@1864: ^ baseAddr bitShift32:-1 cg@3088: ]. cg@1864: ]. cg@3088: (baseAddr bitAnd:ptrSize-1) ~~ 0 ifTrue:[self halt]. cg@1416: cg@1864: o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil. cg@1416: o notNil ifTrue:[^ o]. cg@1416: cg@1416: addr := baseAddr. cg@1416: classPtr := self fetchPointerAt:addr. cg@1416: addr := addr + ptrSize. cg@3088: size := self fetchUnboxedInteger4At:addr. cg@3088: addr := addr + 4. cg@3088: bits := self fetchUnboxedInteger4At:addr. cg@3088: addr := addr + 4. cg@1416: cg@1416: (self class isPointerOOP:classPtr) ifFalse:[ cg@1416: self halt cg@1416: ]. cg@1416: cg@1416: classRef := self fetchClassObjectAt:classPtr. cg@1417: cg@3088: imgAddr := self imageAddressOf:addr. cg@3088: stream position:imgAddr. cg@3088: cg@1482: flags := classRef flags. cg@1482: indexTypeFlags := flags bitAnd:Behavior maskIndexType. cg@1482: (indexTypeFlags = Behavior flagBytes) ifTrue:[ cg@3088: nBytes := (size - hdrSize). cg@1417: o := ImageByteObject new:nBytes. cg@1864: o memory:self. cg@1864: o address:baseAddr. cg@1417: o classRef:classRef. cg@3088: "/ size > 8000 ifTrue:[self halt]. cg@1417: o byteSize:size. cg@1417: o bits:bits. cg@1864: addrToObjectMapping at:(baseAddr bitShift:-2) put:o. cg@1416: cg@1417: 1 to:nBytes do:[:idx | cg@1417: o at:idx put:(stream next). cg@1417: addr := addr + 1. cg@1417: ]. cg@1417: cg@1417: "/Transcript show:'#'. cg@1417: "/Transcript show:((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:o startingAt:1) asString. cg@1417: "/Transcript cr. cg@3326: ^ o cg@3326: ]. cg@3326: (indexTypeFlags = Behavior flagWords) ifTrue:[ cg@3326: |nWords| cg@3326: cg@3326: nBytes := (size - hdrSize). cg@3326: nWords := nBytes//2. cg@3326: o := ImageWordObject new:nWords. cg@1864: o memory:self. cg@1864: o address:baseAddr. cg@1417: o classRef:classRef. cg@3089: "/ size > 8000 ifTrue:[self halt]. cg@1417: o byteSize:size. cg@1417: o bits:bits. cg@1864: addrToObjectMapping at:(baseAddr bitShift:-2) put:o. cg@1416: cg@3326: 1 to:nWords do:[:idx | cg@3326: o at:idx put:(stream nextUnsignedInt16MSB:msb). cg@3326: addr := addr + 2. cg@3326: ]. cg@3326: cg@3326: "/Transcript show:'#'. cg@3326: "/Transcript show:((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:o startingAt:1) asString. cg@3326: "/Transcript cr. cg@3326: ^ o cg@3326: ]. cg@3326: cg@3326: (indexTypeFlags = Behavior flagNotIndexed) ifFalse:[ cg@3326: (indexTypeFlags ~= Behavior flagPointers) ifTrue:[ cg@3326: (indexTypeFlags ~= Behavior flagWeakPointers) ifTrue:[ cg@3326: self halt cg@3326: ] cg@3326: ]. cg@3326: ]. cg@3326: cg@3326: nInsts := (size - hdrSize) // intSize. cg@3326: (flags bitTest:Behavior flagBehavior) cg@3326: "/ classRef isImageBehavior cg@3326: ifTrue:[ cg@3326: o := ImageClassObject new:nInsts. cg@3326: ] ifFalse:[ cg@3326: (flags bitTest:Behavior flagMethod) ifTrue:[ cg@3326: o := ImageMethodObject new:nInsts. cg@3326: ] ifFalse:[ cg@3326: o := ImageObject new:nInsts. cg@3326: ] cg@3326: ]. cg@3326: o memory:self. cg@3326: o address:baseAddr. cg@3326: o classRef:classRef. cg@3326: "/ size > 8000 ifTrue:[self halt]. cg@3326: o byteSize:size. cg@3326: o bits:bits. cg@3326: addrToObjectMapping at:(baseAddr bitShift:-2) put:o. cg@3326: cg@3326: 1 to:nInsts do:[:idx | cg@3326: o at:idx put:(fetchINT value). cg@1417: "/ o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)). cg@3326: addr := addr + ptrSize. cg@1417: ]. cg@1417: ^ o cg@1416: ! cg@1416: cg@1416: fetchPointerAt:addr cg@1416: ^ self fetchUnboxedIntegerAt:addr cg@1416: ! cg@1416: cg@3088: fetchUnboxedInteger4At:addr cg@1417: |ptr imgAddr| cg@1417: cg@3088: (addr bitAnd:(4-1)) ~~ 0 ifTrue:[self halt]. cg@1417: cg@1417: imgAddr := self imageAddressOf:addr. cg@1417: stream position:imgAddr. cg@1417: ptr := stream nextUnsignedLongMSB:msb. cg@1417: ^ ptr cg@1417: ! cg@1417: cg@3088: fetchUnboxedIntegerAt:addr cg@3088: |ptr imgAddr| cg@3088: cg@3088: (addr bitAnd:(ptrSize-1)) ~~ 0 ifTrue:[self halt]. cg@3088: cg@3088: imgAddr := self imageAddressOf:addr. cg@3088: stream position:imgAddr. cg@3088: ptr := fetchINT value. cg@3088: ^ ptr cg@3088: ! cg@3088: cg@1417: imageAddressOf:addr cg@1416: spaceInfos do:[:eachSpace | cg@1417: |byte imgAddr| cg@1416: cg@1416: addr >= eachSpace start ifTrue:[ cg@1416: addr <= eachSpace end ifTrue:[ cg@1416: imgAddr := eachSpace imageBase + (addr - eachSpace start). cg@1417: ^ imgAddr cg@1416: ] cg@1416: ]. cg@1416: ]. cg@1417: self halt:'image address error'. cg@1416: ! ! cg@1416: cg@1416: !SnapShotImageMemory methodsFor:'private'! cg@1416: cg@1416: allClassesDo:aBlock cg@1551: globalEntries do:[:eachGlobal | cg@1416: |val| cg@1416: cg@1551: val := eachGlobal value. mawalch@3324: (val notNil cg@1551: and:[(val isKindOf:ImageHeader) cg@1551: and:[val isImageBehavior]]) ifTrue:[ cg@1416: aBlock value:val cg@1417: ]. cg@1416: ]. cg@1416: ! cg@1416: cg@1419: fetchByteArrayFor:aByteArrayRef cg@1419: |nBytes| cg@1419: cg@1419: (aByteArrayRef isImageBytes) ifFalse:[self halt]. cg@1419: cg@3088: nBytes := aByteArrayRef byteSize - hdrSize. cg@1440: ^ ((ByteArray new:nBytes) replaceFrom:1 to:nBytes-1 with:aByteArrayRef startingAt:1). cg@1440: ! cg@1419: cg@1417: fetchStringFor:aStringRef cg@1417: |nBytes| cg@1417: cg@1417: (aStringRef isImageBytes) ifFalse:[self halt]. cg@1417: cg@3088: nBytes := aStringRef byteSize - hdrSize. cg@3088: ^ ((ByteArray new:nBytes-1) cg@3088: replaceFrom:1 to:nBytes-1 with:aStringRef startingAt:1) asString. cg@1417: ! cg@1417: cg@1416: for:aFilename cg@1416: stream := aFilename asFilename readStream binary. cg@1416: addrToObjectMapping := IdentityDictionary new. cg@1417: cg@1864: addrToObjectMapping at:((ObjectMemory addressOf:false) bitShift:-2) put:false. cg@1864: addrToObjectMapping at:((ObjectMemory addressOf:true) bitShift:-2) put:true. cg@1417: ! cg@1417: cg@1417: printStringOfClass:aClassRef cg@1417: |nameSlot| cg@1417: cg@1417: (aClassRef isImageBehavior) ifFalse:[self halt]. cg@3088: ((aClassRef byteSize - hdrSize) // intSize) < Class instSize ifTrue:[self halt.]. cg@1417: cg@1791: nameSlot := aClassRef nameSlot. cg@1417: nameSlot isInteger ifTrue:[ cg@1417: nameSlot := self fetchObjectAt:nameSlot cg@1417: ]. cg@1417: nameSlot isImageSymbol ifFalse:[self halt]. cg@1417: ^ 'Class: ' , (self printStringOfSymbol:nameSlot) cg@1417: ! cg@1417: cg@1417: printStringOfObject:anObjectRef cg@1417: |s nBytes| cg@1417: cg@1417: anObjectRef isNil ifTrue:[^ 'nil']. cg@1417: (anObjectRef isInteger) ifTrue:[^ anObjectRef printString]. cg@1417: (anObjectRef == true ) ifTrue:[^ anObjectRef printString]. cg@1417: (anObjectRef == false) ifTrue:[^ anObjectRef printString]. cg@1417: cg@1417: (anObjectRef isImageSymbol) ifTrue:[^ self printStringOfSymbol:anObjectRef]. cg@1417: (anObjectRef isImageBehavior) ifTrue:[^ self printStringOfClass:anObjectRef]. cg@1417: cg@1417: ^ 'obj(' , anObjectRef printString , ')' cg@1417: ! cg@1417: cg@1417: printStringOfString:aStringRef cg@1417: |nBytes| cg@1417: cg@1417: (aStringRef isString) ifFalse:[self halt]. cg@1417: ^ self fetchStringFor:aStringRef. cg@1417: ! cg@1417: cg@1417: printStringOfSymbol:aSymbolRef cg@1417: (aSymbolRef isImageSymbol) ifFalse:[self halt]. cg@1420: ^ self fetchStringFor:aSymbolRef. cg@1416: ! cg@1416: cg@1416: readGlobalEntries cg@1417: |refPointer theSymbolPtr theSymbolRef theValuePtr theValueRef pos| cg@1416: cg@1416: globalEntries := OrderedCollection new. cg@1416: [ cg@3088: refPointer := fetchINT value. cg@3088: theSymbolPtr := fetchINT value. cg@3088: theValuePtr := fetchINT value. cg@1417: theSymbolPtr ~~ 0 cg@1416: ] whileTrue:[ cg@1417: globalEntries add:(theSymbolPtr -> theValuePtr). cg@1416: ]. cg@1417: globalEntries := globalEntries asArray. cg@1417: cg@1417: "/ globalEntries inspect. cg@1417: pos := stream position. cg@1417: globalEntries do:[:item | cg@1417: theSymbolPtr := item key. cg@1417: theValuePtr := item value. cg@1417: theSymbolRef := self fetchObjectAt:theSymbolPtr. cg@1417: cg@1417: "/ Transcript show:(self printStringOfSymbol:theSymbolRef). cg@1417: "/ Transcript show:'->'. cg@1417: cg@1417: theValueRef := self fetchObjectAt:theValuePtr. cg@1417: "/ Transcript show:(self printStringOfObject:theValueRef). cg@1417: "/ Transcript cr. cg@1417: cg@1417: item key:theSymbolRef. cg@1417: item value:theValueRef. cg@1417: ]. cg@1417: stream position:pos. cg@1416: ! cg@1416: cg@1416: readHeader cg@1416: " cg@3088: (self for:'st.img') readHeader cg@1864: (self for:'crash.img') readHeader cg@1416: " cg@1416: cg@1416: |order magic version timeStamp snapID last_util_addr hiText_addr flags cg@1416: lowData hiData charSlots charTableSlots fixMemStart fixMemEnd cg@1416: symMemStart symMemEnd vmDataAddr sharedMethodCode sharedBlockCode cg@1416: nContexts contextSpace nRegistered symbolsSeqNr nSpaces cg@1864: classNameSize spaceSize numCharSlots| cg@1416: cg@1416: stream next:256. "/ skip execCmd cg@1416: cg@1416: msb := false. cg@1416: order := stream nextUnsignedLongMSB:msb. cg@1416: order = 16r076543210 ifTrue:[ cg@1416: ] ifFalse:[ ps@1423: order = 16r10325476 ifTrue:[ cg@1416: msb := true. cg@1416: ] ifFalse:[ cg@1416: self error:'unhandled byteorder' cg@1416: ]. cg@1416: ]. cg@1416: magic := (stream next:8) asString. cg@1416: magic ~= 'ST/X-IMG' ifTrue:[ cg@1416: self error:'not an st/x image' cg@1416: ]. cg@1416: version := stream nextUnsignedLongMSB:msb. cg@1416: timeStamp := stream nextUnsignedLongMSB:msb. cg@1416: ptrSize := stream nextByte. cg@1416: ptrSize ~~ 4 ifTrue:[ cg@3088: ptrSize ~~ 8 ifTrue:[ cg@3088: self error:'unhandled ptr format' cg@3088: ]. cg@1416: ]. cg@1416: stream next:7. "/ filler cg@1416: intSize := stream nextUnsignedLongMSB:msb. cg@3088: intSize == 9 "encoded as SmallInteger; i.e. with tag" ifTrue:[ cg@1416: intSize := 4. cg@1416: intTag := 1. cg@1416: ] ifFalse:[ cg@3088: intSize == 17 "encoded as SmallInteger; i.e. with tag" ifTrue:[ cg@3088: intSize := 8. cg@3088: intTag := 1. cg@3088: ] ifFalse:[ cg@3088: self error:'unhandled int format' cg@3088: ]. cg@1416: ]. cg@3088: hdrSize := ptrSize + 4 + 4. cg@3088: cg@3088: intSize == 4 ifTrue:[ cg@3088: fetchINT := [stream nextUnsignedLongMSB:msb] cg@3088: ] ifFalse:[ cg@3088: fetchINT := [stream nextUnsignedHyperMSB:msb] cg@3088: ]. cg@3088: cg@1416: snapID := stream nextUnsignedLongMSB:msb. cg@3088: intSize == 8 ifTrue:[ cg@3088: "/ sigh - align for 8byte cg@3088: stream next:4 cg@3088: ]. cg@3088: last_util_addr := fetchINT value. cg@3088: hiText_addr := fetchINT value. cg@3088: flags := fetchINT value. cg@3088: "infoPrinting :=" stream next. cg@3088: "debugPrinting :=" stream next. cg@3088: stream next:6. "/ filler cg@3088: cg@3088: lowData := fetchINT value. cg@3088: hiData := fetchINT value. cg@3088: cg@3088: charSlots := fetchINT value. cg@3088: charTableSlots := fetchINT value. cg@1416: cg@1416: version >= 8 ifTrue:[ cg@3088: fixMemStart := fetchINT value. cg@3088: fixMemEnd := fetchINT value. cg@3088: symMemStart := fetchINT value. cg@3088: symMemEnd := fetchINT value. cg@3088: vmDataAddr := fetchINT value. cg@1416: ]. cg@1416: stream next:(128 * intSize). "/ skip sharedMethodCode ptrs cg@1416: stream next:(128 * intSize). "/ skip sharedBlockCode ptrs cg@1416: cg@3088: nContexts := fetchINT value. cg@3088: contextSpace := fetchINT value. cg@3088: nRegistered := fetchINT value. cg@1416: cg@1416: version >= 8 ifTrue:[ cg@1416: version >= 9 ifTrue:[ cg@3088: symbolsSeqNr := fetchINT value. cg@1864: version >= 10 ifTrue:[ cg@3088: numCharSlots := fetchINT value. cg@1864: stream next:(intSize * 30). cg@1864: ] ifFalse:[ cg@1864: stream next:(intSize * 31). cg@1864: ]. cg@1416: ] ifFalse:[ cg@1416: stream next:(intSize * 32). cg@1416: ] cg@1416: ]. cg@1416: cg@3088: nSpaces := fetchINT value. cg@1416: spaceInfos := (1 to:nSpaces) collect:[:idx | SpaceInfo new]. cg@1416: cg@1416: 1 to:nSpaces do:[:i | cg@3088: (spaceInfos at:i) flags:(fetchINT value). cg@1416: ]. cg@3088: nSpaces+1 to:32 do:[:i | fetchINT value]. cg@1416: cg@1416: 1 to:nSpaces do:[:i | cg@3088: (spaceInfos at:i) start:(fetchINT value). cg@1416: ]. cg@3088: nSpaces+1 to:32 do:[:i | fetchINT value]. cg@1416: cg@1416: 1 to:nSpaces do:[:i | cg@3088: (spaceInfos at:i) size:(fetchINT value). cg@1416: ]. cg@3088: nSpaces+1 to:32 do:[:i | fetchINT value]. cg@1416: version >= 8 ifTrue:[ cg@1864: stream reset. cg@1417: stream skip:4096. cg@1416: ]. cg@1416: cg@1416: 1 to:nSpaces do:[:i | cg@1416: (spaceInfos at:i) end:((spaceInfos at:i) start + (spaceInfos at:i) size - 1). cg@1416: ]. cg@1416: 1 to:nSpaces do:[:i | cg@1416: (spaceInfos at:i) imageBase:(stream position). cg@1417: spaceSize := (spaceInfos at:i) size. cg@1417: stream skip:spaceSize. cg@1416: ]. cg@1416: cg@1416: "/ registration cg@1416: cg@1416: self readRegistrationEntries. cg@1417: Transcript showCR:'reading symbols...'. cg@1416: self readSymbolEntries. cg@1417: self readUGlobalEntries. cg@1417: Transcript showCR:'reading globals...'. cg@1416: self readGlobalEntries. cg@1416: cg@1416: cg@1416: "/struct basicImageHeader { cg@1416: "/ char h_execCmd[256]; cg@1416: "/ cg@1416: "/ int h_orderWord; cg@1416: "/ char h_magic[8]; cg@1416: "/ int h_version; cg@1416: "/ int h_timeStamp; cg@1416: "/ char h_ptrSize; cg@1416: "/ char h_filler1[7]; cg@1416: "/ int h_intSize; cg@1416: "/ int h_snapID; cg@1416: "/ INT h_last_util_addr; cg@1416: "/ INT h_hiText_addr; cg@1416: "/ INT h_flags; cg@1416: "/ char h_infoPrinting; cg@1416: "/ char h_debugPrinting; cg@1416: "/ char h_filler2[6]; cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * these are to verify compatibility of the image with cg@1416: "/ * myself ... cg@1416: "/ * this is now obsolete. cg@1416: "/ */ cg@1416: "/ INT h_lowData, h_hiData; cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * base address of character- and characterTable slots cg@1416: "/ */ cg@1416: "/ INT h_charSlots; cg@1416: "/ INT h_charTableSlots; cg@1416: "/ cg@1416: "/#if HEADER_VERSION >= 8 cg@1416: "/ /* cg@1416: "/ * the fixBase (VMDATA address) cg@1416: "/ */ cg@1416: "/ INT h_fixMemStart; cg@1416: "/ INT h_fixMemEnd; cg@1416: "/ INT h_symMemStart; cg@1416: "/ INT h_symMemEnd; cg@1416: "/ cg@1416: "/ INT h_vmDataAddr; cg@1416: "/#endif cg@1416: "/ cg@1416: "/ INT h_sharedMethodCode[128]; cg@1416: "/ INT h_sharedBlockCode[128]; cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * space needed to restore contexts cg@1416: "/ */ cg@1416: "/ INT h_nContexts; cg@1416: "/ INT h_contextSpace; cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * number of class registration info records cg@1416: "/ */ cg@1416: "/ INT h_nRegistered; cg@1416: "/ cg@1416: "/#if HEADER_VERSION >= 8 cg@1416: "/ /* cg@1416: "/ * reserved slots, for future versions cg@1416: "/ * (can add additional info, without affecting position of following stuff) cg@1416: "/ * If you add slots, you MUST DECREMENT the fillcount. cg@1416: "/ */ cg@1416: "/# if HEADER_VERSION >= 9 cg@1416: "/ INT h_symbolsSeqNr; cg@1416: "/ INT h_reserved[31]; cg@1416: "/# else cg@1416: "/ INT h_reserved[32]; cg@1416: "/# endif cg@1416: "/#endif cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * number of spaces, base and size of each cg@1416: "/ */ cg@1416: "/ INT h_nSpaces; cg@1416: "/ INT h_spaceFlags[MAXSPACES]; cg@1416: "/ INT h_spaceBase[MAXSPACES]; cg@1416: "/ INT h_spaceSize[MAXSPACES]; cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * here come nSpaces object spaces cg@1416: "/ */ cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * here comes registration info cg@1416: "/ */ cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * here come nSymbols symbolEntries cg@1416: "/ * followed by a zero/zero entry cg@1416: "/ */ cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * here come nGlobal globalEntries cg@1416: "/ * followed by a zero/zero entry cg@1416: "/ */ cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * here come nUnnamedGlobal globalEntries cg@1416: "/ * followed by a zero/zero entry cg@1416: "/ */ cg@1416: "/ cg@1416: "/ /* cg@1416: "/ * here come stack contexts cg@1416: "/ */ cg@1416: "/}; cg@1416: ! cg@1416: cg@1416: readRegistrationEntries cg@1416: |classNameSize| cg@1416: cg@1416: [ cg@1416: classNameSize := stream nextUnsignedLongMSB:msb. cg@1416: classNameSize ~~ 0 cg@1416: ] whileTrue:[ cg@1416: |className flags moduleTimestamp signature nMethods nBlocks oldLitRefs nLitRefs cg@1416: oldConstTable nConsts| cg@1416: cg@1416: className := (stream next:classNameSize) asString. cg@1416: stream next. "/ 0-byte cg@3088: flags := fetchINT value. cg@3088: moduleTimestamp := fetchINT value. cg@3088: signature := fetchINT value. cg@1416: nMethods := stream nextUnsignedLongMSB:msb. cg@3088: nMethods timesRepeat:[ fetchINT value ]. cg@1416: nBlocks := stream nextUnsignedLongMSB:msb. cg@3088: nBlocks timesRepeat:[ fetchINT value ]. cg@3088: cg@3088: oldLitRefs := fetchINT value. cg@1416: nLitRefs := stream nextUnsignedLongMSB:msb. cg@3088: nLitRefs timesRepeat:[ fetchINT value ]. cg@3088: fetchINT value. "/ 0-litRef cg@3088: oldConstTable := fetchINT value. cg@1550: nConsts := stream nextLongMSB:msb. cg@1550: nConsts > 0 ifTrue:[ cg@3088: nConsts timesRepeat:[ fetchINT value ]. cg@3088: ]. cg@3088: "/ Transcript show:className; cg@3088: "/ show:' nconsts:'; show:nConsts; cg@3088: "/ show:' nlits:'; show:nLitRefs; cg@3088: "/ show:' nMethods:'; show:nMethods; cg@3088: "/ show:' nBlocks:'; showCR:nBlocks. cg@1416: ]. cg@1416: ! cg@1416: cg@1416: readSymbolEntries cg@1417: |refPointer theSymbolPtr theSymbolRef pos| cg@1416: cg@1416: symbolEntries := OrderedCollection new. cg@1416: cg@1416: [ cg@3088: refPointer := fetchINT value. cg@3088: theSymbolPtr := fetchINT value. cg@1417: theSymbolPtr ~~ 0 cg@1416: ] whileTrue:[ cg@1417: symbolEntries add:theSymbolPtr. cg@1416: ]. cg@1417: symbolEntries := symbolEntries asArray. cg@1417: cg@1417: pos := stream position. cg@3088: 1 to:symbolEntries size do:[:i | cg@3088: |theSymbolPtr| cg@3088: cg@3088: "/ an inlined collect, to avoid allocating big array twice. cg@3088: theSymbolPtr := symbolEntries at:i. cg@1417: theSymbolRef := self fetchObjectAt:theSymbolPtr. cg@1417: theSymbolRef isImageSymbol ifFalse:[ cg@1417: self halt cg@1417: ]. cg@3088: symbolEntries at:i put:theSymbolRef. cg@1417: ]. cg@1417: stream position:pos cg@1416: ! cg@1416: cg@1416: readUGlobalEntries cg@1416: |refPointer theValue| cg@1416: cg@1416: [ cg@3088: refPointer := fetchINT value. cg@3088: theValue := fetchINT value. cg@1416: refPointer ~~ 0 cg@1416: ] whileTrue cg@1416: ! ! cg@1416: cg@3088: !SnapShotImageMemory methodsFor:'queries'! cg@3088: cg@3088: metaClassByteSize cg@3088: ^ Metaclass instSize * ptrSize + hdrSize cg@3088: ! cg@3088: cg@3088: privateMetaClassByteSize cg@3088: ^ PrivateMetaclass instSize * ptrSize + hdrSize cg@3088: ! ! cg@3088: cg@1417: !SnapShotImageMemory::ImageHeader methodsFor:'accessing'! cg@1417: cg@1864: address:something cg@1864: address := something. cg@1864: ! cg@1864: cg@1417: bits cg@1417: "return the value of the instance variable 'bits' (automatically generated)" cg@1417: cg@1440: ^ bits cg@1440: ! cg@1417: cg@1417: bits:something cg@1417: "set the value of the instance variable 'bits' (automatically generated)" cg@1417: cg@1440: bits := something. cg@1440: ! cg@1417: cg@1417: byteSize cg@1417: "return the value of the instance variable 'size' (automatically generated)" cg@1417: cg@1417: ^ byteSize cg@1417: ! cg@1417: cg@1417: byteSize:something cg@1417: "set the value of the instance variable 'size' (automatically generated)" cg@1417: cg@1791: "/ something > 8000 ifTrue:[self halt]. cg@1417: byteSize := something. cg@1417: ! cg@1417: cg@1417: classRef cg@1417: "return the value of the instance variable 'classRef' (automatically generated)" cg@1417: cg@1440: ^ classRef cg@1440: ! cg@1417: cg@1417: classRef:something cg@1417: "set the value of the instance variable 'classRef' (automatically generated)" cg@1417: cg@1440: classRef := something. cg@1440: ! cg@1417: cg@1417: memory cg@1417: "return the value of the instance variable 'memory' (automatically generated)" cg@1417: cg@1440: ^ memory cg@1440: ! cg@1417: cg@1417: memory:something cg@1417: "set the value of the instance variable 'memory' (automatically generated)" cg@1417: cg@1440: memory := something. cg@1440: ! ! cg@1417: cg@1417: !SnapShotImageMemory::ImageHeader methodsFor:'queries'! cg@1417: cg@1417: category cg@1791: |categoryPtr categoryRef category categorySlotOffset| cg@1417: cg@1417: self isMethodOrLazyMethod ifTrue:[ cg@1791: categorySlotOffset := Method instVarOffsetOf:'category'. cg@1791: "/ categorySlotOffset := 6. cg@1791: categoryPtr := self at:categorySlotOffset. cg@1417: categoryRef := memory fetchObjectAt:categoryPtr. cg@1417: category := memory fetchStringFor:categoryRef. cg@1417: ^ category cg@1417: ]. cg@1417: self halt. cg@1417: ! cg@1417: cg@1419: isBehavior cg@1440: ^ self isImageBehavior cg@1440: ! cg@1419: cg@1417: isImageBehavior cg@1417: |flags| cg@1417: cg@1417: flags := classRef flags. cg@1417: ^ flags bitTest:Behavior flagBehavior cg@1417: ! cg@1417: cg@1417: isImageBytes cg@1417: |flags| cg@1417: cg@1417: flags := classRef flags bitAnd:Behavior maskIndexType. cg@1417: ^ flags = Behavior flagBytes cg@1417: ! cg@1417: cg@1417: isImageMethod cg@1417: |flags| cg@1417: cg@1417: flags := classRef flags. cg@1417: ^ flags bitTest:Behavior flagMethod cg@1417: ! cg@1417: cg@1417: isImageSymbol cg@1417: |flags| cg@1417: cg@1417: flags := classRef flags. cg@1417: ^ flags bitTest:Behavior flagSymbol cg@1417: ! cg@1417: mawalch@3324: isJavaMethod cg@1420: |nm| cg@1420: cg@1420: nm := classRef name. cg@1420: ^ (nm = 'JavaMethod' mawalch@3324: or:[ nm = 'JavaMethodWithException' mawalch@3324: or:[ nm = 'JavaMethodWithHandler' cg@1420: or:[ nm = 'JavaNativeMethod' ]]]) cg@1420: ! cg@1420: mawalch@3324: isLazyMethod cg@1440: ^ classRef name = 'LazyMethod' cg@1440: ! cg@1419: cg@1417: isMeta cg@1417: ^ false cg@1417: ! cg@1417: mawalch@3324: isMethod cg@1420: |cls| cg@1420: cg@1420: cls := classRef. cg@1420: [cls notNil] whileTrue:[ cg@1420: cls name = 'Method' ifTrue:[^ true]. cg@1420: cls := cls superclass cg@1420: ]. cg@1420: ^ false. cg@1417: ! cg@1417: cg@1417: isMethodDictionary cg@1417: ^ classRef name = 'MethodDictionary' cg@1417: ! cg@1417: mawalch@3324: isMethodOrLazyMethod cg@1417: classRef name = 'LazyMethod' ifTrue:[^ true]. cg@1420: ^ self isMethod cg@1417: ! cg@1417: cg@1417: isString cg@1417: ^ classRef name = 'String' cg@1417: ! ! cg@1417: cg@1419: !SnapShotImageMemory::ImageObject methodsFor:'method protocol'! cg@1419: cg@1419: byteCode cg@1419: |byteCodeSlotOffset byteCodePtr byteCodeRef byteCode| cg@1419: cg@1419: self isMethod ifTrue:[ cg@1419: byteCodeSlotOffset := Method instVarOffsetOf:'byteCode'. cg@1419: ]. cg@1419: byteCodeSlotOffset notNil ifTrue:[ cg@1419: byteCodePtr := self at:byteCodeSlotOffset. cg@1419: byteCodeRef := memory fetchObjectAt:byteCodePtr. cg@1419: byteCodeRef isNil ifTrue:[^ nil]. cg@1419: cg@1419: byteCode := memory fetchByteArrayFor:byteCodeRef. cg@1419: ^ byteCode cg@1419: ]. cg@1419: cg@1419: self halt. cg@1419: ! cg@1419: cg@1419: comment cg@1419: |src comment comments parser| cg@1419: cg@1419: self isMethod ifTrue:[ cg@1419: src := self source. cg@1419: src isNil ifTrue:[^ nil]. cg@1419: cg@1419: parser := Parser for:src in:nil. cg@1419: parser ignoreErrors; ignoreWarnings; saveComments:true. cg@1419: parser parseMethodSpec. cg@1419: comments := parser comments. cg@1419: comments size ~~ 0 ifTrue:[ cg@1419: comment := comments first string. cg@1419: (comment withoutSpaces endsWith:'}') ifTrue:[ cg@1419: "if first comment is a pragma, take next comment" cg@1419: comment := comments at:2 ifAbsent:nil. cg@1419: comment notNil ifTrue:[ cg@1419: comment := comment string. cg@1419: ]. cg@1419: ]. cg@1417: ]. cg@1419: ^ comment. cg@1417: ]. cg@1419: self isLazyMethod ifTrue:[ cg@1419: ^ '' cg@1419: ]. cg@1419: cg@1419: self halt. cg@1417: ! cg@1416: cg@1419: containingClass cg@1419: self isMethodOrLazyMethod ifTrue:[ cg@1419: ^ self mclass cg@1417: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1469: flags cg@1469: |flagsSlotOffset flagsPtr flags| cg@1469: cg@1469: self isMethod ifTrue:[ cg@1469: flagsSlotOffset := Method instVarOffsetOf:'flags'. cg@1469: ]. cg@1469: flagsSlotOffset notNil ifTrue:[ cg@1469: flagsPtr := self at:flagsSlotOffset. cg@1469: flags := memory fetchObjectAt:flagsPtr. cg@1469: ^ flags cg@1469: ]. cg@1469: cg@1469: self halt. cg@1469: ! cg@1469: cg@1419: hasCode cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isBreakpointed cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isCounting cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isCountingMemoryUsage cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isDynamic cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isExecutable cg@1419: self isMethod ifTrue:[ cg@1419: ^ false cg@1419: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1419: isIgnored cg@1440: ^ false cg@1440: ! cg@1419: cg@1482: isObsolete cg@1482: ^ false cg@1482: ! cg@1482: cg@1419: isPrivate cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isProtected cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isPublic cg@1440: ^ true cg@1440: ! cg@1419: cg@1419: isTimed cg@1440: ^ false cg@1440: ! cg@1419: cg@1419: isTraced cg@1440: ^ false cg@1440: ! cg@1416: cg@1417: isWrapped cg@1417: ^ false cg@1416: ! cg@1416: cg@1419: mclass cg@1419: |mclassSlotOffset mclassPtr mclass| cg@1419: cg@1419: self isMethod ifTrue:[ cg@1419: mclassSlotOffset := Method instVarOffsetOf:'mclass'. cg@1420: ] ifFalse:[ cg@1420: self isJavaMethod ifTrue:[ cg@1420: mclassSlotOffset := JavaMethod instVarOffsetOf:'javaClass'. cg@1420: ] cg@1420: ]. cg@1420: cg@1420: mclassSlotOffset notNil ifTrue:[ cg@1419: mclassPtr := self at:mclassSlotOffset. cg@1419: mclassPtr ~~ 0 ifTrue:[ cg@1420: mclassPtr isInteger ifTrue:[ cg@1420: mclass := memory fetchObjectAt:mclassPtr. cg@1420: self at:mclassSlotOffset put:mclass. cg@1420: ] ifFalse:[ cg@1420: mclass := mclassPtr. cg@1420: ]. cg@1419: mclass isImageBehavior ifFalse:[ cg@1419: self halt cg@1419: ]. cg@1419: ^ mclass cg@1419: ]. cg@1419: cg@1419: "/ search my class ... cg@1419: memory image allClassesDo:[:eachClass | cg@1419: eachClass theNonMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef | cg@1419: mthdRef == self ifTrue:[ cg@1419: self at:mclassSlotOffset put:eachClass theNonMetaclass. cg@1419: ^ eachClass theNonMetaclass cg@1419: ]. cg@1419: ]. cg@1419: eachClass theMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef | cg@1419: mthdRef == self ifTrue:[ cg@1419: self at:mclassSlotOffset put:eachClass theMetaclass. cg@1419: ^ eachClass theMetaclass cg@1419: ]. cg@1419: ] cg@1417: ]. cg@1419: self halt. cg@1420: ^ nil. cg@1417: ]. cg@1420: ^ nil. cg@1419: self halt. cg@1417: ! cg@1417: cg@1419: numArgs cg@1469: |flags| cg@1469: cg@1469: flags := self flags. cg@1469: ^ (flags bitAnd:(Method numArgsMaskInFlags)) bitShift:(Method numArgsShiftInFlags negated) cg@1419: ! cg@1419: cg@1419: package cg@1419: |packageSlotOffset packagePtr packageRef package| cg@1419: cg@1419: self isImageBehavior ifTrue:[ cg@1419: self isMeta ifTrue:[ cg@1419: ^ self theNonMetaclass package cg@1419: ]. cg@1419: packageSlotOffset := Class instVarOffsetOf:'package'. cg@1420: ] ifFalse:[ cg@1420: self isMethod ifTrue:[ cg@1420: packageSlotOffset := Method instVarOffsetOf:'package'. cg@1420: ] ifFalse:[ cg@1420: self isLazyMethod ifTrue:[ cg@1420: packageSlotOffset := Method instVarOffsetOf:'package'. cg@1420: ]. cg@1420: ]. cg@1419: ]. cg@1419: packageSlotOffset notNil ifTrue:[ cg@1419: packagePtr := self at:packageSlotOffset. cg@1419: packageRef := memory fetchObjectAt:packagePtr. cg@1419: packageRef isNil ifTrue:[^ nil]. cg@1419: cg@1419: packageRef isImageSymbol ifFalse:[ cg@1420: packageRef isImageBytes ifFalse:[ cg@1420: self halt. cg@1420: ]. cg@1420: "/ mhmh - can be a string sometimes ... cg@1419: ]. cg@1419: package := memory fetchStringFor:packageRef. cg@1419: ^ package asSymbol cg@1419: ]. cg@1419: self isMeta ifTrue:[ cg@1419: self halt cg@1419: ]. cg@1419: cg@1420: ^ nil cg@1419: ! cg@1419: cg@1419: previousVersion cg@1440: ^ nil cg@1440: ! cg@1419: cg@1417: printStringForBrowserWithSelector:selector cg@1417: ^ selector cg@1417: ! cg@1417: sr@2164: printStringForBrowserWithSelector:selector inClass:aClass sr@2164: ^ selector sr@2164: ! sr@2164: cg@1419: privacy cg@1440: ^ #public cg@1440: ! cg@1419: cg@1417: resources cg@1417: ^ nil cg@1417: ! cg@1417: cg@1417: source cg@1482: self halt:'unimplemented'. cg@1416: ! cg@1416: cg@1419: sourceFilename cg@1419: "return the sourcefilename if source is extern; nil otherwise" cg@1419: cg@1486: |sourcePtr sourceRef source| cg@1485: cg@1419: self isMethodOrLazyMethod ifTrue:[ cg@1484: self sourcePosition notNil ifTrue:[ cg@1486: sourcePtr := self at:(Method instVarOffsetOf:'source'). cg@1486: sourceRef := memory fetchObjectAt:sourcePtr. cg@1486: sourceRef isString ifFalse:[ cg@1486: self halt. cg@1485: ]. cg@1486: source := memory printStringOfString:sourceRef. cg@1485: ^ source. cg@1484: ]. cg@1419: ^ nil cg@1419: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1419: sourceLineNumber cg@1419: self isMethodOrLazyMethod ifTrue:[ cg@1419: ^ 1 cg@1419: ]. cg@1419: self halt. cg@1419: ! cg@1419: cg@1419: sourcePosition cg@1419: |sourcePosition| cg@1419: cg@1419: self isMethodOrLazyMethod ifTrue:[ cg@1419: sourcePosition := self sourcePositionValue. cg@1419: sourcePosition isNil ifTrue:[^ sourcePosition]. cg@1419: ^ sourcePosition abs cg@1419: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1419: sourcePositionValue cg@1419: |sourcePosition sourcePositionPtr| cg@1419: cg@1419: self isMethodOrLazyMethod ifTrue:[ cg@1419: sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition'). cg@1419: sourcePosition := memory fetchObjectAt:sourcePositionPtr. cg@1419: ^ sourcePosition cg@1419: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1417: sourceStream mawalch@3324: |sourcePosition source aStream fileName junk who cg@1417: myClass mgr className sep dir mod package| cg@1417: cg@1417: self isMethod ifTrue:[ cg@1417: sourcePosition := self at:(Method instVarOffsetOf:'sourcePosition'). cg@1417: source := self at:(Method instVarOffsetOf:'source'). cg@1417: source := memory fetchObjectAt:source. cg@1417: source isString ifTrue:[ cg@1417: source := memory printStringOfString:source. cg@1417: ]. cg@1417: sourcePosition notNil ifTrue:[ cg@1417: sourcePosition := memory fetchObjectAt:sourcePosition. cg@1417: ]. cg@1417: cg@1417: source isNil ifTrue:[^ nil]. cg@1417: sourcePosition isNil ifTrue:[^ source readStream]. cg@1417: cg@1417: sourcePosition < 0 ifTrue:[ cg@1417: aStream := source asFilename readStream. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: cg@1417: fileName := Smalltalk getSourceFileName:source. cg@1417: fileName notNil ifTrue:[ cg@1417: aStream := fileName asFilename readStream. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: ]. cg@1417: ]. cg@1417: cg@1417: "/ cg@1417: "/ if there is no SourceManager, look in local standard places first cg@1417: "/ cg@1417: (mgr := Smalltalk at:#SourceCodeManager) isNil ifTrue:[ cg@1417: aStream := self localSourceStream. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: ]. cg@1417: cg@1417: "/ cg@1417: "/ nope - ask my class for the source (this also invokes the SCMgr) cg@1417: "/ cg@1417: myClass := self mclass. cg@1416: cg@1417: package := self package. cg@1417: (package notNil and:[package ~= myClass package]) ifTrue:[ cg@1417: mgr notNil ifTrue:[ cg@1417: "/ try to get the source using my package information ... cg@1417: sep := package indexOfAny:'/\:'. cg@1417: sep ~~ 0 ifTrue:[ cg@1417: mod := package copyTo:sep - 1. cg@1417: dir := package copyFrom:sep + 1. cg@1417: aStream := mgr streamForClass:nil fileName:source revision:nil directory:dir module:mod cache:true. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: ]. cg@1417: ]. cg@1417: ]. cg@1417: cg@1417: aStream := myClass sourceStreamFor:source. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: cg@1417: "/ mawalch@3324: "/ nope - look in standard places cg@1417: "/ (if there is a source-code manager - otherwise, we already did that) cg@1417: "/ cg@1417: mgr notNil ifTrue:[ cg@1417: aStream := self localSourceStream. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: ]. cg@1417: cg@1417: "/ cg@1417: "/ final chance: try current directory cg@1417: "/ cg@1417: aStream isNil ifTrue:[ cg@1417: aStream := source asFilename readStream. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: ]. cg@1417: cg@1417: (who isNil and:[source notNil]) ifTrue:[ cg@1417: "/ cg@1417: "/ mhmh - seems to be a method which used to be in some cg@1417: "/ class, but has been overwritten by another or removed. cg@1417: "/ (i.e. it has no containing class anyMore) cg@1417: "/ try to guess the class from the sourceFileName. cg@1417: "/ and retry. cg@1417: "/ cg@1417: className := Smalltalk classNameForFile:source. cg@1417: className knownAsSymbol ifTrue:[ cg@1417: myClass := Smalltalk at:className asSymbol ifAbsent:nil. cg@1417: myClass notNil ifTrue:[ cg@1417: aStream := myClass sourceStreamFor:source. cg@1417: aStream notNil ifTrue:[ cg@1417: ^ aStream cg@1417: ]. cg@1417: ] cg@1417: ] mawalch@3324: ]. cg@1417: cg@1417: ^ nil cg@1417: ]. cg@3089: ^ nil cg@1416: ! ! cg@1416: cg@1419: !SnapShotImageMemory::ImageObject methodsFor:'methodDictionary protocol'! cg@1419: cg@1419: at:aSelector ifAbsent:exceptionValue cg@1419: self isMethodDictionary ifTrue:[ cg@1419: cachedContents isNil ifTrue:[ cg@1419: self cacheMethodDictionary. cg@1419: ]. cg@1419: ^ cachedContents at:aSelector ifAbsent:exceptionValue cg@1419: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1419: cacheMethodDictionary cg@1419: |symPtr symRef mthdPtr mthdRef s| cg@1419: cg@1419: cachedContents isNil ifTrue:[ cg@1419: cachedContents := IdentityDictionary new. cg@1419: cg@1419: 1 to:self size by:2 do:[:idx | cg@1419: symPtr := self at:idx. cg@1419: symRef := memory fetchObjectAt:symPtr. cg@1419: symRef isImageSymbol ifFalse:[self halt]. cg@1419: s := memory fetchStringFor:symRef. cg@1419: mthdPtr := self at:idx + 1. cg@1419: mthdRef := memory fetchObjectAt:mthdPtr. cg@1419: cachedContents at:s asSymbol put:mthdRef. cg@1419: ]. cg@1440: ]. cg@1440: ! cg@1419: cg@1419: do:aBlock cg@1419: self isMethodDictionary ifTrue:[ cg@1419: cachedContents isNil ifTrue:[ cg@1419: self cacheMethodDictionary. cg@1419: ]. cg@1419: cachedContents do:aBlock. cg@1419: ^ self. cg@1419: ]. cg@1419: self halt. cg@1419: ! cg@1419: cg@1419: includesKey:aSelector cg@1419: self isMethodDictionary ifTrue:[ cg@1419: cachedContents isNil ifTrue:[ cg@1419: self cacheMethodDictionary. cg@1419: ]. cg@1419: ^ cachedContents includesKey:aSelector cg@1419: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1419: keyAtValue:aMethod ifAbsent:exceptionValue cg@1419: self isMethodDictionary ifTrue:[ cg@1419: cachedContents isNil ifTrue:[ cg@1419: self cacheMethodDictionary. cg@1419: ]. cg@1419: ^ cachedContents keyAtValue:aMethod ifAbsent:exceptionValue cg@1419: ]. cg@1440: self halt. cg@1440: ! cg@1419: cg@1419: keysAndValuesDo:aBlock cg@1419: self isMethodDictionary ifTrue:[ cg@1419: cachedContents isNil ifTrue:[ cg@1419: self cacheMethodDictionary. cg@1419: ]. cg@1419: cg@1419: cachedContents keysAndValuesDo:[:sel :mthdRef | cg@1419: aBlock value:sel value:mthdRef. cg@1419: ]. cg@1419: ^ self cg@1419: ]. cg@1419: self halt. cg@1419: ! ! cg@1419: cg@1448: !SnapShotImageMemory::ImageByteObject methodsFor:'queries'! cg@1448: cg@1448: size cg@1448: ^ byteSize cg@1448: ! ! cg@1448: cg@1482: !SnapShotImageMemory::ImageMethodObject methodsFor:'method protocol'! cg@1482: cg@1484: localSourceStream cg@1484: "try to open a stream from a local source file, cg@1484: searching in standard places." cg@1484: cg@1484: |fileName aStream package source| cg@1484: cg@1484: package := self package. cg@1485: source := self sourceFilename. cg@1484: package notNil ifTrue:[ cg@1484: fileName := Smalltalk getSourceFileName:(package copyReplaceAll:$: with:$/) , '/' , source. cg@1484: fileName notNil ifTrue:[ cg@1484: aStream := fileName asFilename readStream. cg@1484: aStream notNil ifTrue:[^ aStream]. cg@1484: ]. cg@1484: ]. cg@1484: fileName := Smalltalk getSourceFileName:source. cg@1484: fileName notNil ifTrue:[ cg@1484: aStream := fileName asFilename readStream. cg@1484: aStream notNil ifTrue:[^ aStream]. cg@1484: ]. cg@1484: ^ nil cg@1484: ! cg@1484: cg@1552: mclass cg@1552: cachedMClass isNil ifTrue:[ cg@1552: cachedMClass := super mclass. cg@1552: ]. cg@1552: ^ cachedMClass cg@1552: ! cg@1552: cg@1482: package cg@1482: |packageSlotOffset packagePtr packageRef package| cg@1482: cg@1482: cachedPackage isNil ifTrue:[ cg@1482: packageSlotOffset := Method instVarOffsetOf:'package'. cg@1482: cg@1482: packagePtr := self at:packageSlotOffset. cg@1482: packageRef := memory fetchObjectAt:packagePtr. cg@1482: packageRef isNil ifTrue:[^ nil]. cg@1482: cg@1482: packageRef isImageSymbol ifFalse:[ cg@1482: packageRef isImageBytes ifFalse:[ cg@1482: self halt. cg@1482: ]. cg@1482: "/ mhmh - can be a string sometimes ... cg@1482: ]. cg@1482: package := memory fetchStringFor:packageRef. cg@1482: cachedPackage := package asSymbol cg@1482: ]. cg@1482: ^ cachedPackage cg@1482: ! cg@1482: cg@1552: selector cg@1552: cachedSelector isNil ifTrue:[ cg@1552: self mclass methodDictionary keysAndValuesDo:[:sel :mthd | mthd == self ifTrue:[cachedSelector := sel]]. cg@1552: ]. cg@1552: ^ cachedSelector cg@1552: ! cg@1552: cg@1482: source cg@1482: |sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk| cg@1482: cg@1482: sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition'). cg@1482: sourcePtr := self at:(Method instVarOffsetOf:'source'). cg@1482: sourceRef := memory fetchObjectAt:sourcePtr. cg@1482: sourceRef isString ifFalse:[ cg@1482: self halt. cg@1482: ]. cg@1482: source := memory printStringOfString:sourceRef. cg@1482: sourcePosition := memory fetchObjectAt:sourcePositionPtr. cg@1482: sourcePosition isNil ifTrue:[ cg@1482: ^ source cg@1482: ]. cg@1482: cg@1482: aStream := self sourceStream. cg@1482: aStream notNil ifTrue:[ cg@1482: Stream positionErrorSignal handle:[:ex | cg@1482: ^ nil cg@1482: ] do:[ cg@1482: aStream position:sourcePosition abs. cg@1482: ]. cg@1482: junk := aStream nextChunk. cg@1482: cg@1482: aStream close. cg@1482: ^ junk cg@1482: ]. cg@1482: self halt. cg@1584: ! cg@1584: cg@1584: syntaxHighlighterClass cg@1584: ^ #askClass cg@1482: ! ! cg@1482: cg@1482: !SnapShotImageMemory::ImageMethodObject methodsFor:'queries'! cg@1482: cg@1482: isMethod cg@1482: ^ true sv@1865: ! sv@1865: sv@1865: previousVersionCode sv@1865: "return the receivers previous versions source code" sv@1865: sv@1865: "there is no previous version" sv@1865: ^ nil sv@1866: ! sv@1866: sv@1866: sends:aSelectorSymbol sv@1866: "return true, if this method contains a message-send sv@1866: with aSelectorSymbol as selector." sv@1866: sv@1866: "/ (self referencesLiteral:aSelectorSymbol) ifTrue:[ sv@1866: "/ ^ self messagesSent includesIdentical:aSelectorSymbol sv@1866: "/ ]. sv@1866: ^ false cg@1482: ! ! cg@1482: cg@1416: !SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'! cg@1416: cg@1417: category cg@1482: |categoryRef| cg@1482: cg@1482: cachedCategory isNil ifTrue:[ cg@1482: categoryRef := self categorySlot. cg@1482: categoryRef isInteger ifTrue:[ cg@1482: categoryRef := memory fetchObjectAt:categoryRef. cg@1482: ]. cg@1482: categoryRef notNil ifTrue:[ cg@1482: cachedCategory := memory fetchStringFor:categoryRef. cg@1482: ]. cg@1417: ]. cg@1482: ^ cachedCategory cg@1417: ! cg@1417: cg@1416: categorySlot cg@1440: ^ self at:(Class instVarOffsetOf:'category') cg@1440: ! cg@1419: cg@2130: classBaseFilename cg@2130: ^ self classFilename asFilename baseName cg@2130: cg@2130: "Created: / 19-10-2006 / 01:10:17 / cg" cg@2130: ! cg@2130: cg@1419: classFilename cg@1419: |classFilenameRef classFilename| cg@1419: cg@1419: classFilenameRef := self classFilenameSlot. cg@1419: classFilenameRef isInteger ifTrue:[ cg@1419: classFilenameRef := memory fetchObjectAt:classFilenameRef. cg@1419: ]. cg@1419: classFilenameRef notNil ifTrue:[ cg@1419: classFilename := memory fetchStringFor:classFilenameRef. cg@1419: ]. cg@1440: ^ classFilename cg@1440: ! cg@1416: cg@1416: classFilenameSlot cg@1440: ^ self at:(Class instVarOffsetOf:'classFilename') cg@1440: ! cg@1416: cg@1417: classVarNames cg@1417: |classVarNamesRef classVarNames s| cg@1417: cg@1417: classVarNamesRef := self classVarsSlot. cg@1417: classVarNamesRef isInteger ifTrue:[ cg@1417: classVarNamesRef := memory fetchObjectAt:classVarNamesRef. cg@1417: ]. cg@1417: classVarNamesRef notNil ifTrue:[ cg@1417: classVarNamesRef isImageBytes ifTrue:[ cg@1417: "/ a string cg@1417: classVarNames := memory fetchStringFor:classVarNamesRef. cg@1417: classVarNames := classVarNames asCollectionOfWords. cg@1417: ] ifFalse:[ cg@1417: classVarNames := Array new:(classVarNamesRef size). cg@1417: 1 to:classVarNames size do:[:idx | cg@1417: s := classVarNamesRef at:idx. cg@1417: s := memory fetchObjectAt:s. cg@1417: s isImageBytes ifFalse:[self halt]. cg@1417: s := memory fetchStringFor:s. cg@1417: classVarNames at:idx put:s. cg@1417: ]. cg@1417: ]. cg@1417: ]. cg@1482: ^ classVarNames ? #() cg@1417: ! cg@1417: cg@1419: classVariableString cg@1419: |classVarsPtr classVarsRef classVars| cg@1419: cg@1419: (classVarsPtr := self classVarsSlot) == 0 ifTrue:[^ '']. cg@1419: classVarsRef := memory fetchObjectAt:classVarsPtr. cg@1419: classVarsRef isImageBytes ifTrue:[ cg@1419: "/ a string cg@1419: classVars := memory fetchStringFor:classVarsRef. cg@1419: ^ classVars cg@1419: ]. cg@1419: ^ self classVarNames asStringWith:(Character space) cg@1419: ! cg@1419: cg@1416: classVarsSlot cg@1791: ^ self at:(Class instVarOffsetOf:'classvars') cg@1416: ! cg@1416: cg@1417: comment cg@3089: |commentRef comment stream string| cg@1417: cg@1417: commentRef := self commentSlot. cg@1417: commentRef isInteger ifTrue:[ cg@3089: (SnapShotImageMemory isSmallIntegerOOP:commentRef) ifTrue:[ cg@3089: "/ comment points into file. cg@3089: stream := self sourceStream. cg@3089: stream notNil ifTrue:[ cg@3089: Stream positionErrorSignal handle:[:ex | cg@3089: ^ nil cg@3089: ] do:[ cg@3089: stream position:(commentRef bitShift:-1). cg@3089: string := String readFrom:stream. cg@3089: stream close. cg@3089: ]. cg@3089: ^ string cg@3089: ]. cg@3089: ^ nil cg@3089: ]. cg@1417: commentRef := memory fetchObjectAt:commentRef. cg@1417: ]. cg@1417: commentRef notNil ifTrue:[ cg@1417: comment := memory fetchStringFor:commentRef. cg@1417: ]. cg@1417: ^ comment cg@1417: ! cg@1417: cg@3088: commentOrDocumentationString cg@3088: "the classes documentation-method's comment, its plain cg@3088: comment or nil" cg@3088: cg@3088: |cls m s| cg@3088: cg@3088: cls := self theNonMetaclass. cg@3088: m := cls theMetaclass compiledMethodAt:#documentation. cg@3088: m notNil ifTrue:[ cg@3088: "/ try documentation method's comment cg@3088: s := m comment. cg@3088: ] ifFalse:[ cg@3088: "try classes comment" cg@3088: s := cls comment. cg@3088: s isString ifTrue:[ cg@3088: s isEmpty ifTrue:[ cg@3088: s := nil cg@3088: ] ifFalse:[ cg@3088: (s includes:$") ifTrue:[ cg@3088: s := s copyReplaceAll:$" with:$'. cg@3088: ]. cg@3088: s size > 80 ifTrue:[ cg@3088: s := s asCollectionOfSubstringsSeparatedBy:$.. cg@3088: s := s asStringCollection. cg@3088: s := s collect:[:each | (each startsWith:Character space) ifTrue:[ cg@3088: each copyFrom:2 cg@3088: ] ifFalse:[ cg@3088: each cg@3088: ] cg@3088: ]. cg@3088: s := s asStringWith:('.' , Character cr). cg@3088: ]. cg@3088: ] cg@3088: ] ifFalse:[ cg@3088: "/ class redefines comment ? cg@3088: s := nil cg@3088: ]. cg@3088: ]. cg@3088: s isEmptyOrNil ifTrue:[^ s]. cg@3088: ^ s withTabsExpanded cg@3088: cg@3088: " cg@3088: Array commentOrDocumentationString cg@3088: " cg@3088: ! cg@3088: cg@1416: commentSlot cg@1440: ^ self at:(Class instVarOffsetOf:'comment') cg@1440: ! cg@1416: cg@1417: flags cg@3088: |flags| cg@1416: cg@1482: cachedFlags isNil ifTrue:[ cg@1482: flags := self flagsSlot. cg@1482: cg@1482: (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[ cg@1482: self halt cg@1482: ]. cg@3088: cachedFlags := flags bitShift:-1. cg@1416: ]. cg@1482: ^ cachedFlags cg@1416: ! cg@1416: cg@1417: flagsSlot cg@1440: ^ self at:(Class instVarOffsetOf:'flags') cg@1440: ! cg@1419: cg@1419: instSize cg@1419: |instSizeRef| cg@1419: cg@1419: instSizeRef := self instSizeSlot. cg@1440: ^ memory fetchObjectAt:instSizeRef. cg@1440: ! cg@1417: cg@1416: instSizeSlot cg@1440: ^ self at:(Class instVarOffsetOf:'instSize') cg@1440: ! cg@1416: cg@1417: instVarNames cg@1417: |instVarNamesRef instVarNames s| cg@1417: cg@1417: instVarNamesRef := self instVarsSlot. cg@1417: instVarNamesRef isInteger ifTrue:[ cg@1417: instVarNamesRef := memory fetchObjectAt:instVarNamesRef. cg@1417: ]. cg@1417: instVarNamesRef notNil ifTrue:[ cg@1417: instVarNamesRef isImageBytes ifTrue:[ cg@1417: "/ a string cg@1417: instVarNames := memory fetchStringFor:instVarNamesRef. cg@1417: instVarNames := instVarNames asCollectionOfWords. cg@1417: ] ifFalse:[ cg@1417: instVarNames := Array new:(instVarNamesRef size). cg@1417: 1 to:instVarNames size do:[:idx | cg@1417: s := instVarNamesRef at:idx. cg@1417: s := memory fetchObjectAt:s. cg@1417: s isImageBytes ifFalse:[self halt]. cg@1417: s := memory fetchStringFor:s. cg@1417: instVarNames at:idx put:s. cg@1417: ]. cg@1417: ]. cg@1417: ]. cg@1440: ^ instVarNames ? #() cg@1440: ! cg@1417: cg@1416: instVarsSlot cg@1791: ^ self at:(Class instVarOffsetOf:'instvars') cg@1416: ! cg@1416: cg@1417: methodDictionary cg@1417: |methodDictionaryRef methodDictionary| cg@1417: cg@1417: methodDictionaryRef := self methodDictionarySlot. cg@1417: methodDictionaryRef isInteger ifTrue:[ cg@1417: methodDictionaryRef == 0 ifTrue:[^ nil]. cg@1417: methodDictionary := memory fetchObjectAt:methodDictionaryRef. cg@1417: ]. cg@1417: ^ methodDictionary cg@1417: ! cg@1417: cg@1416: methodDictionarySlot cg@1440: ^ self at:(Class instVarOffsetOf:'methodDictionary') cg@1440: ! cg@1416: cg@1417: name cg@1482: |nameRef| cg@1482: cg@1482: cachedName isNil ifTrue:[ cg@1482: self isMeta ifTrue:[ cg@1482: cachedName := self theNonMetaclass name , ' class' cg@1482: ] ifFalse:[ cg@1792: self isPrivateMeta ifTrue:[ cg@1792: self halt. cg@1792: ]. cg@1792: cg@1482: nameRef := self nameSlot. cg@1482: nameRef isInteger ifTrue:[ cg@1482: nameRef := memory fetchObjectAt:nameRef. cg@1482: ]. cg@1482: nameRef notNil ifTrue:[ cg@1482: cachedName := memory fetchStringFor:nameRef. cg@1482: cachedName := cachedName asSymbol cg@1482: ]. cg@1482: ]. cg@1419: ]. cg@1482: ^ cachedName cg@1417: ! cg@1417: cg@1416: nameSlot cg@1440: ^ self at:(Class instVarOffsetOf:'name') cg@1440: ! cg@1416: cg@1416: packageSlot cg@1440: ^ self at:(Class instVarOffsetOf:'package') cg@1440: ! cg@1419: cg@1419: primitiveSpec cg@1419: |primitiveSpecRef primitiveSpec| cg@1419: cg@1419: primitiveSpecRef := self primitiveSpecSlot. cg@1419: primitiveSpecRef isInteger ifTrue:[ cg@1419: primitiveSpecRef := memory fetchObjectAt:primitiveSpecRef. cg@1419: ]. cg@1419: primitiveSpecRef notNil ifTrue:[ cg@1419: primitiveSpec := memory fetchStringFor:primitiveSpecRef. cg@1419: ]. cg@1419: ^ primitiveSpec cg@1416: ! cg@1416: cg@1419: primitiveSpecSlot cg@1791: (Class instVarOffsetOf:'primitiveSpec') isNil ifTrue:[ cg@1791: ^ self at:(Class instVarOffsetOf:'attributes') cg@1791: ]. cg@1440: ^ self at:(Class instVarOffsetOf:'primitiveSpec') cg@1440: ! cg@1419: cg@1419: revision cg@1419: |revisionRef revision| cg@1419: cg@1419: revisionRef := self revisionSlot. cg@1419: revisionRef isInteger ifTrue:[ cg@1419: revisionRef := memory fetchObjectAt:revisionRef. cg@1419: ]. cg@1419: revisionRef notNil ifTrue:[ cg@1419: revision := memory fetchStringFor:revisionRef. cg@1419: ]. cg@1440: ^ revision cg@1440: ! cg@1419: cg@1416: revisionSlot cg@1791: ^ self at:(Class instVarOffsetOf:'revision') cg@1416: ! cg@1416: cg@1417: superclass cg@1417: |superClassRef superClass| cg@1417: cg@1417: superClassRef := self superclassSlot. cg@1417: superClassRef isInteger ifTrue:[ cg@1417: superClass := memory fetchObjectAt:superClassRef. cg@1417: ]. cg@1417: ^ superClass cg@1417: ! cg@1417: cg@1417: superclassSlot cg@1791: ^ self at:(Class instVarOffsetOf:'superclass') cg@1416: ! ! cg@1416: cg@1417: !SnapShotImageMemory::ImageClassObject methodsFor:'class protocol'! cg@1417: cg@1419: addAllClassVarNamesTo:aCollection cg@1419: "helper - add the name-strings of the class variables and of the class-vars cg@1419: of all superclasses to the argument, aCollection. Return aCollection" cg@1419: cg@1419: |classvars superclass| cg@1419: cg@1419: (superclass := self superclass) notNil ifTrue:[ cg@1419: superclass addAllClassVarNamesTo:aCollection cg@1419: ]. cg@1419: (classvars := self classVariableString) notNil ifTrue:[ cg@1419: aCollection addAll:(classvars asCollectionOfWords). cg@1419: ]. cg@1440: ^ aCollection cg@1440: ! cg@1419: cg@1419: addAllInstVarNamesTo:aCollection cg@1419: |superInsts instvars superclass| cg@1419: cg@1419: (superclass := self superclass) notNil ifTrue:[ cg@1419: self superclass addAllInstVarNamesTo:aCollection cg@1419: ]. cg@1419: aCollection addAll:self instVarNames. cg@1440: ^ aCollection cg@1440: ! cg@1440: cg@1440: addChangeRecordForClassFileOut:aClass cg@1440: ! cg@1419: cg@1419: allClassVarNames cg@1419: "return a collection of all the class variable name-strings cg@1419: this includes all superclass-class variables" cg@1419: cg@1440: ^ self addAllClassVarNamesTo:(OrderedCollection new) cg@1440: ! cg@1419: cg@1419: allInstVarNames cg@1419: self superclass isNil ifTrue:[^ self instVarNames]. cg@1440: ^ self addAllInstVarNamesTo:(OrderedCollection new) cg@1440: ! cg@1419: cg@1419: allSubclassesDo:aBlock cg@1419: "evaluate aBlock for all of my subclasses. cg@1419: There is no specific order, in which the entries are enumerated. cg@1419: Warning: cg@1419: This will only enumerate globally known classes - for anonymous cg@1419: behaviors, you have to walk over all instances of Behavior." cg@1419: cg@1419: self isMeta ifTrue:[ cg@1419: "/ metaclasses are not found via Smalltalk allClassesDo: cg@1419: "/ here, walk over classes and enumerate corresponding metas. cg@1419: self soleInstance allSubclassesDo:[:aSubClass | cg@1482: aBlock value:(aSubClass theMetaclass) cg@1419: ]. cg@1419: ] ifFalse:[ cg@1419: Smalltalk allClassesDo:[:aClass | cg@1419: (aClass isSubclassOf:self) ifTrue:[ cg@1419: aBlock value:aClass cg@1419: ] cg@1419: ] cg@1419: ] cg@1419: cg@1419: " cg@1419: Collection allSubclassesDo:[:c | Transcript showCR:(c name)] cg@1419: Collection class allSubclassesDo:[:c | Transcript showCR:(c name)] cg@1419: " cg@1419: cg@1419: "Modified: / 25.10.1997 / 21:17:13 / cg" cg@1419: ! cg@1419: cg@1419: allSuperclasses cg@1419: "return a collection of the receivers accumulated superclasses" cg@1419: cg@1419: |aCollection theSuperClass| cg@1419: cg@1419: theSuperClass := self superclass. cg@1419: theSuperClass isNil ifTrue:[ cg@1419: ^ #() cg@1419: ]. cg@1419: aCollection := OrderedCollection new. cg@1419: [theSuperClass notNil] whileTrue:[ cg@1419: aCollection add:theSuperClass. cg@1419: theSuperClass := theSuperClass superclass cg@1419: ]. cg@1419: ^ aCollection cg@1419: cg@1419: " cg@1419: String allSuperclasses cg@1440: " cg@1440: ! cg@1419: cg@1419: allSuperclassesDo:aBlock cg@1419: "evaluate aBlock for all of my superclasses" cg@1419: cg@1419: |theClass| cg@1419: cg@1419: theClass := self superclass. cg@1419: [theClass notNil] whileTrue:[ cg@1419: aBlock value:theClass. cg@1419: theClass := theClass superclass cg@1419: ] cg@1419: cg@1419: " cg@1419: String allSuperclassesDo:[:c | Transcript showCR:(c name)] cg@1419: " cg@1419: ! cg@1419: cg@1419: basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace cg@1419: "append an expression on aStream, which defines myself." cg@1419: cg@1419: self cg@1419: basicFileOutDefinitionOn:aStream cg@1419: withNameSpace:forceNameSpace cg@1440: withPackage:true cg@1440: ! cg@1419: cg@1417: basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace withPackage:showPackage cg@1417: "append an expression on aStream, which defines myself." cg@1417: cg@1417: |s owner ns nsName fullName superName cls topOwner cg@1417: syntaxHilighting superclass category| cg@1417: cg@1417: UserPreferences isNil ifTrue:[ cg@1417: syntaxHilighting := false cg@1417: ] ifFalse:[ cg@1417: syntaxHilighting := UserPreferences current syntaxColoring. cg@1417: ]. cg@1417: cg@1417: owner := self owningClass. cg@1417: cg@1417: owner isNil ifTrue:[ cg@1417: ns := self nameSpace. cg@1417: ] ifFalse:[ cg@1417: ns := self topOwningClass nameSpace cg@1417: ]. cg@1417: fullName := Class fileOutNameSpaceQuerySignal query == true. cg@1417: cg@1417: (showPackage and:[owner isNil]) ifTrue:[ cg@1417: aStream nextPutAll:'"{ Package: '''. cg@1417: aStream nextPutAll:self package asString. cg@1417: aStream nextPutAll:''' }"'; cr; cr. cg@1417: ]. cg@1417: cg@1417: ((owner isNil and:[fullName not]) cg@1417: or:[owner notNil and:[forceNameSpace and:[fullName not]]]) ifTrue:[ cg@1417: (ns notNil and:[ns ~~ Smalltalk]) ifTrue:[ cg@1417: nsName := ns name. cg@1417: (nsName includes:$:) ifTrue:[ cg@1417: nsName := '''' , nsName , '''' cg@1417: ]. cg@1417: "/ aStream nextPutLine:'"{ NameSpace: ' , nsName , ' }"'; cr. cg@1417: aStream nextPutAll:'"{ NameSpace: '. cg@1417: syntaxHilighting ifTrue:[aStream bold]. cg@1417: aStream nextPutAll:nsName. cg@1417: syntaxHilighting ifTrue:[aStream normal]. cg@1417: aStream nextPutAll:' }"'; cr; cr. cg@1417: ] cg@1417: ]. cg@1417: cg@1419: superclass := self superclass. cg@1419: category := self category. cg@1419: cg@1417: "take care of nil-superclass" cg@1417: superclass isNil ifTrue:[ cg@1417: s := 'nil' cg@1417: ] ifFalse:[ cg@1417: fullName ifTrue:[ cg@1417: superclass == owner ifTrue:[ cg@1417: s := superclass nameWithoutNameSpacePrefix cg@1417: ] ifFalse:[ cg@1417: s := superclass name cg@1417: ] cg@1417: ] ifFalse:[ cg@1417: (ns == superclass nameSpace cg@1417: and:[superclass owningClass isNil]) ifTrue:[ cg@1417: "/ superclass is in the same namespace; cg@1417: "/ still prepend namespace prefix, to avoid cg@1417: "/ confusing stc, which needs that information ... cg@1417: s := superclass nameWithoutPrefix cg@1417: ] ifFalse:[ cg@1417: "/ a very special (rare) situation: cg@1417: "/ my superclass resides in another nameSpace, cg@1417: "/ but there is something else named like this cg@1417: "/ to be found in my nameSpace (or a private class) cg@1417: cg@1417: superName := superclass nameWithoutNameSpacePrefix asSymbol. cg@1417: cls := self privateClassesAt:superName. cg@1417: cls isNil ifTrue:[ cg@1417: (topOwner := self topOwningClass) isNil ifTrue:[ cg@1417: ns := self nameSpace. cg@1417: ns notNil ifTrue:[ cg@1417: cls := ns privateClassesAt:superName cg@1417: ] ifFalse:[ cg@1417: "/ self error:'unexpected nil namespace' cg@1417: ] cg@1417: ] ifFalse:[ cg@1417: cls := topOwner nameSpace at:superName. cg@1417: ] cg@1417: ]. cg@1417: (cls notNil and:[cls ~~ superclass]) ifTrue:[ cg@1417: s := superclass nameSpace name , '::' , superName cg@1417: ] ifFalse:[ cg@1417: "/ no class with that name found in my namespace ... cg@1417: "/ if the superclass resides in Smalltalk, cg@1417: "/ suppress prefix; otherwise, use full prefix. cg@1417: (superclass nameSpace notNil cg@1417: and:[superclass nameSpace ~~ Smalltalk]) ifTrue:[ cg@1417: (owner notNil cg@1417: and:[owner nameSpace == superclass owningClass nameSpace]) cg@1417: ifTrue:[ cg@1417: s := superclass nameWithoutNameSpacePrefix cg@1417: ] ifFalse:[ cg@1417: s := superclass name cg@1417: ] cg@1417: ] ifFalse:[ cg@1417: s := superName cg@1417: ] cg@1417: ] cg@1417: ] cg@1417: ] cg@1417: ]. cg@1417: cg@1417: syntaxHilighting ifTrue:[aStream bold]. cg@1417: aStream nextPutAll:s. "/ superclass cg@1417: syntaxHilighting ifTrue:[aStream normal]. cg@1417: aStream space. cg@1417: self basicFileOutInstvarTypeKeywordOn:aStream. cg@1417: cg@1417: (fullName and:[owner isNil]) ifTrue:[ cg@1417: aStream nextPutAll:'#'''. cg@1417: syntaxHilighting ifTrue:[aStream bold]. cg@1417: aStream nextPutAll:(self name). cg@1417: syntaxHilighting ifTrue:[aStream normal]. cg@1417: aStream nextPutAll:''''. cg@1417: ] ifFalse:[ cg@1417: aStream nextPut:$#. cg@1417: syntaxHilighting ifTrue:[aStream bold]. cg@1417: aStream nextPutAll:(self nameWithoutPrefix). cg@1417: syntaxHilighting ifTrue:[aStream normal]. cg@1417: ]. cg@1417: cg@1417: aStream crtab. cg@1417: aStream nextPutAll:'instanceVariableNames:'''. cg@1417: syntaxHilighting ifTrue:[aStream bold]. cg@1417: self printInstVarNamesOn:aStream indent:16. cg@1417: syntaxHilighting ifTrue:[aStream normal]. cg@1417: aStream nextPutAll:''''. cg@1417: cg@1417: aStream crtab. cg@1417: aStream nextPutAll:'classVariableNames:'''. cg@1417: syntaxHilighting ifTrue:[aStream bold]. cg@1417: self printClassVarNamesOn:aStream indent:16. cg@1417: syntaxHilighting ifTrue:[aStream normal]. cg@1417: aStream nextPutAll:''''. cg@1417: cg@1417: aStream crtab. cg@1417: aStream nextPutAll:'poolDictionaries:'''''. cg@1417: cg@1417: aStream crtab. cg@1417: owner isNil ifTrue:[ cg@1417: "/ a public class cg@1417: aStream nextPutAll:'category:'. cg@1417: category isNil ifTrue:[ cg@1417: s := '''''' cg@1417: ] ifFalse:[ cg@1417: s := category asString storeString cg@1417: ]. cg@1417: aStream nextPutAll:s. cg@1417: ] ifFalse:[ cg@1417: "/ a private class cg@1417: aStream nextPutAll:'privateIn:'. cg@1417: syntaxHilighting ifTrue:[aStream bold]. cg@1417: "/ fullName ifTrue:[ cg@1417: "/ s := owner name. cg@1417: "/ ] ifFalse:[ cg@1417: "/ s := owner nameWithoutNameSpacePrefix. cg@1417: "/ ]. cg@1417: s := owner nameWithoutNameSpacePrefix. cg@1417: aStream nextPutAll:s. cg@1417: syntaxHilighting ifTrue:[aStream normal]. cg@1417: ]. cg@1417: aStream cr cg@1417: cg@1417: "Created: / 4.1.1997 / 20:38:16 / cg" cg@1417: "Modified: / 8.8.1997 / 10:59:50 / cg" cg@1440: "Modified: / 18.3.1999 / 18:15:46 / stefan" cg@1440: ! cg@1417: cg@1417: basicFileOutInstvarTypeKeywordOn:aStream cg@1417: "a helper for fileOutDefinition" cg@1417: cg@1417: |isVar s superclass| cg@1417: cg@1417: superclass := self superclass. cg@1417: superclass isNil ifTrue:[ cg@1417: isVar := self isVariable cg@1417: ] ifFalse:[ cg@1417: "I cant remember what this is for ?" cg@1417: isVar := (self isVariable and:[superclass isVariable not]) cg@1417: ]. cg@1417: cg@1417: aStream nextPutAll:(self firstDefinitionSelectorPart). cg@1417: cg@1417: "Created: 11.10.1996 / 18:57:29 / cg" cg@1417: ! cg@1417: cg@1419: binaryRevision cg@1419: "return the revision-ID from which the class was stc-compiled; cg@1419: nil if its an autoloaded or filedIn class. cg@1419: If a classes binary is up-to-date w.r.t. the source repository, cg@1419: the returned string is the same as the one returned by #revision." cg@1419: cg@1419: |owner info c revision| cg@1419: cg@1419: revision := self revision. cg@1419: cg@1419: (owner := self owningClass) notNil ifTrue:[^ owner binaryRevision]. cg@1419: revision notNil ifTrue:[ cg@1419: c := revision first. cg@1419: c == $$ ifTrue:[ cg@1419: info := Class revisionInfoFromString:revision. cg@1419: info isNil ifTrue:[^ '0']. cg@1419: ^ info at:#revision ifAbsent:'0'. cg@1419: ]. cg@1419: c isDigit ifFalse:[ cg@1419: ^ '0' cg@1419: ]. cg@1419: ]. cg@1419: cg@1419: ^ revision cg@1419: cg@1419: " cg@1419: Object binaryRevision cg@1419: Object class binaryRevision cg@1419: " cg@1419: cg@1419: " cg@1419: to find all classes which are not up-to-date: cg@1419: cg@1419: |classes| cg@1419: cg@1419: classes := Smalltalk allClasses cg@1419: select:[:cls | cls binaryRevision notNil and:[cls binaryRevision ~= cls revision]]. cg@1419: SystemBrowser browseClasses:classes title:'classes which are not up-to-date' cg@1419: " cg@1419: cg@1419: "Created: 7.12.1995 / 10:58:47 / cg" cg@1419: "Modified: 1.4.1997 / 23:33:01 / stefan" cg@1440: "Modified: 9.9.1997 / 12:05:41 / cg" cg@1440: ! cg@1419: cg@1417: compiledMethodAt:aSelector cg@1417: cg@1417: ^ self compiledMethodAt:aSelector ifAbsent:nil cg@1417: ! cg@1417: cg@1417: compiledMethodAt:aSelector ifAbsent:exceptionValue cg@1417: |dict| cg@1417: cg@1417: dict := self methodDictionary. cg@1417: dict isNil ifTrue:[ cg@1417: ('Behavior [warning]: nil methodDictionary in ' , self name printString) errorPrintCR. cg@1417: ^ exceptionValue value cg@1417: ]. cg@1417: cg@1417: ^ dict at:aSelector ifAbsent:exceptionValue cg@1417: ! cg@1417: cg@1417: evaluatorClass cg@1417: ^ Object evaluatorClass cg@1417: ! cg@1417: cg@1419: fileOut cg@1419: |baseName dirName nm fileName| cg@1419: cg@1419: baseName := (Smalltalk fileNameForClass:self name). cg@1419: nm := baseName asFilename withSuffix:'st'. cg@1419: cg@1419: " cg@1419: this test allows a smalltalk to be built without Projects/ChangeSets cg@1419: " cg@1419: Project notNil ifTrue:[ cg@1419: dirName := Project currentProjectDirectory cg@1419: ] ifFalse:[ cg@1419: dirName := Filename currentDirectory cg@1419: ]. cg@1419: fileName := (dirName asFilename construct:nm). cg@1419: fileName makeLegalFilename. cg@1419: cg@1419: self fileOutAs:fileName name. cg@1419: cg@1419: "/ " cg@1419: "/ add a change record; that way, administration is much easier, cg@1419: "/ since we can see in that changeBrowser, which changes have cg@1419: "/ already found their way into a sourceFile and which must be cg@1419: "/ applied again cg@1419: "/ " cg@1419: "/ self addChangeRecordForClassFileOut:self cg@1419: cg@1419: "Modified: / 7.6.1996 / 09:14:43 / stefan" cg@1440: "Modified: / 27.8.1998 / 02:02:57 / cg" cg@1440: ! cg@1419: cg@1419: fileOutAllDefinitionsOn:aStream cg@1419: "append expressions on aStream, which defines myself and all of my private classes." cg@1419: cg@1419: self fileOutDefinitionOn:aStream. cg@1419: aStream nextPutChunkSeparator. cg@1419: aStream cr; cr. cg@1419: cg@1419: "/ cg@1419: "/ optional classInstanceVariables cg@1419: "/ cg@1419: self classRef instanceVariableString isBlank ifFalse:[ cg@1419: self fileOutClassInstVarDefinitionOn:aStream. cg@1419: aStream nextPutChunkSeparator. cg@1419: aStream cr; cr cg@1419: ]. cg@1419: cg@1419: "/ here, the full nameSpace prefixes are output, cg@1419: "/ to avoid confusing stc cg@1419: "/ (which otherwise could not find the correct superclass) cg@1419: "/ cg@1419: Class fileOutNameSpaceQuerySignal answer:true do:[ cg@1419: self privateClassesSorted do:[:aClass | cg@1419: aClass fileOutAllDefinitionsOn:aStream cg@1419: ] cg@1419: ]. cg@1419: cg@1419: "Created: 15.10.1996 / 11:15:19 / cg" cg@1440: "Modified: 22.3.1997 / 16:11:56 / cg" cg@1440: ! cg@1419: cg@1791: fileOutAllMethodsOn:aStream methodFilter:methodFilter cg@1791: |collectionOfCategories| cg@1791: cg@1792: collectionOfCategories := self theMetaclass categories asSortedCollection. cg@1791: collectionOfCategories notNil ifTrue:[ cg@1791: collectionOfCategories do:[:aCategory | cg@1792: self theMetaclass fileOutCategory:aCategory methodFilter:methodFilter on:aStream. cg@1791: aStream cr cg@1791: ] cg@1791: ]. cg@1791: collectionOfCategories := self categories asSortedCollection. cg@1791: collectionOfCategories notNil ifTrue:[ cg@1791: collectionOfCategories do:[:aCategory | cg@1791: self fileOutCategory:aCategory methodFilter:methodFilter on:aStream. cg@1791: aStream cr cg@1791: ] cg@1791: ]. cg@1791: cg@1791: self privateClassesSorted do:[:aClass | cg@1791: aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter cg@1791: ]. cg@1791: ! cg@1791: cg@1419: fileOutAs:fileNameString cg@1419: "create a file consisting of all methods in myself in cg@1419: sourceForm, from which the class can be reconstructed (by filing in). cg@1419: The given fileName should be a full path, including suffix. cg@1419: Care is taken, to not clobber any existing file in cg@1419: case of errors (for example: disk full). cg@1419: Also, since the classes methods need a valid sourcefile, the current cg@1419: sourceFile may not be rewritten." cg@1419: cg@1419: |aStream fileName newFileName savFilename needRename cg@1419: mySourceFileName sameFile s mySourceFileID anySourceRef| cg@1419: cg@1419: self isLoaded ifFalse:[ cg@1419: ^ Class fileOutErrorSignal cg@1419: raiseRequestWith:self cg@1419: errorString:'will not fileOut unloaded classes' cg@1419: ]. cg@1419: cg@1419: fileName := fileNameString asFilename. cg@1419: cg@1419: " cg@1419: if file exists, copy the existing to a .sav-file, cg@1419: create the new file as XXX.new-file, cg@1419: and, if that worked rename afterwards ... cg@1419: " cg@1419: (fileName exists) ifTrue:[ cg@1419: sameFile := false. cg@1419: cg@1419: "/ check carefully - maybe, my source does not really come from that cg@1419: "/ file (i.e. all of my methods have their source as string) cg@1419: cg@1419: anySourceRef := false. cg@1419: self methodDictionary do:[:m| cg@1419: m sourcePosition notNil ifTrue:[ cg@1419: anySourceRef := true cg@1419: ] cg@1419: ]. cg@1419: self classRef methodDictionary do:[:m| cg@1419: m sourcePosition notNil ifTrue:[ cg@1419: anySourceRef := true cg@1419: ] cg@1419: ]. cg@1419: cg@1419: anySourceRef ifTrue:[ cg@1419: s := self sourceStream. cg@1419: s notNil ifTrue:[ cg@1419: mySourceFileID := s pathName asFilename info id. cg@1419: sameFile := (fileName info id) == mySourceFileID. cg@1419: s close. cg@1419: ] ifFalse:[ cg@1419: self classFilename notNil ifTrue:[ cg@1419: " cg@1419: check for overwriting my current source file cg@1419: this is not allowed, since it would clobber my methods source cg@1419: file ... you have to save it to some other place. cg@1419: This happens if you ask for a fileOut into the source-directory cg@1419: (from which my methods get their source) cg@1419: " cg@1419: mySourceFileName := Smalltalk getSourceFileName:self classFilename. cg@1419: sameFile := (fileNameString = mySourceFileName). cg@1419: sameFile ifFalse:[ cg@1419: mySourceFileName notNil ifTrue:[ cg@1419: sameFile := (fileName info id) == (mySourceFileName asFilename info id) cg@1419: ] cg@1419: ]. cg@1419: ] cg@1419: ]. cg@1419: ]. cg@1419: cg@1419: sameFile ifTrue:[ cg@1419: ^ Class fileOutErrorSignal cg@1419: raiseRequestWith:fileNameString cg@1419: errorString:('may not overwrite sourcefile:', fileNameString) cg@1419: ]. cg@1419: cg@1419: savFilename := Filename newTemporary. cg@1419: fileName copyTo:savFilename. cg@1419: newFileName := fileName withSuffix:'new'. cg@1419: needRename := true cg@1419: ] ifFalse:[ cg@1419: "/ another possible trap: if my sourceFileName is cg@1419: "/ the same as the written one AND the new files directory cg@1419: "/ is along the sourcePath, we also need a temporary file cg@1419: "/ first, to avoid accessing the newly written file. cg@1419: cg@1419: anySourceRef := false. cg@1419: self methodDictionary do:[:m| cg@1419: |mSrc| cg@1419: cg@1419: (mSrc := m sourceFilename) notNil ifTrue:[ cg@1419: mSrc asFilename baseName = fileName baseName ifTrue:[ cg@1419: anySourceRef := true cg@1419: ] cg@1419: ] cg@1419: ]. cg@1419: self classRef methodDictionary do:[:m| cg@1419: |mSrc| cg@1419: cg@1419: (mSrc := m sourceFilename) notNil ifTrue:[ cg@1419: mSrc asFilename baseName = fileName baseName ifTrue:[ cg@1419: anySourceRef := true cg@1419: ] cg@1419: ] cg@1419: ]. cg@1419: anySourceRef ifTrue:[ cg@1419: newFileName := fileName withSuffix:'new'. cg@1419: needRename := true cg@1419: ] ifFalse:[ cg@1419: newFileName := fileName. cg@1419: needRename := false cg@1419: ] cg@1419: ]. cg@1419: cg@1419: aStream := newFileName writeStream. cg@1419: aStream isNil ifTrue:[ cg@1419: savFilename notNil ifTrue:[ cg@1419: savFilename delete cg@1419: ]. cg@1419: ^ Class fileOutErrorSignal cg@1419: raiseRequestWith:newFileName cg@1419: errorString:('cannot create file:', newFileName name) cg@1419: ]. cg@1419: self fileOutOn:aStream. cg@1419: aStream close. cg@1419: cg@1419: " cg@1419: finally, replace the old-file cg@1419: be careful, if the old one is a symbolic link; in this case, cg@1419: we have to do a copy ... cg@1419: " cg@1419: needRename ifTrue:[ cg@1419: newFileName copyTo:fileName. cg@1419: newFileName delete cg@1419: ]. cg@1419: savFilename notNil ifTrue:[ cg@1419: savFilename delete cg@1419: ]. cg@1419: cg@1419: " cg@1419: add a change record; that way, administration is much easier, cg@1419: since we can see in that changeBrowser, which changes have cg@1419: already found their way into a sourceFile and which must be cg@1419: applied again cg@1419: " cg@1419: self addChangeRecordForClassFileOut:self cg@1419: cg@1419: "Modified: / 7.6.1996 / 09:14:43 / stefan" cg@1419: "Created: / 16.4.1997 / 20:44:05 / cg" cg@1440: "Modified: / 12.8.1998 / 11:14:56 / cg" cg@1440: ! cg@1419: cg@1419: fileOutCategory:aCategory cg@1419: "create a file 'class-category.st' consisting of all methods in aCategory. cg@1419: If the current project is not nil, create the file in the projects cg@1419: directory." cg@1419: cg@1419: |aStream fileName| cg@1419: cg@1419: fileName := (self name , '-' , aCategory , '.st') asFilename. cg@1419: fileName makeLegalFilename. cg@1419: cg@1419: "/ cg@1419: "/ this test allows a smalltalk to be built without Projects/ChangeSets cg@1419: "/ cg@1419: Project notNil ifTrue:[ cg@1419: fileName := Project currentProjectDirectory asFilename construct:(fileName name). cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ if the file exists, save original in a .sav file cg@1419: "/ cg@1419: fileName exists ifTrue:[ cg@1419: fileName copyTo:(fileName withSuffix:'sav') cg@1419: ]. cg@1419: aStream := FileStream newFileNamed:fileName. cg@1419: aStream isNil ifTrue:[ cg@1419: ^ Class fileOutErrorSignal cg@1419: raiseRequestWith:fileName cg@1419: errorString:('cannot create file:', fileName pathName) cg@1419: ]. cg@1419: cg@1419: self fileOutCategory:aCategory on:aStream. cg@1419: aStream close cg@1419: cg@1419: "Modified: / 1.4.1997 / 16:00:24 / stefan" cg@1419: "Created: / 1.4.1997 / 16:04:18 / stefan" cg@1440: "Modified: / 28.10.1997 / 14:40:28 / cg" cg@1440: ! cg@1419: cg@1419: fileOutCategory:aCategory except:skippedMethods only:savedMethods methodFilter:methodFilter on:aStream cg@1419: |dict source sortedSelectors first privacy interestingMethods cat| cg@1419: cg@1419: dict := self methodDictionary. cg@1419: dict notNil ifTrue:[ cg@1419: interestingMethods := OrderedCollection new. cg@1419: dict do:[:aMethod | cg@1419: |wanted| cg@1419: cg@1419: (methodFilter isNil cg@1419: or:[methodFilter value:aMethod]) ifTrue:[ cg@1419: (aCategory = aMethod category) ifTrue:[ cg@1419: skippedMethods notNil ifTrue:[ cg@1419: wanted := (skippedMethods includesIdentical:aMethod) not cg@1419: ] ifFalse:[ cg@1419: savedMethods notNil ifTrue:[ cg@1419: wanted := (savedMethods includesIdentical:aMethod). cg@1419: ] ifFalse:[ cg@1419: wanted := true cg@1419: ] cg@1419: ]. cg@1419: wanted ifTrue:[interestingMethods add:aMethod]. cg@1419: ] cg@1419: ] cg@1419: ]. cg@1419: interestingMethods notEmpty ifTrue:[ cg@1419: first := true. cg@1419: privacy := nil. cg@1419: cg@1419: "/ cg@1419: "/ sort by selector cg@1419: "/ cg@1419: sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m]. cg@1419: sortedSelectors sortWith:interestingMethods. cg@1419: cg@1419: interestingMethods do:[:aMethod | cg@1419: first ifFalse:[ cg@1419: privacy ~~ aMethod privacy ifTrue:[ cg@1419: first := true. cg@1419: aStream space. cg@1419: aStream nextPutChunkSeparator. cg@1419: ]. cg@1419: aStream cr; cr cg@1419: ]. cg@1419: cg@1419: privacy := aMethod privacy. cg@1419: cg@1419: first ifTrue:[ cg@1419: aStream nextPutChunkSeparator. cg@1419: self printClassNameOn:aStream. cg@1419: privacy ~~ #public ifTrue:[ cg@1419: aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'. cg@1419: ] ifFalse:[ cg@1419: aStream nextPutAll:' methodsFor:'. cg@1419: ]. cg@1419: cat := aCategory. cg@1419: cat isNil ifTrue:[ cat := '' ]. cg@1419: aStream nextPutAll:aCategory asString storeString. cg@1419: aStream nextPutChunkSeparator; cr; cr. cg@1419: first := false. cg@1419: ]. cg@1419: source := aMethod source. cg@1419: source isNil ifTrue:[ cg@1419: Class fileOutErrorSignal cg@1419: raiseRequestWith:self cg@1419: errorString:'no source for method: ', (aMethod displayString) cg@1419: ] ifFalse:[ cg@1419: aStream nextChunkPut:source. cg@1419: ]. cg@1419: ]. cg@1419: aStream space. cg@1419: aStream nextPutChunkSeparator. cg@1419: aStream cr cg@1419: ] cg@1419: ] cg@1419: cg@1419: "Modified: 28.8.1995 / 14:30:41 / claus" cg@1419: "Modified: 12.6.1996 / 11:37:33 / stefan" cg@1419: "Modified: 15.11.1996 / 11:32:21 / cg" cg@1440: "Created: 1.4.1997 / 16:04:33 / stefan" cg@1440: ! cg@1419: cg@1419: fileOutCategory:aCategory methodFilter:methodFilter on:aStream cg@1419: "file out all methods belonging to aCategory, aString onto aStream" cg@1419: cg@1440: self fileOutCategory:aCategory except:nil only:nil methodFilter:methodFilter on:aStream cg@1440: ! cg@1419: cg@1419: fileOutCategory:aCategory on:aStream cg@1419: Class fileOutNameSpaceQuerySignal answer:true do:[ cg@1419: self fileOutCategory:aCategory except:nil only:nil methodFilter:nil on:aStream cg@1440: ] cg@1440: ! cg@1419: cg@1419: fileOutClassInstVarDefinitionOn:aStream withNameSpace:withNameSpace cg@1419: "append an expression to define my classInstanceVariables on aStream" cg@1419: cg@1419: |anySuperClassInstVar| cg@1419: cg@1419: self isLoaded ifFalse:[ cg@1419: ^ self basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace cg@1419: ]. cg@1419: cg@1419: withNameSpace ifTrue:[ cg@1419: self name printOn:aStream. cg@1419: ] ifFalse:[ cg@1419: self printClassNameOn:aStream. cg@1419: ]. cg@1419: aStream nextPutAll:' class instanceVariableNames:'''. cg@1482: self theMetaclass printInstVarNamesOn:aStream indent:8. cg@1419: aStream nextPutAll:''''. cg@1419: cg@1419: "mhmh - good idea; saw this in SmallDraw sourcecode ..." cg@1419: cg@1419: anySuperClassInstVar := false. cg@1419: self allSuperclassesDo:[:aSuperClass | cg@1482: aSuperClass theMetaclass instVarNames do:[:ignored | anySuperClassInstVar := true]. cg@1419: ]. cg@1419: cg@1419: aStream cr; cr; nextPut:(Character doubleQuote); cr; space. cg@1419: anySuperClassInstVar ifFalse:[ cg@1419: aStream cg@1419: nextPutLine:'No other class instance variables are inherited by this class.'. cg@1419: ] ifTrue:[ cg@1419: aStream cg@1419: nextPutLine:'The following class instance variables are inherited by this class:'. cg@1419: aStream cr. cg@1419: self allSuperclassesDo:[:aSuperClass | cg@1419: aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '. cg@1482: aStream nextPutLine:(aSuperClass theMetaclass instanceVariableString). cg@1419: ]. cg@1419: cg@1419: ]. cg@1419: aStream nextPut:(Character doubleQuote); cr. cg@1419: cg@1419: "Created: / 10.12.1995 / 16:31:25 / cg" cg@1419: "Modified: / 1.4.1997 / 16:00:33 / stefan" cg@1419: "Modified: / 3.2.2000 / 23:05:28 / cg" cg@1419: ! cg@1419: cg@1864: fileOutCommentOn:aStream cg@1864: "append an expression on aStream, which defines my comment" cg@1864: cg@1864: |comment s| cg@1864: cg@1864: self printClassNameOn:aStream. cg@1864: aStream nextPutAll:' comment:'. cg@1864: (comment := self comment) isNil ifTrue:[ cg@1864: s := '''''' cg@1864: ] ifFalse:[ cg@1864: s := comment storeString cg@1864: ]. cg@1864: aStream nextPutAllAsChunk:s. cg@1864: aStream nextPutChunkSeparator. cg@1864: aStream cr cg@1864: ! cg@1864: cg@1419: fileOutDefinitionOn:aStream cg@1419: "append an expression on aStream, which defines myself." cg@1419: cg@1440: ^ self basicFileOutDefinitionOn:aStream withNameSpace:false cg@1440: ! cg@1419: cg@1419: fileOutMethod:aMethod cg@1419: |aStream fileName selector| cg@1419: cg@1419: selector := self selectorAtMethod:aMethod. cg@1419: selector notNil ifTrue:[ cg@1419: fileName := (self name , '-' , selector, '.st') asFilename. cg@1419: fileName makeLegalFilename. cg@1419: cg@1419: " cg@1419: this test allows a smalltalk to be built without Projects/ChangeSets cg@1419: " cg@1419: Project notNil ifTrue:[ cg@1419: fileName := Project currentProjectDirectory asFilename construct:fileName name. cg@1419: ]. cg@1419: cg@1419: " cg@1419: if file exists, save original in a .sav file cg@1419: " cg@1419: fileName exists ifTrue:[ cg@1419: fileName copyTo:(fileName withSuffix: 'sav') cg@1419: ]. cg@1419: cg@1419: fileName := fileName name. cg@1419: cg@1419: aStream := FileStream newFileNamed:fileName. cg@1419: aStream isNil ifTrue:[ cg@1419: ^ Class fileOutErrorSignal cg@1419: raiseRequestWith:fileName cg@1419: errorString:('cannot create file:', fileName) cg@1419: ]. cg@1419: self fileOutMethod:aMethod on:aStream. cg@1419: aStream close cg@1419: ] cg@1419: cg@1419: "Modified: / 1.4.1997 / 16:00:57 / stefan" cg@1419: "Created: / 2.4.1997 / 00:24:28 / stefan" cg@1440: "Modified: / 28.10.1997 / 14:40:34 / cg" cg@1440: ! cg@1419: cg@1419: fileOutMethod:aMethod on:aStream cg@1419: |dict cat source privacy| cg@1419: cg@1419: dict := self methodDictionary. cg@1419: dict notNil ifTrue:[ cg@1419: aStream nextPutChunkSeparator. cg@1419: self name printOn:aStream. cg@1419: "/ self printClassNameOn:aStream. cg@1419: cg@1419: (privacy := aMethod privacy) ~~ #public ifTrue:[ cg@1419: aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'. cg@1419: ] ifFalse:[ cg@1419: aStream nextPutAll:' methodsFor:'. cg@1419: ]. cg@1419: cat := aMethod category. cg@1419: cat isNil ifTrue:[ cg@1419: cat := '' cg@1419: ]. cg@1419: aStream nextPutAll:cat asString storeString. cg@1419: aStream nextPutChunkSeparator; cr; cr. cg@1419: source := aMethod source. cg@1419: source isNil ifTrue:[ cg@1419: Class fileOutErrorSignal cg@1419: raiseRequestWith:self cg@1419: errorString:('no source for method: ' , cg@1419: self name , '>>' , cg@1419: (self selectorAtMethod:aMethod)) cg@1419: ] ifFalse:[ cg@1419: aStream nextChunkPut:source. cg@1419: ]. cg@1419: aStream space. cg@1419: aStream nextPutChunkSeparator. cg@1419: aStream cr cg@1419: ] cg@1419: cg@1419: "Modified: 27.8.1995 / 01:23:19 / claus" cg@1419: "Modified: 12.6.1996 / 11:44:41 / stefan" cg@1419: "Modified: 15.11.1996 / 11:32:43 / cg" cg@1440: "Created: 2.4.1997 / 00:24:33 / stefan" cg@1440: ! cg@1419: cg@1419: fileOutOn:aStream cg@1419: cg@1440: ^ self fileOutOn:aStream withTimeStamp:true cg@1440: ! cg@1419: cg@1419: fileOutOn:aStream withTimeStamp:stampIt cg@1419: "file out my definition and all methods onto aStream. cg@1419: If stampIt is true, a timeStamp comment is prepended." cg@1419: cg@1440: self fileOutOn:aStream withTimeStamp:stampIt withInitialize:true cg@1440: ! cg@1419: cg@1419: fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt cg@1419: "file out my definition and all methods onto aStream. cg@1419: If stampIt is true, a timeStamp comment is prepended. cg@1419: If initIt is true, and the class implements a class-initialize method, cg@1419: append a corresponding doIt expression for initialization." cg@1419: cg@1419: self cg@1419: fileOutOn:aStream cg@1419: withTimeStamp:stampIt cg@1419: withInitialize:initIt cg@1419: withDefinition:true cg@1440: methodFilter:nil cg@1440: ! cg@1419: cg@1419: fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter cg@1419: "file out my definition and all methods onto aStream. cg@1419: If stampIt is true, a timeStamp comment is prepended. cg@1419: If initIt is true, and the class implements a class-initialize method, cg@1419: append a corresponding doIt expression for initialization. cg@1419: The order by which the fileOut is done is used to put the version string at the end. cg@1419: Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move" cg@1419: cg@1419: |collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods cg@1419: meta| cg@1419: cg@1419: self isLoaded ifFalse:[ cg@1419: ^ Class fileOutErrorSignal cg@1419: raiseRequestWith:self cg@1419: errorString:'will not fileOut unloaded classes' cg@1419: ]. cg@1419: cg@1419: meta := self classRef. cg@1419: cg@1419: " cg@1419: if there is a copyright method, add a copyright comment cg@1419: at the beginning, taking the string from the copyright method. cg@1419: We cannot do this unconditionally - that would lead to my copyrights cg@1419: being put on your code ;-). cg@1419: On the other hand: I want every file created by myself to have the cg@1419: copyright string at the beginning be preserved .... even if the cg@1419: code was edited in the browser and filedOut. cg@1419: " cg@1419: (copyrightMethod := meta compiledMethodAt:#copyright) notNil ifTrue:[ cg@1419: " cg@1419: get the copyright methods source, cg@1419: and insert at beginning. cg@1419: " cg@1419: copyrightText := copyrightMethod source. cg@1419: copyrightText isNil ifTrue:[ cg@1419: " cg@1419: no source available - trigger an error cg@1419: " cg@1419: Class fileOutErrorSignal cg@1419: raiseRequestWith:'no source for class ' , self name , ' available. Cannot fileOut'. cg@1419: ^ self cg@1419: ]. cg@1419: " cg@1419: strip off the selector-line cg@1419: " cg@1419: copyrightText := copyrightText asCollectionOfLines asStringCollection. cg@1419: copyrightText := copyrightText copyFrom:2 to:(copyrightText size). cg@1419: "/ copyrightText do:[:line | aStream nextPutAll:line. aStream cr.]. cg@1419: copyrightText := copyrightText asString. cg@1419: aStream nextPutAllAsChunk:copyrightText. cg@1419: ]. cg@1419: cg@1419: stampIt ifTrue:[ cg@1419: "/ cg@1419: "/ first, a timestamp cg@1419: "/ cg@1419: aStream nextPutAll:(Smalltalk timeStamp). cg@1419: aStream nextPutChunkSeparator. cg@1419: aStream cr; cr. cg@1419: ]. cg@1419: cg@1419: withDefinition ifTrue:[ cg@1419: "/ cg@1419: "/ then the definition cg@1419: "/ cg@1419: self fileOutAllDefinitionsOn:aStream. cg@1419: "/ cg@1419: "/ a comment - if any cg@1419: "/ cg@1419: (comment := self comment) notNil ifTrue:[ cg@1419: self fileOutCommentOn:aStream. cg@1419: aStream cr. cg@1419: ]. cg@1419: "/ cg@1419: "/ primitive definitions - if any cg@1419: "/ cg@1419: self fileOutPrimitiveSpecsOn:aStream. cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ methods from all categories in metaclass (i.e. class methods) cg@1419: "/ EXCEPT: the version method is placed at the very end, to cg@1419: "/ avoid sourcePosition-shifts when checked out later. cg@1419: "/ (RCS expands this string, so its size is not constant) cg@1419: "/ cg@1419: collectionOfCategories := meta categories asSortedCollection. cg@1419: collectionOfCategories notNil ifTrue:[ cg@1419: "/ cg@1419: "/ documentation first (if any), but not the version method cg@1419: "/ cg@1419: (collectionOfCategories includes:'documentation') ifTrue:[ cg@1419: versionMethod := meta compiledMethodAt:#version. cg@1419: versionMethod notNil ifTrue:[ cg@1419: skippedMethods := Array with:versionMethod cg@1419: ]. cg@1419: meta fileOutCategory:'documentation' except:skippedMethods only:nil methodFilter:methodFilter on:aStream. cg@1419: aStream cr. cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ initialization next (if any) cg@1419: "/ cg@1419: (collectionOfCategories includes:'initialization') ifTrue:[ cg@1419: meta fileOutCategory:'initialization' methodFilter:methodFilter on:aStream. cg@1419: aStream cr. cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ instance creation next (if any) cg@1419: "/ cg@1419: (collectionOfCategories includes:'instance creation') ifTrue:[ cg@1419: meta fileOutCategory:'instance creation' methodFilter:methodFilter on:aStream. cg@1419: aStream cr. cg@1419: ]. cg@1419: collectionOfCategories do:[:aCategory | cg@1419: ((aCategory ~= 'documentation') cg@1419: and:[(aCategory ~= 'initialization') cg@1419: and:[aCategory ~= 'instance creation']]) ifTrue:[ cg@1419: meta fileOutCategory:aCategory methodFilter:methodFilter on:aStream. cg@1419: aStream cr cg@1419: ] cg@1419: ] cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ methods from all categories in myself cg@1419: "/ cg@1419: collectionOfCategories := self categories asSortedCollection. cg@1419: collectionOfCategories notNil ifTrue:[ cg@1419: collectionOfCategories do:[:aCategory | cg@1419: self fileOutCategory:aCategory methodFilter:methodFilter on:aStream. cg@1419: aStream cr cg@1419: ] cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ any private classes' methods cg@1419: "/ cg@1419: self privateClassesSorted do:[:aClass | cg@1419: aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter cg@1419: ]. cg@1419: cg@1419: cg@1419: "/ cg@1419: "/ finally, the previously skipped version method cg@1419: "/ cg@1419: versionMethod notNil ifTrue:[ cg@1419: meta fileOutCategory:'documentation' except:nil only:skippedMethods methodFilter:methodFilter on:aStream. cg@1419: ]. cg@1419: cg@1419: initIt ifTrue:[ cg@1419: "/ cg@1419: "/ optionally an initialize message cg@1419: "/ cg@1419: (meta implements:#initialize) ifTrue:[ cg@1419: self printClassNameOn:aStream. aStream nextPutAll:' initialize'. cg@1419: aStream nextPutChunkSeparator. cg@1419: aStream cr cg@1419: ] cg@1419: ] cg@1419: cg@1419: "Created: / 15.11.1995 / 12:53:06 / cg" cg@1419: "Modified: / 1.4.1997 / 16:01:05 / stefan" cg@1440: "Modified: / 13.3.1998 / 12:23:59 / cg" cg@1440: ! cg@1419: cg@1419: fileOutPrimitiveDefinitionsOn:aStream cg@1419: "append primitive defs (if any) to aStream." cg@1419: cg@1419: |s| cg@1419: cg@1419: " cg@1419: primitive definitions - if any cg@1419: " cg@1419: (s := self primitiveDefinitionsString) notNil ifTrue:[ cg@1419: aStream nextPutChunkSeparator. cg@1419: self printClassNameOn:aStream. cg@1419: aStream nextPutAll:' primitiveDefinitions'; cg@1419: nextPutChunkSeparator; cg@1419: cr. cg@1419: aStream nextPutAll:s. cg@1419: aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr cg@1419: ]. cg@1419: (s := self primitiveVariablesString) notNil ifTrue:[ cg@1419: aStream nextPutChunkSeparator. cg@1419: self printClassNameOn:aStream. cg@1419: aStream nextPutAll:' primitiveVariables'; cg@1419: nextPutChunkSeparator; cg@1419: cr. cg@1419: aStream nextPutAll:s. cg@1419: aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr cg@1419: ]. cg@1419: cg@1440: "Modified: 8.1.1997 / 17:45:40 / cg" cg@1440: ! cg@1419: cg@1419: fileOutPrimitiveSpecsOn:aStream cg@1419: "append primitive defs (if any) to aStream." cg@1419: cg@1419: |s| cg@1419: cg@1419: " cg@1419: primitive definitions - if any cg@1419: " cg@1419: self fileOutPrimitiveDefinitionsOn:aStream. cg@1419: " cg@1419: primitive functions - if any cg@1419: " cg@1419: (s := self primitiveFunctionsString) notNil ifTrue:[ cg@1419: aStream nextPutChunkSeparator. cg@1419: self printClassNameOn:aStream. cg@1419: aStream nextPutAll:' primitiveFunctions'; cg@1419: nextPutChunkSeparator; cg@1419: cr. cg@1419: aStream nextPutAll:s. cg@1419: aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr cg@1419: ]. cg@1419: cg@1440: "Modified: 8.1.1997 / 17:45:51 / cg" cg@1440: ! cg@1419: cg@1417: firstDefinitionSelectorPart cg@1417: "return the first part of the selector with which I was (can be) defined in my superclass" cg@1417: cg@1417: self isVariable ifFalse:[ cg@1417: ^ #'subclass:' cg@1417: ]. cg@1417: self isBytes ifTrue:[ cg@1417: ^ #'variableByteSubclass:' cg@1417: ]. cg@1417: self isLongs ifTrue:[ cg@1417: ^ #'variableLongSubclass:' cg@1417: ]. cg@1417: self isFloats ifTrue:[ cg@1417: ^ #'variableFloatSubclass:' cg@1417: ]. cg@1417: self isDoubles ifTrue:[ cg@1417: ^ #'variableDoubleSubclass:' cg@1417: ]. cg@1417: self isWords ifTrue:[ cg@1417: ^ #'variableWordSubclass:' cg@1417: ]. cg@1417: self isSignedWords ifTrue:[ cg@1417: ^ #'variableSignedWordSubclass:' cg@1417: ]. cg@1417: self isSignedLongs ifTrue:[ cg@1417: ^ #'variableSignedLongSubclass:' cg@1417: ]. cg@1417: self isSignedLongLongs ifTrue:[ cg@1417: ^ #'variableSignedLongLongSubclass:' cg@1417: ]. cg@1417: self isLongLongs ifTrue:[ cg@1417: ^ #'variableLongLongSubclass:' cg@1417: ]. cg@1417: ^ #'variableSubclass:' cg@1417: ! cg@1417: cg@1419: getPrimitiveSpecsAt:index cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return a primitiveSpecification component as string or nil" cg@1419: cg@1419: |owner pos stream string primitiveSpec classFilename| cg@1419: cg@1419: (owner := self owningClass) notNil ifTrue:[^ owner getPrimitiveSpecsAt:index]. cg@1419: cg@1419: primitiveSpec := self primitiveSpec. cg@1419: cg@1419: primitiveSpec isNil ifTrue:[^ nil]. cg@1419: pos := primitiveSpec at:index. cg@1419: pos isNil ifTrue:[^ nil]. cg@1419: cg@1419: "the primitiveSpec is either a string, or an integer specifying the cg@1419: position within the classes sourcefile ... cg@1419: " cg@1419: pos isNumber ifTrue:[ cg@1419: classFilename := self classFilename. cg@1419: classFilename notNil ifTrue:[ cg@1419: stream := self sourceStream. cg@1419: stream notNil ifTrue:[ cg@1419: stream position:pos+1. cg@1419: string := stream nextChunk. cg@1419: stream close. cg@1419: ^ string cg@1419: ] cg@1419: ]. cg@1419: ^ nil cg@1419: ]. cg@1419: ^ pos cg@1419: cg@1440: "Modified: 15.1.1997 / 15:29:30 / stefan" cg@1440: ! cg@1419: cg@1419: hasMethods cg@1419: "return true, if there are any (local) methods in this class" cg@1419: cg@1440: ^ (self methodDictionary size ~~ 0) cg@1440: ! cg@1419: cg@1419: implements:aSelector cg@1440: ^ self includesSelector:aSelector cg@1440: ! cg@1419: cg@1419: includesSelector:aSelector cg@1440: ^ self methodDictionary includesKey:aSelector cg@1440: ! cg@1419: cg@1419: instanceVariableString cg@1419: "return a string of the instance variable names" cg@1419: cg@1419: |instvars| cg@1419: cg@1419: instvars := self instVarNames. cg@1419: instvars isNil ifTrue:[^ '']. cg@1419: instvars isString ifTrue:[ cg@1419: ^ instvars cg@1419: ]. cg@1419: cg@1419: ^ instvars asStringWith:(Character space) cg@1419: cg@1419: " cg@1419: Point instanceVariableString cg@1419: " cg@1419: cg@1419: "Modified: 22.8.1997 / 14:59:14 / cg" cg@1419: ! cg@1419: cg@1482: isObsolete cg@1482: "return true, if the receiver is obsolete cg@1482: (i.e. has been replaced by a different class or was removed, cg@1482: but is still referenced by instanced)" cg@1482: cg@1482: |cat| cg@1482: cg@1482: cat := self category. cg@1482: cg@1482: ^ cat = 'obsolete' cg@1482: or:[cat = 'removed' cg@1482: or:[cat = '* removed *' cg@1482: or:[cat = '* obsolete *']]] cg@1419: ! cg@1419: cg@1419: isSubclassOf:aClass cg@1419: "return true, if I am a subclass of the argument, aClass" cg@1419: cg@1419: |theClass| cg@1419: cg@1419: theClass := self superclass. cg@1419: [theClass notNil] whileTrue:[ cg@1419: (theClass == aClass) ifTrue:[^ true]. cg@1419: theClass := theClass superclass. cg@1419: ]. cg@1419: ^ false cg@1419: ! cg@1419: cg@1440: localSourceStreamFor:sourceFile cg@1440: "return an open stream on a local sourcefile, nil if that is not available" cg@1440: cg@1440: |fileName info module dir fn package packageDir zar entry| cg@1440: cg@1440: "/ cg@1440: "/ old: look in 'source/' cg@1440: "/ this is still kept in order to find user-private cg@1440: "/ classes in her currentDirectory. cg@1440: "/ cg@1440: fileName := Smalltalk getSourceFileName:sourceFile. cg@1440: fileName notNil ifTrue:[ cg@1440: ^ fileName asFilename readStream. cg@1440: ]. cg@1440: cg@1440: (package := self package) notNil ifTrue:[ cg@1440: "/ newest sceme ... cg@1440: packageDir := package copyReplaceAll:$: with:$/. cg@1440: packageDir := Smalltalk getPackageFileName:packageDir. cg@1440: packageDir notNil ifTrue:[ cg@1440: "/ present there ? cg@1440: packageDir := packageDir asFilename. cg@1440: (fn := packageDir construct:sourceFile) exists ifTrue:[ cg@1440: ^ fn readStream. cg@1440: ]. cg@1440: cg@1440: "/ a source subdirectory ? cg@1440: fn := (packageDir construct:'source') construct:sourceFile. cg@1440: fn exists ifTrue:[ cg@1440: ^ fn readStream. cg@1440: ]. cg@1440: cg@1440: "/ a zip-file ? cg@1440: fn := (packageDir construct:'source.zip'). cg@1440: fn exists ifTrue:[ cg@1440: zar := ZipArchive oldFileNamed:fn. cg@1440: zar notNil ifTrue:[ cg@1440: entry := zar extract:sourceFile. cg@1440: entry notNil ifTrue:[ cg@1440: ^ entry asString readStream cg@1440: ] cg@1440: ] cg@1440: ] cg@1440: ]. cg@1440: cg@1440: "/ will vanish ... cg@1440: (package includes:$:) ifTrue:[ cg@1440: package := package asString copyReplaceAll:$: with:$/ cg@1440: ] ifFalse:[ cg@1440: package := 'stx/' , package cg@1440: ]. cg@1440: fileName := Smalltalk getSourceFileName:(package , '/' , sourceFile). cg@1440: fileName notNil ifTrue:[ cg@1440: ^ fileName asFilename readStream. cg@1440: ]. cg@1440: (package startsWith:'stx/') ifTrue:[ cg@1440: fileName := Smalltalk getSourceFileName:((package copyFrom:5) , '/' , sourceFile). cg@1440: fileName notNil ifTrue:[ cg@1440: ^ fileName asFilename readStream. cg@1440: ] cg@1440: ] cg@1440: ]. cg@1440: cg@1440: "/ cg@1440: "/ new: look in 'source/// cg@1440: "/ this makes the symbolic links to (or copy of) the source files cg@1440: "/ obsolete. cg@1440: info := self packageSourceCodeInfo. cg@1440: info notNil ifTrue:[ cg@1440: module := info at:#module ifAbsent:nil. cg@1440: module notNil ifTrue:[ cg@1440: dir := info at:#directory ifAbsent:nil. cg@1440: dir notNil ifTrue:[ cg@1440: fn := (module asFilename construct:dir) construct:sourceFile. cg@1440: fileName := Smalltalk getSourceFileName:(fn name). cg@1440: fileName notNil ifTrue:[ cg@1440: ^ fileName asFilename readStream. cg@1440: ]. cg@1440: cg@1440: "/ brand new: look for source//package.zip cg@1440: "/ containing an entry for cg@1440: cg@1440: fn := (module asFilename construct:dir) withSuffix:'zip'. cg@1440: fileName := Smalltalk getSourceFileName:(fn name). cg@1440: fileName notNil ifTrue:[ cg@1440: zar := ZipArchive oldFileNamed:fileName. cg@1440: zar notNil ifTrue:[ cg@1440: entry := zar extract:sourceFile. cg@1440: entry notNil ifTrue:[ cg@1440: ^ entry asString readStream cg@1440: ] cg@1440: ] cg@1440: ]. cg@1440: cg@1440: "/ and also in source/source.zip ... cg@1440: cg@1440: fileName := Smalltalk getSourceFileName:'source.zip'. cg@1440: fileName notNil ifTrue:[ cg@1440: zar := ZipArchive oldFileNamed:fileName. cg@1440: zar notNil ifTrue:[ cg@1440: entry := zar extract:sourceFile. cg@1440: entry notNil ifTrue:[ cg@1440: ^ entry asString readStream cg@1440: ] cg@1440: ] cg@1440: ]. cg@1440: ] cg@1440: ] cg@1440: ]. cg@1440: ^ nil cg@1440: cg@1440: "Modified: / 18.7.1998 / 22:53:19 / cg" cg@1440: ! cg@1440: cg@1482: lookupMethodFor:aSelector cg@1482: "return the method, which would be executed if aSelector was sent to cg@1482: an instance of the receiver. I.e. the selector arrays of the receiver cg@1482: and all of its superclasses are searched for aSelector. cg@1482: Return the method, or nil if instances do not understand aSelector. cg@1482: EXPERIMENTAL: take care of multiple superclasses." cg@1482: cg@1482: |m cls| cg@1482: cg@1482: cls := self. cg@1482: [cls notNil] whileTrue:[ cg@1482: m := cls compiledMethodAt:aSelector. cg@1482: m notNil ifTrue:[^ m]. cg@1482: cls := cls superclass cg@1482: ]. cg@1482: ^ nil cg@1482: ! cg@1482: cg@1417: nameWithoutNameSpacePrefix cg@1417: |nm owner| cg@1417: cg@1417: nm := self nameWithoutPrefix. cg@1417: (owner := self owningClass) isNil ifTrue:[ cg@1417: ^ nm cg@1417: ]. cg@1417: cg@1417: ^ (owner nameWithoutNameSpacePrefix , '::' , nm) cg@1417: ! cg@1417: cg@1417: nameWithoutPrefix cg@1417: |nm idx| cg@1417: cg@1417: nm := self name. cg@1417: idx := nm lastIndexOf:$:. cg@1417: idx == 0 ifTrue:[ cg@1417: ^ nm cg@1417: ]. cg@1417: ^ nm copyFrom:idx+1. cg@1417: ! cg@1417: cg@1419: packageSourceCodeInfo cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return the sourceCodeInfo, which defines the module and the subdirectory cg@1419: in which the receiver class was built. cg@1419: This info is extracted from the package id (which is added to stc-compiled classes). cg@1419: This method is to be obsoleted soon, since the same info is now found cg@1419: in the versionString. cg@1419: cg@1419: The info returned consists of a dictionary cg@1419: filled with (at least) values at: #module, #directory and #library. cg@1419: If no such info is present in the class, nil is returned. cg@1419: (this happens with autoloaded and filed-in classes) cg@1419: Auotloaded classes set their package from the revisionInfo, if present. cg@1419: cg@1419: By convention, this info is encoded in the classes package cg@1419: string (which is given as argument to stc) as the last word in parenthesis. cg@1419: The info consists of 1 to 3 subcomponents, separated by colons. cg@1419: The first defines the classes module (i.e. some application identifier), cg@1419: the second defines the subdirectory within that module, the third cg@1419: defines the name of the class library. cg@1419: If left blank, the module info defaults to 'stx', cg@1419: the directory info defaults to library name. cg@1419: The library name may not be left blank. cg@1419: (this is done for backward compatibility,) cg@1419: cg@1419: For example: cg@1419: '....(libbasic)' -> module: stx directory: libbasic library: libbasic cg@1419: '....(stx:libbasic)' -> module: stx directory: libbasic library: libbasic cg@1419: '....(stx:foo:libbfoo)' -> module: stx directory: foo library: libfoo cg@1419: '....(aeg:libIECInterface)' -> module: aeg directory: libIECInterface library:libIECInterface cg@1419: '....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase cg@1419: cg@1419: The way how the sourceCodeManager uses this to find the source location cg@1419: depends on the scheme used. For CVS, the module is taken as the -d arg, cg@1419: while the directory is prepended to the file name. cg@1419: Other schemes may do things differently - these are not yet specified. cg@1419: cg@1419: Caveat: cg@1419: Encoding this info in the package string seems somewhat kludgy. cg@1419: " cg@1419: cg@1419: |owner sourceInfo packageString idx1 idx2 cg@1419: moduleString directoryString libraryString components component1 component2 dirComponents mgr cg@1419: package| cg@1419: cg@1419: (owner := self owningClass) notNil ifTrue:[^ owner packageSourceCodeInfo]. cg@1419: cg@1419: package := self package. cg@1419: package isNil ifTrue:[^ nil]. cg@1419: cg@1419: packageString := package asString. cg@1419: idx1 := packageString lastIndexOf:$(. cg@1419: idx1 ~~ 0 ifTrue:[ cg@1419: idx2 := packageString indexOf:$) startingAt:idx1+1. cg@1419: idx2 ~~ 0 ifTrue:[ cg@1419: sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1 cg@1419: ] cg@1419: ] ifFalse:[ cg@1419: sourceInfo := packageString cg@1419: ]. cg@1419: cg@1419: sourceInfo isNil ifTrue:[^ nil]. cg@1419: components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:. cg@1419: components size == 0 ifTrue:[ cg@1419: "/ moduleString := 'stx'. cg@1419: "/ directoryString := libraryString := ''. cg@1419: ^ nil cg@1419: ]. cg@1419: cg@1419: component1 := components at:1. cg@1419: components size == 1 ifTrue:[ cg@1419: "/ a single name given - the module becomes 'stx' or cg@1419: "/ the very first directory component (if such a module exists). cg@1419: "/ If the component includes slashes, its the directory cg@1419: "/ otherwise the library. cg@1419: "/ cg@1419: dirComponents := Filename concreteClass components:component1. cg@1419: (dirComponents size > 1 cg@1419: and:[(mgr := self sourceCodeManager) notNil cg@1419: and:[mgr checkForExistingModule:dirComponents first]]) ifTrue:[ cg@1419: moduleString := dirComponents first. cg@1419: directoryString := libraryString := (Filename fromComponents:(dirComponents copyFrom:2)) asString. cg@1419: ] ifFalse:[ cg@1419: "/ non-existing; assume directory under the stx package. cg@1419: moduleString := 'stx'. cg@1419: (component1 startsWith:'stx/') ifTrue:[ cg@1419: component1 := component1 copyFrom:5 cg@1419: ]. cg@1419: directoryString := libraryString := component1. cg@1419: ]. cg@1419: cg@1419: (libraryString includes:$/) ifTrue:[ cg@1419: libraryString := libraryString asFilename baseName cg@1419: ] cg@1419: ] ifFalse:[ cg@1419: component2 := components at:2. cg@1419: components size == 2 ifTrue:[ cg@1419: "/ two components - assume its the module and the directory; cg@1419: "/ the library is assumed to be named after the directory cg@1419: "/ except, if slashes are in the name; then the libraryname cg@1419: "/ is the last component. cg@1419: "/ cg@1419: moduleString := component1. cg@1419: directoryString := libraryString := component2. cg@1419: (libraryString includes:$/) ifTrue:[ cg@1419: libraryString := libraryString asFilename baseName cg@1419: ] cg@1419: ] ifFalse:[ cg@1419: "/ all components given cg@1419: moduleString := component1. cg@1419: directoryString := component2. cg@1419: libraryString := components at:3. cg@1419: ] cg@1419: ]. cg@1419: cg@1419: libraryString isEmpty ifTrue:[ cg@1419: directoryString notEmpty ifTrue:[ cg@1419: libraryString := directoryString asFilename baseName cg@1419: ]. cg@1419: libraryString isEmpty ifTrue:[ cg@1419: "/ lets extract the library from the liblist file ... cg@1419: libraryString := Smalltalk libraryFileNameOfClass:self. cg@1419: libraryString isNil ifTrue:[^ nil]. cg@1419: ] cg@1419: ]. cg@1419: cg@1419: moduleString isEmpty ifTrue:[ cg@1419: moduleString := 'stx'. cg@1419: ]. cg@1419: directoryString isEmpty ifTrue:[ cg@1419: directoryString := libraryString. cg@1419: ]. cg@1419: cg@1419: ^ IdentityDictionary cg@1419: with:(#module->moduleString) cg@1419: with:(#directory->directoryString) cg@1419: with:(#library->libraryString) cg@1419: cg@1419: " cg@1419: Object packageSourceCodeInfo cg@1419: View packageSourceCodeInfo cg@1419: Model packageSourceCodeInfo cg@1419: BinaryObjectStorage packageSourceCodeInfo cg@1419: MemoryMonitor packageSourceCodeInfo cg@1419: ClockView packageSourceCodeInfo cg@1419: " cg@1419: cg@1419: "Created: 4.11.1995 / 20:36:53 / cg" cg@1440: "Modified: 19.9.1997 / 10:42:25 / cg" cg@1440: ! cg@1419: cg@1419: primitiveDefinitionsString cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return the primitiveDefinition string or nil" cg@1419: cg@1419: ^ self getPrimitiveSpecsAt:1 cg@1419: cg@1419: " mawalch@3324: Object primitiveDefinitionsString cg@1419: String primitiveDefinitionsString cg@1440: " cg@1440: ! cg@1419: cg@1419: primitiveFunctionsString cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return the primitiveFunctions string or nil" cg@1419: cg@1440: ^ self getPrimitiveSpecsAt:3 cg@1440: ! cg@1419: cg@1419: primitiveVariablesString cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return the primitiveVariables string or nil" cg@1419: cg@1440: ^ self getPrimitiveSpecsAt:2 cg@1440: ! cg@1419: cg@1419: printClassNameOn:aStream cg@1419: |nm| cg@1419: cg@1419: Class fileOutNameSpaceQuerySignal query == false ifTrue:[ cg@1419: nm := self nameWithoutNameSpacePrefix cg@1419: ] ifFalse:[ cg@1419: nm := self name. cg@1419: ]. cg@1419: cg@1440: aStream nextPutAll:nm. cg@1440: ! cg@1419: cg@1417: printClassVarNamesOn:aStream indent:indent cg@1417: "print the class variable names indented and breaking at line end" cg@1417: cg@1417: self printNameArray:(self classVarNames) on:aStream indent:indent cg@1417: ! cg@1417: cg@1417: printHierarchyAnswerIndentOn:aStream cg@1417: "print my class hierarchy on aStream - return indent cg@1417: recursively calls itself to print superclass and use returned indent cg@1417: for my description - used in the browser" cg@1417: cg@1417: |indent nm superclass| cg@1417: cg@1417: superclass := self superclass. cg@1417: indent := 0. cg@1417: (superclass notNil) ifTrue:[ cg@1417: indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2 cg@1417: ]. cg@1417: aStream spaces:indent. cg@1417: nm := self printNameInHierarchy. cg@1417: aStream nextPutAll:nm; nextPutAll:' ('. cg@1417: self printInstVarNamesOn:aStream indent:(indent + nm size + 2). cg@1417: aStream nextPutLine:')'. cg@1417: ^ indent cg@1417: ! cg@1417: cg@1417: printHierarchyOn:aStream cg@1417: self printHierarchyAnswerIndentOn:aStream cg@1417: ! cg@1417: cg@1417: printInstVarNamesOn:aStream indent:indent cg@1417: "print the instance variable names indented and breaking at line end" cg@1417: cg@1417: self printNameArray:(self instVarNames) on:aStream indent:indent cg@1417: cg@1417: "Created: 22.3.1997 / 14:12:00 / cg" cg@1417: ! cg@1417: cg@1417: printNameArray:anArray on:aStream indent:indent cg@1417: "print an array of strings separated by spaces; when the stream cg@1417: defines a lineLength, break when this limit is reached; indent cg@1417: every line; used to printOut instance variable names" cg@1417: cg@1417: |thisName nextName arraySize lenMax pos mustBreak line spaces| cg@1417: cg@1417: arraySize := anArray size. cg@1417: arraySize ~~ 0 ifTrue:[ cg@1417: pos := indent. cg@1417: lenMax := aStream lineLength. cg@1417: thisName := anArray at:1. cg@1417: line := ''. cg@1417: 1 to:arraySize do:[:index | cg@1417: line := line , thisName. cg@1417: pos := pos + thisName size. cg@1417: (index == arraySize) ifFalse:[ cg@1417: nextName := anArray at:(index + 1). cg@1417: mustBreak := false. cg@1417: (lenMax > 0) ifTrue:[ cg@1417: ((pos + nextName size) > lenMax) ifTrue:[ cg@1417: mustBreak := true cg@1417: ] cg@1417: ]. cg@1417: mustBreak ifTrue:[ cg@1417: aStream nextPutLine:line withTabs. cg@1417: spaces isNil ifTrue:[ cg@1417: spaces := String new:indent cg@1417: ]. cg@1417: line := spaces. cg@1417: pos := indent cg@1417: ] ifFalse:[ cg@1417: line := line , ' '. cg@1417: pos := pos + 1 cg@1417: ]. cg@1417: thisName := nextName cg@1417: ] cg@1417: ]. cg@1417: aStream nextPutAll:line withTabs cg@1417: ] cg@1417: cg@1417: "Modified: 9.11.1996 / 00:12:06 / cg" cg@1417: "Created: 22.3.1997 / 14:12:12 / cg" cg@1417: ! cg@1417: cg@1417: printNameInHierarchy cg@1417: ^ self name cg@1417: ! cg@1417: cg@1419: privateClasses cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return a collection of my private classes (if any). cg@1419: The classes are in any order." cg@1419: cg@1440: ^ self privateClassesOrAll:false cg@1440: ! cg@1419: cg@1417: privateClassesAt:aClassNameStringOrSymbol cg@1417: |nmSym| cg@1417: cg@1417: nmSym := (self name , '::' , aClassNameStringOrSymbol) asSymbolIfInterned. cg@1417: nmSym isNil ifTrue:[ cg@1417: "/ no such symbol - there cannot be a corresponding private class cg@1417: ^ nil cg@1417: ]. cg@1417: sv@1866: ^ memory image at:nmSym. cg@1417: ! cg@1417: cg@1419: privateClassesOrAll:allOfThem cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return a collection of my direct private classes (if any) cg@1419: or direct plus indirect private classes (if allOfThem). cg@1419: An empty collection if there are none. cg@1419: The classes are in any order." cg@1419: cg@1419: |classes myName myNamePrefix myNamePrefixLen| cg@1419: cg@1419: myName := self name. cg@1419: myNamePrefix := myName , '::'. cg@1419: myNamePrefixLen := myNamePrefix size. cg@1419: cg@1791: memory image keysDo:[:nm | cg@1419: |cls| cg@1419: cg@1419: (nm startsWith:myNamePrefix) ifTrue:[ cg@1419: (allOfThem cg@1419: or:[(nm indexOf:$: startingAt:myNamePrefixLen + 1) == 0]) ifTrue:[ cg@1791: cls := memory image at:nm. cg@1419: cg@1419: (cls isBehavior and:[cls isMeta not]) ifTrue:[ cg@1419: classes isNil ifTrue:[ cg@1419: classes := IdentitySet new:10. cg@1419: ]. cg@1419: classes add:cls. cg@1419: ] cg@1419: ] cg@1419: ] cg@1419: ]. cg@1419: cg@1419: ^ classes ? #() cg@1419: cg@1419: " cg@1419: UILayoutTool privateClassesOrAll:true cg@1419: UILayoutTool privateClassesOrAll:false cg@1419: " cg@1419: cg@1440: "Modified: / 29.5.1998 / 23:23:18 / cg" cg@1440: ! cg@1419: cg@1419: privateClassesSorted cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return a collection of my private classes (if any). cg@1419: The classes are sorted by inheritance." cg@1419: cg@1419: |classes| cg@1419: cg@1419: classes := self privateClasses. cg@1419: (classes size > 0) ifTrue:[ cg@1419: classes := classes asOrderedCollection topologicalSort:[:a :b | b isSubclassOf:a]. cg@1419: ]. cg@1419: ^ classes. cg@1419: cg@1419: " cg@1419: Object privateClassesSorted cg@1419: " cg@1419: cg@1419: "Created: 22.3.1997 / 16:10:42 / cg" cg@1440: "Modified: 22.3.1997 / 16:11:20 / cg" cg@1440: ! cg@1419: cg@1419: revisionInfo cg@1419: "return a dictionary filled with revision info. cg@1419: This extracts the relevant info from the revisionString. cg@1419: The revisionInfo contains all or a subset of: cg@1419: #binaryRevision - the revision upon which the binary of this class is based cg@1419: #revision - the revision upon which the class is based logically cg@1419: (different, if a changed class was checked in, but not yet recompiled) cg@1419: #user - the user who checked in the logical revision cg@1419: #date - the date when the logical revision was checked in cg@1419: #time - the time when the logical revision was checked in cg@1419: #fileName - the classes source file name cg@1419: #repositoryPath - the classes source container cg@1419: " cg@1419: cg@1419: |vsnString info mgr| cg@1419: cg@1419: vsnString := self revisionString. cg@1419: vsnString notNil ifTrue:[ cg@1419: mgr := self sourceCodeManager. cg@1419: mgr notNil ifTrue:[ cg@1419: info := mgr revisionInfoFromString:vsnString cg@1419: ] ifFalse:[ cg@1419: info := Class revisionInfoFromString:vsnString. cg@1419: ]. cg@1419: info notNil ifTrue:[ cg@1419: info at:#binaryRevision put:self binaryRevision. cg@1419: ] cg@1419: ]. cg@1440: ^ info cg@1440: ! cg@1419: cg@3091: revisionInfoOfManager: mgr cg@3091: ^ (Smalltalk classNamed:self name) cg@3091: revisionInfoOfManager: mgr cg@3091: ! cg@3091: cg@1419: revisionString cg@1419: "{ Pragma: +optSpace }" cg@1419: cg@1419: "return my revision string; that one is extracted from the cg@1419: classes #version method. Either this is a method returning that string, cg@1419: or its a comment-only method and the comment defines the version. mawalch@3250: If the source is not accessible or no such method exists, cg@1419: nil is returned." cg@1419: cg@1419: |owner cls meta m src val| cg@1419: cg@1419: (owner := self owningClass) notNil ifTrue:[^ owner revisionString]. cg@1419: cg@1419: thisContext isRecursive ifTrue:[^ nil ]. cg@1419: cg@1419: self isMeta ifTrue:[ cg@1419: meta := self. cls := self soleInstance cg@1419: ] ifFalse:[ cg@1419: cls := self. meta := self classRef cg@1419: ]. cg@1419: cg@1419: m := meta compiledMethodAt:#version. cg@1419: m isNil ifTrue:[ cg@1419: m := cls compiledMethodAt:#version. cg@1419: m isNil ifTrue:[^ nil]. cg@1419: ]. cg@1419: cg@1419: m isExecutable ifTrue:[ cg@1419: "/ cg@1419: "/ if its a method returning the string, cg@1419: "/ thats the returned value cg@1419: "/ cg@1419: val := cls version. cg@1419: val isString ifTrue:[^ val]. cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ if its a method consisting of a comment only cg@1419: "/ extract it - this may lead to a recursive call cg@1419: "/ to myself (thats what the #isRecursive is for) cg@1419: "/ in case we need to access the source code manager cg@1419: "/ for the source ... cg@1419: "/ cg@1419: src := m source. cg@1419: src isNil ifTrue:[^ nil]. cg@1419: ^ Class revisionStringFromSource:src cg@1419: cg@1419: " cg@1419: Smalltalk allClassesDo:[:cls | cg@1419: Transcript showCR:cls revisionString cg@1419: ]. cg@1419: cg@1419: Number revisionString cg@1419: FileDirectory revisionString cg@1419: Metaclass revisionString cg@1419: " cg@1419: cg@1419: "Created: 29.10.1995 / 19:28:03 / cg" cg@1419: "Modified: 23.10.1996 / 18:23:56 / cg" cg@1440: "Modified: 1.4.1997 / 23:37:25 / stefan" cg@1440: ! cg@1419: cg@1419: selectorAtMethod:aMethod cg@1440: ^ self selectorAtMethod:aMethod ifAbsent:[nil] cg@1440: ! cg@1419: cg@1419: selectorAtMethod:aMethod ifAbsent:failBlock cg@1419: |md| cg@1419: cg@1419: md := self methodDictionary. cg@1419: md isNil ifTrue:[ cg@1419: 'OOPS - nil methodDictionary' errorPrintCR. cg@1419: ^ nil cg@1419: ]. cg@1440: ^ md keyAtValue:aMethod ifAbsent:failBlock. cg@1440: ! cg@1419: cg@1419: soleInstance cg@1419: self isMeta ifFalse:[self halt]. cg@1419: ^ self theNonMetaclass. cg@1419: ! cg@1419: cg@1417: sourceCodeManager cg@1417: ^ SourceCodeManager cg@1417: ! cg@1417: cg@1419: sourceStreamFor:source cg@1419: "return an open stream on a sourcefile, nil if that is not available" cg@1419: cg@1419: |owner fileName aStream mgr validated guessedFileName sep mod dir classFilename package name| cg@1419: cg@1419: self isMeta ifTrue:[ cg@1419: ^ self theNonMetaclass sourceStreamFor:source cg@1419: ]. cg@1419: cg@1419: (owner := self owningClass) notNil ifTrue:[^ owner sourceStreamFor:source]. cg@1419: validated := false. cg@1419: cg@1419: classFilename := self classFilename. cg@1419: package := self package. cg@1419: name := self name. cg@1419: cg@1419: "/ mawalch@3324: "/ if there is no SourceCodeManager, cg@1419: "/ or TryLocalSourceFirst is true, cg@1419: "/ look in standard places first cg@1419: "/ mawalch@3324: ((mgr := self sourceCodeManager) isNil cg@1419: or:[Class tryLocalSourceFirst == true]) ifTrue:[ cg@1419: aStream := self localSourceStreamFor:source. cg@1419: ]. cg@1419: cg@1419: aStream isNil ifTrue:[ cg@1419: "/ mhmh - still no source file. mawalch@3324: "/ If there is a SourceCodeManager, ask it to acquire the mawalch@3324: "/ the source for my class, and return an open stream on it. cg@1419: "/ if that one does not know about the source, look in cg@1419: "/ standard places cg@1419: cg@1419: mgr notNil ifTrue:[ cg@1419: self classFilename ~= source ifTrue:[ cg@1419: sep := self package indexOfAny:'/\:'. cg@1419: sep ~~ 0 ifTrue:[ cg@1419: mod := package copyTo:sep - 1. cg@1419: dir := package copyFrom:sep + 1. cg@1419: aStream := mgr streamForClass:nil fileName:source revision:nil directory:dir module:mod cache:true. cg@1419: ]. cg@1419: ]. cg@1419: aStream isNil ifTrue:[ cg@1419: classFilename isNil ifTrue:[ cg@1419: classFilename := guessedFileName := (Smalltalk fileNameForClass:self) , '.st'. cg@1419: ]. cg@1419: source asFilename baseName = classFilename asFilename baseName ifTrue:[ cg@1419: aStream := mgr getSourceStreamFor:self. cg@1419: ] cg@1419: ]. cg@1419: aStream notNil ifTrue:[ cg@1419: (self validateSourceStream:aStream) ifFalse:[ mawalch@3324: ('Class [info]: repositories source for `' cg@1419: , (self isMeta ifTrue:[self soleInstance name] cg@1419: ifFalse:[name]) cg@1419: , ''' is invalid.') infoPrintCR. cg@1419: aStream close. cg@1419: aStream := nil cg@1419: ] ifTrue:[ cg@1419: validated := true. cg@1419: ]. cg@1419: ]. cg@1419: ] cg@1419: ]. cg@1419: cg@1419: aStream isNil ifTrue:[ mawalch@3324: "/ cg@1419: "/ hard case - there is no source file for this class cg@1419: "/ (in the source-dir-path). mawalch@3324: "/ mawalch@3324: mawalch@3324: "/ cg@1419: "/ look if my binary is from a dynamically loaded module, cg@1419: "/ and, if so, look in the modules directory for the cg@1419: "/ source file. mawalch@3324: "/ cg@1419: ObjectFileLoader notNil ifTrue:[ cg@1419: ObjectFileLoader loadedObjectHandlesDo:[:h | cg@1419: |f classes| cg@1419: cg@1419: aStream isNil ifTrue:[ cg@1419: (classes := h classes) size > 0 ifTrue:[ cg@1419: (classes includes:self) ifTrue:[ cg@1419: f := h pathName. cg@1419: f := f asFilename directory. cg@1419: f := f construct:source. cg@1419: f exists ifTrue:[ cg@1419: aStream := f readStream. cg@1419: ]. cg@1419: ]. cg@1419: ]. cg@1419: ] cg@1419: ]. cg@1419: ]. cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ try along sourcePath cg@1419: "/ cg@1419: aStream isNil ifTrue:[ cg@1419: aStream := self localSourceStreamFor:source. cg@1419: ]. cg@1419: cg@1419: "/ cg@1419: "/ final chance: try current directory cg@1419: "/ cg@1419: aStream isNil ifTrue:[ cg@1419: aStream := source asFilename readStream. cg@1419: ]. cg@1419: cg@1419: (aStream notNil and:[validated not]) ifTrue:[ cg@1419: (self validateSourceStream:aStream) ifFalse:[ cg@1419: (Smalltalk releaseIdentification = 'ST/X_free_demo_vsn') ifTrue:[ cg@1419: "/ ('Class [info]: source for ''' , self name , ''' is not available in the demo version.') infoPrintCR cg@1419: ] ifFalse:[ cg@1419: ('Class [warning]: source for ''' , self name , ''' is invalid or stripped. Take care.') errorPrintCR cg@1419: ] cg@1419: ]. cg@1419: ]. cg@1419: (aStream notNil and:[aStream isFileStream]) ifTrue:[ cg@1419: guessedFileName notNil ifTrue:[ cg@1419: classFilename := aStream pathName asFilename baseName. cg@1419: ] cg@1419: ]. cg@1419: ^ aStream cg@1419: cg@1419: " cg@1419: Object sourceStream cg@1419: Clock sourceStream cg@1419: Autoload sourceStream cg@1419: " cg@1419: cg@1419: "Created: / 10.11.1995 / 21:05:13 / cg" cg@1419: "Modified: / 22.4.1998 / 19:20:50 / ca" cg@1419: "Modified: / 23.4.1998 / 15:53:54 / cg" cg@1419: ! cg@1419: cg@1419: subclasses cg@1419: "return a collection of the direct subclasses of the receiver" cg@1419: cg@1419: |newColl| cg@1419: cg@1419: "/ "/ use cached information (avoid class hierarchy search) cg@1419: "/ "/ if possible cg@1419: "/ cg@1419: "/ SubclassInfo notNil ifTrue:[ cg@1419: "/ newColl := SubclassInfo at:self ifAbsent:nil. cg@1419: "/ newColl notNil ifTrue:[^ newColl asOrderedCollection] cg@1419: "/ ]. cg@1419: cg@1419: newColl := OrderedCollection new. cg@1419: self subclassesDo:[:aClass | cg@1419: newColl add:aClass cg@1419: ]. cg@1419: "/ SubclassInfo notNil ifTrue:[ cg@1419: "/ SubclassInfo at:self put:newColl. cg@1419: "/ ]. cg@1419: ^ newColl cg@1419: ! cg@1419: cg@1419: subclassesDo:aBlock cg@1419: "evaluate the argument, aBlock for all immediate subclasses. cg@1419: This will only enumerate globally known classes - for anonymous cg@1419: behaviors, you have to walk over all instances of Behavior." cg@1419: cg@1419: |coll| cg@1419: cg@1419: self isMeta ifTrue:[ cg@1419: self halt. cg@1419: "/ metaclasses are not found via Smalltalk allClassesDo: cg@1419: "/ here, walk over classes and enumerate corresponding metas. cg@1419: self soleInstance subclassesDo:[:aSubClass | cg@1482: aBlock value:(aSubClass theMetaclass) cg@1419: ]. cg@1419: ^ self cg@1419: ]. cg@1419: cg@1419: "/ use cached information (avoid class hierarchy search) cg@1419: "/ if possible cg@1419: cg@1419: "/ SubclassInfo isNil ifTrue:[ cg@1419: "/ Behavior subclassInfo cg@1419: "/ ]. cg@1419: "/ SubclassInfo notNil ifTrue:[ cg@1419: "/ coll := SubclassInfo at:self ifAbsent:nil. cg@1419: "/ coll notNil ifTrue:[ cg@1419: "/ coll do:aBlock. cg@1419: "/ ]. cg@1419: "/ ^ self cg@1419: "/ ]. cg@1419: cg@1419: Smalltalk allClassesDo:[:aClass | cg@1419: (aClass superclass == self) ifTrue:[ cg@1419: aBlock value:aClass cg@1419: ] cg@1419: ] cg@1419: cg@1419: " cg@1419: Collection subclassesDo:[:c | Transcript showCR:(c name)] cg@1419: " cg@1419: cg@1419: "Modified: 22.1.1997 / 18:44:01 / cg" cg@1419: ! cg@1419: cg@1417: syntaxHighlighterClass cg@1417: ^ Object syntaxHighlighterClass cg@1417: ! cg@1417: cg@1419: theMetaclass cg@1419: self isMeta ifTrue:[^ self]. cg@1440: ^ self classRef. cg@1440: ! cg@1419: cg@1419: theNonMetaclass cg@1419: |instSlotOffs clsPtr| cg@1419: cg@1419: self isMeta ifFalse:[^ self]. cg@1419: instSlotOffs := Metaclass instVarOffsetOf:'myClass'. cg@1419: clsPtr := self at:instSlotOffs. cg@1419: ^ memory fetchObjectAt:clsPtr. cg@1419: ! cg@1419: cg@1419: validateSourceStream:aStream cg@1419: "check if aStream really contains my source. cg@1419: This is done by checking the version methods return value cg@1419: against the version string as contained in the version method" cg@1419: cg@1440: ^ true cg@1440: ! cg@1419: cg@1482: whichClassDefinesClassVar:aVariableName cg@1482: "return the class which defines the class variable cg@1482: named aVariableName. This method should not be used for cg@1482: repeated searches (i.e. in the compiler/parser), since it creates cg@1482: many throw away intermediate objects." cg@1482: cg@1482: |cls| cg@1482: cg@1482: cls := self. cg@1482: [cls notNil] whileTrue:[ cg@1482: (cls classVarNames includes:aVariableName) ifTrue:[ ^ cls]. cg@1482: cls := cls superclass cg@1482: ]. cg@1482: ^ nil cg@1482: ! cg@1482: cg@1482: whichClassIncludesSelector:aSelector cg@1482: "return the class in the inheritance chain, which implements the method cg@1482: for aSelector; return nil if none." cg@1482: cg@1482: |cls| cg@1482: cg@1482: cls := self. cg@1482: [cls notNil] whileTrue:[ cg@1482: (cls includesSelector:aSelector) ifTrue:[^ cls]. cg@1482: cls := cls superclass cg@1482: ]. cg@1482: ^ nil cg@1482: ! cg@1482: cg@1419: withAllSuperclasses cg@1419: "return a collection containing the receiver and all cg@1419: of the receivers accumulated superclasses" cg@1419: cg@1419: |aCollection theSuperClass| cg@1419: cg@1419: aCollection := OrderedCollection with:self. cg@1419: theSuperClass := self superclass. cg@1419: [theSuperClass notNil] whileTrue:[ cg@1419: aCollection add:theSuperClass. cg@1419: theSuperClass := theSuperClass superclass cg@1419: ]. cg@1419: ^ aCollection cg@1440: ! cg@1419: cg@1417: withAllSuperclassesDo:aBlock cg@1417: |sc| cg@1417: cg@1417: aBlock value:self. cg@1417: sc := self superclass. cg@1417: sc notNil ifTrue:[ cg@1417: sc withAllSuperclassesDo:aBlock. cg@1417: ] cg@1417: ! ! cg@1417: cg@1551: !SnapShotImageMemory::ImageClassObject methodsFor:'namespace protocol'! cg@1551: cg@1791: allClasses cg@1791: |classes| cg@1791: cg@1791: classes := IdentitySet new. cg@1791: self allClassesDo:[:aClass | classes add:aClass]. cg@1791: ^ classes cg@1791: ! cg@1791: cg@1551: allClassesDo:aBlock cg@1551: |prefix| cg@1551: cg@1551: self isNameSpace ifFalse:[ self error ]. cg@1551: prefix := self name , '::'. cg@1551: cg@1551: memory image allClassesDo:[:cls | cg@1551: (cls name startsWith:prefix) ifTrue:[ cg@1551: aBlock value:cls cg@1551: ] cg@1551: ] cg@1551: ! cg@1551: cg@1551: at:aKey cg@1551: |fullName| cg@1551: sv@1866: aKey isString ifFalse:[ cg@1551: ^ super at:aKey cg@1551: ]. cg@1551: sv@1866: self isNameSpace ifFalse:[ self error:'namespace expected' ]. cg@1551: fullName := self name , '::' , aKey. cg@1551: ^ memory image at:fullName asSymbol cg@1551: ! ! cg@1551: cg@1551: !SnapShotImageMemory::ImageClassObject methodsFor:'printing'! cg@1551: cg@1551: printOn:aStream cg@1551: aStream nextPutAll:'img-'. cg@1551: aStream nextPutAll:self name. cg@1551: ! ! cg@1551: cg@1417: !SnapShotImageMemory::ImageClassObject methodsFor:'queries'! cg@1417: cg@1417: categories cg@1417: |newList| cg@1417: cg@1417: newList := Set new. cg@1417: self methodDictionary do:[:aMethod | cg@1417: |cat| cg@1417: cg@1417: cat := aMethod category. cg@1417: cat isNil ifTrue:[ cg@1417: cat := '* no category *' cg@1417: ]. cg@1417: newList add:cat cg@1417: ]. cg@1417: ^ newList cg@1417: ! cg@1417: cg@1417: isBytes cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagBytes. cg@1417: ! cg@1417: cg@1417: isDoubles cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagDoubles. cg@1417: ! cg@1417: cg@1417: isFloats cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagFloats. cg@1417: ! cg@1417: cg@1482: isImageBehavior cg@1482: ^ true cg@1482: ! cg@1482: cg@1417: isLoaded cg@1420: |superclass| cg@1420: cg@1420: superclass := self superclass. cg@1420: superclass isNil ifTrue:[^ true]. cg@1417: ^ self superclass name ~= 'Autoload' cg@1417: ! cg@1417: cg@1417: isLongLongs cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagLongLongs. cg@1417: ! cg@1417: cg@1417: isLongs cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagLongs. cg@1417: ! cg@1417: cg@1417: isMeta cg@1792: |clsName| cg@1792: cg@1864: thisContext isRecursive ifTrue:[^ false]. cg@3088: byteSize = memory metaClassByteSize ifFalse:[^ false]. cg@1864: cg@1792: clsName := classRef name. cg@1792: ^ clsName = 'Metaclass' or:[clsName = 'PrivateMetaclass']. cg@1792: cg@1792: "/self halt. cg@1792: "/ ^ self size == (Metaclass instSize). cg@1440: ! cg@1417: cg@1551: isNameSpace cg@1551: "return true, if this is a nameSpace." cg@1551: cg@1551: |superclass| cg@1551: cg@1551: superclass := self superclass. cg@1551: ^ superclass notNil cg@1551: and:[ superclass name = 'NameSpace' ]. cg@1551: ! cg@1551: cg@1417: isPrivate mawalch@3324: ^ classRef isPrivateMeta cg@1417: ! cg@1417: cg@1417: isPrivateMeta cg@1864: thisContext isRecursive ifTrue:[^ false]. cg@3088: byteSize = memory privateMetaClassByteSize ifFalse:[^ false]. cg@1417: ^ classRef name = 'PrivateMetaclass' cg@1417: ! cg@1417: cg@1417: isSignedLongLongs cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedLongLongs. cg@1417: ! cg@1417: cg@1417: isSignedLongs cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedLongs. cg@1417: ! cg@1417: cg@1417: isSignedWords cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedWords. cg@1417: ! cg@1417: cg@1791: isTopLevelNameSpace sv@1866: "return true, if this is a top level nameSpace." sv@1866: sv@1866: ^ self isNameSpace and:[(self name includes:$:) not] cg@1551: ! cg@1551: cg@1417: isVariable cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) ~= 0. cg@1417: ! cg@1417: cg@1422: isVisualStartable cg@1440: ^ false cg@1440: ! cg@1422: cg@1417: isWords cg@1417: ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagWords. cg@1417: ! cg@1417: cg@1417: nameSpace cg@1417: |env name idx nsName| cg@1417: cg@1417: "/ (env := self environment) notNil ifTrue:[^ env]. cg@1551: env := memory image at:#Smalltalk. "/ default cg@1417: name := self name. cg@1417: idx := name lastIndexOf:$:. cg@1417: idx ~~ 0 ifTrue:[ cg@1417: (name at:idx-1) == $: ifTrue:[ cg@1417: nsName := name copyTo:(idx - 2). cg@1551: env := memory image at:nsName asSymbol. cg@1417: ] cg@1417: ]. cg@1417: ^ env cg@1417: ! cg@1417: cg@1417: owningClass cg@1417: |ownerPtr owner| cg@1417: cg@1417: classRef isPrivateMeta ifFalse:[^ nil]. cg@1791: ownerPtr := classRef at:(PrivateMetaclass instVarOffsetOf:'owningClass'). cg@1417: owner := memory fetchClassObjectAt:ownerPtr. cg@1417: ^ owner cg@1417: ! cg@1417: cg@1724: owningClassOrYourself cg@1724: self owningClass notNil ifTrue:[^ self topOwningClass]. cg@1724: ^ self cg@1724: ! cg@1724: cg@1417: supportsMethodCategories cg@1417: ^ true cg@1417: ! cg@1417: sv@1866: topNameSpace sv@1866: "return the nameSpace of my topOwningClass (if private) or my own nameSpace." sv@1866: sv@1866: self isPrivate ifTrue:[^ self topOwningClass topNameSpace]. sv@1866: ^ self nameSpace sv@1866: ! sv@1866: cg@1417: topOwningClass cg@1417: |owner| cg@1417: cg@1417: classRef isPrivateMeta ifTrue:[ cg@1417: owner := self owningClass. cg@1417: [owner classRef isPrivateMeta] whileTrue:[ cg@1417: owner := owner owningClass cg@1417: ]. cg@1417: ^ owner cg@1417: ] ifFalse:[ cg@1417: ^ nil cg@1417: ]. cg@1417: ^ self halt. cg@1417: ! cg@1417: cg@1417: wasAutoloaded mawalch@3324: ^ false cg@1417: ! ! cg@1417: cg@3326: !SnapShotImageMemory::ImageWordObject methodsFor:'queries'! cg@3326: cg@3326: size cg@3326: ^ byteSize // 2 cg@3326: ! ! cg@3326: cg@1440: !SnapShotImageMemory::SpaceInfo methodsFor:'accessing'! cg@1440: cg@1440: end cg@1440: "return the value of the instance variable 'end' (automatically generated)" cg@1440: cg@1440: ^ end cg@1440: ! cg@1440: cg@1440: end:something cg@1440: "set the value of the instance variable 'end' (automatically generated)" cg@1440: cg@1440: end := something. cg@1440: ! cg@1440: cg@1440: flags cg@1440: "return the value of the instance variable 'flags' (automatically generated)" cg@1440: cg@1440: ^ flags cg@1440: ! cg@1440: cg@1440: flags:something cg@1440: "set the value of the instance variable 'flags' (automatically generated)" cg@1440: cg@1440: flags := something. cg@1440: ! cg@1440: cg@1440: imageBase cg@1440: "return the value of the instance variable 'imageBase' (automatically generated)" cg@1440: cg@1440: ^ imageBase cg@1440: ! cg@1440: cg@1440: imageBase:something cg@1440: "set the value of the instance variable 'imageBase' (automatically generated)" cg@1440: cg@1440: imageBase := something. cg@1440: ! cg@1440: cg@1440: size cg@1440: "return the value of the instance variable 'size' (automatically generated)" cg@1440: cg@1440: ^ size cg@1440: ! cg@1440: cg@1440: size:something cg@1440: "set the value of the instance variable 'size' (automatically generated)" cg@1440: cg@1440: size := something. cg@1440: ! cg@1440: cg@1440: start cg@1440: "return the value of the instance variable 'start' (automatically generated)" cg@1440: cg@1440: ^ start cg@1440: ! cg@1440: cg@1440: start:something cg@1440: "set the value of the instance variable 'start' (automatically generated)" cg@1440: cg@1440: start := something. cg@1440: ! ! cg@1440: cg@1416: !SnapShotImageMemory class methodsFor:'documentation'! cg@1416: cg@1416: version cg@1416: ^ '$Header$' cg@3089: ! cg@3089: cg@3089: version_CVS cg@3089: ^ '$Header$' cg@1416: ! ! cg@3088: