'From Squeak3.9alpha of ''2 November 2004'' [latest update: #6520] on 5 December 2004 at 10:21:28 pm'! "Change Set: isKindOfForImageSegment Date: 5 December 2004 Author: Alejandro Magistrello - replaces all isKindOf: Morph, Behavior, Collection, String, Number, Stream, Text by isForm, isBehavior, isCollection, isString, isNumber, isStream, isText"! !ImageSegment methodsFor: 'read/write segment' stamp: 'asm 7/2/2003 23:51'! writeForExportWithSources: fName inDirectory: aDirectory "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "this is the old version which I restored until I solve the gzip problem" | fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. temp _ endMarker. endMarker _ nil. tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'. zipper _ [ ProgressNotification signal: '3:uncompressedSaveComplete'. (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" aDirectory rename: (tempFileName, FileDirectory dot, 'gz') toBe: fName. aDirectory deleteFileNamed: tempFileName ifAbsent: [] ]. fileStream _ aDirectory newFileNamed: tempFileName. fileStream fileOutClass: nil andObject: self. "remember extra structures. Note class names." endMarker _ temp. "append sources" allClassesInRoots _ arrayOfRoots select: [:cls | cls isBehavior]. classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource _ OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. fileStream reopen; setToEnd. fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(Utilities timeStampForMethod: each third) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream close. zipper value.! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'asm 7/2/2003 23:51'! writeForExportWithSources: fName inDirectory: aDirectory changeSet: aChangeSetOrNil "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "An experimental version to fileout a changeSet first so that a project can contain its own classes" | fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. temp _ endMarker. endMarker _ nil. tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'. zipper _ [ Preferences debugPrintSpaceLog ifTrue:[ fileStream _ aDirectory newFileNamed: (fName copyFrom: 1 to: (fName lastIndexOf: $.)), 'space'. self printSpaceAnalysisOn: fileStream. fileStream close]. ProgressNotification signal: '3:uncompressedSaveComplete'. (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" aDirectory rename: (tempFileName, FileDirectory dot, 'gz') toBe: fName. aDirectory deleteFileNamed: tempFileName ifAbsent: [] ]. fileStream _ aDirectory newFileNamed: tempFileName. fileStream fileOutChangeSet: aChangeSetOrNil andObject: self. "remember extra structures. Note class names." endMarker _ temp. "append sources" allClassesInRoots _ arrayOfRoots select: [:cls | cls isBehavior]. classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource _ OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. fileStream reopen; setToEnd. fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(Utilities timeStampForMethod: each third) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream close. zipper value. ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'asm 7/2/2003 23:51'! writeForExportWithSourcesGZ: fName inDirectory: aDirectory "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "this is the gzipped version which I have temporarily suspended until I can get resolve the problem with forward references tring to reposition the stream - RAA 11 june 2000" | fileStream temp allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. temp _ endMarker. endMarker _ nil. fileStream _ GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory. fileStream fileOutClass: nil andObject: self. "remember extra structures. Note class names." endMarker _ temp. "append sources" allClassesInRoots _ arrayOfRoots select: [:cls | cls isBehavior]. classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource _ OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [ fileStream reallyClose. "since #close is ignored" ^ self ]. "fileStream reopen; setToEnd." "<--not required with gzipped surrogate stream" fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(Utilities timeStampForMethod: each third) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream reallyClose. "since #close is ignored" ! ! !ImageSegment methodsFor: 'testing' stamp: 'asm 7/2/2003 23:50'! verify: ob1 matches: ob2 knowing: matchDict | priorMatch first | ob1 == ob2 ifTrue: ["If two pointers are same, they must be ints or in outPointers" ((ob1 isMemberOf: SmallInteger) and: [ob1 = ob2]) ifTrue: [^ self]. (ob1 isBehavior and: [ob1 indexIfCompact = ob2 indexIfCompact]) ifTrue: [^ self]. (outPointers includes: ob1) ifTrue: [^ self]. self halt]. priorMatch _ matchDict at: ob1 ifAbsent: [nil]. priorMatch == nil ifTrue: [matchDict at: ob1 put: ob2] ifFalse: [priorMatch == ob2 ifTrue: [^ self] ifFalse: [self halt]]. self verify: ob1 class matches: ob2 class knowing: matchDict. ob1 class isVariable ifTrue: [ob1 basicSize = ob2 basicSize ifFalse: [self halt]. first _ 1. (ob1 isMemberOf: CompiledMethod) ifTrue: [first _ ob1 initialPC]. first to: ob1 basicSize do: [:i | self verify: (ob1 basicAt: i) matches: (ob2 basicAt: i) knowing: matchDict]]. ob1 class instSize = ob2 class instSize ifFalse: [self halt]. 1 to: ob1 class instSize do: [:i | self verify: (ob1 instVarAt: i) matches: (ob2 instVarAt: i) knowing: matchDict]. (ob1 isMemberOf: CompiledMethod) ifTrue: [ob1 header = ob2 header ifFalse: [self halt]. ob1 numLiterals = ob2 numLiterals ifFalse: [self halt]. 1 to: ob1 numLiterals do: [:i | self verify: (ob1 literalAt: i) matches: (ob2 literalAt: i) knowing: matchDict]]! ! Smalltalk removeClassNamed: #AnObsoleteDummyClassBuilderFormatTestSubClass!