'From Cuis 2.0 of 12 February 2010 [latest update: #418] on 17 February 2010 at 11:33:30 pm'!
!classDefinition: #ReferenceStream category: #'System-Object Storage'!
DataStream subclass: #ReferenceStream
	instanceVariableNames: 'references objects currentReference fwdRefEnds blockers skipping insideASegment '
	classVariableNames: 'RefTypes '
	poolDictionaries: ''
	category: 'System-Object Storage'!

!ClassDescription methodsFor: 'initialize-release' stamp: 'jmv 2/17/2010 23:00'!
updateInstancesFrom: oldClass
	"Recreate any existing instances of the argument, oldClass, as instances of 
	the receiver, which is a newly changed class. Permute variables as 
	necessary. Return the array of old instances (none of which should be
	pointed to legally by anyone but the array)."
	"ar 7/15/1999: The updating below is possibly dangerous. If there are any
	contexts having an old instance as receiver it might crash the system if
	the new receiver in which the context is executed has a different layout.
	See bottom below for a simple example:"
	| oldInstances |
	oldInstances _ oldClass allInstances asArray.
	^self updateInstances: oldInstances from: oldClass isMeta: self isMeta.

"	| crashingBlock class |
	class _ Object subclass: #CrashTestDummy
		instanceVariableNames: 'instVar'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Crash-Test'.
	class compile:'instVar: value instVar _ value'.
	class compile:'crashingBlock ^[instVar]'.
	crashingBlock _ (class new) instVar: 42; crashingBlock.
	Object subclass: #CrashTestDummy
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Crash-Test'.
	crashingBlock.
	crashingBlock value.
	"
! !


!Class methodsFor: 'fileIn/Out' stamp: 'jmv 2/17/2010 23:15'!
objectForDataStream: refStrm

	"I am about to be written on an object file.  Write a reference to a class in Smalltalk instead."

	^ DiskProxy global: self theNonMetaClass name selector: #yourself args: #()! !


!ContextPart methodsFor: 'objects from disk' stamp: 'jmv 2/17/2010 23:16'!
storeDataOn: aDataStream
	"Contexts are not allowed go to out in DataStreams.  They must be included inside an ImageSegment."

	self error: 'Contexts are not allowed go to out in DataStreams'.
	^ nil! !


!DataStream methodsFor: 'write and read' stamp: 'jmv 2/17/2010 23:21'!
readWordArrayForSegment
	"Read the contents of a WordArray ignoring endianness."
	"Removed WordArrayForSegment when removed ImageSegment"
"	^ WordArrayForSegment newFromStream: byteStream"
	"Size is number of long words."! !


!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 2/17/2010 23:19'!
initialize
	"TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.  
	Classes named here have special formats in the file.  If such a class has a subclass, it will use type 9 and write correctly.  It will just be slow.  (Later write the class name in the special format, then subclasses can use the type also.)
	 See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"
	"DataStream initialize"

	| refTypes t |
	refTypes _ OrderedCollection new.
	t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing"

	t at: UndefinedObject put: 1.   refTypes add: 0.
	t at: True put: 2.   refTypes add: 0.
	t at: False put: 3.   refTypes add: 0.
	t at: SmallInteger put: 4.	 refTypes add: 0.
	t at: String put: 5.   refTypes add: 1.
	t at: Symbol put: 6.   refTypes add: 1.
	t at: ByteArray put: 7.   refTypes add: 1.
	t at: Array put: 8.   refTypes add: 1.
	"(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)"
		refTypes add: 1.
	"(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"
		refTypes add: 0.
	t at: Bitmap put: 11.   refTypes add: 1.
	t at: Metaclass put: 12.   refTypes add: 0.
	"Type ID 13 is used for HyperSqueak User classes that must be reconstructed."
		refTypes add: 1.
	t at: Float put: 14.  refTypes add: 1.
	t at: Rectangle put: 15.  refTypes add: 1.	"Allow compact Rects."
	"type ID 16 is an instance with short header.  See beginInstance:size:"
		refTypes add: 1.
	t at: String put: 17.   refTypes add: 1.	"new String format, 1 or 4 bytes of length"
	t at: WordArray put: 18.  refTypes add: 1.	"bitmap-like"
	"t at: WordArrayForSegment put: 19.  refTypes add: 1."		"bitmap-like"
	t at: SoundBuffer put: 20.  refTypes add: 1.	"And all other word arrays, both 
		16-bit and 32-bit.  See methods in ArrayedCollection.  Overridden in SoundBuffer."
	t at: CompiledMethod put: 21.  refTypes add: 1.	"special creation method"
	"t at:  put: 22.  refTypes add: 0."
	ReferenceStream refTypes: refTypes.		"save it"

	"For all classes that are like WordArrays, store them the way ColorArray is stored.  As bits, and able to change endianness."
	Smalltalk do: [:cls |
		cls isInMemory ifTrue: [
			cls isBehavior ifTrue: [
				cls isPointers not & cls isVariable & cls isWords ifTrue: [
					(t includesKey: cls) ifFalse: [t at: cls put: 20]]]]].! !


!DiskProxy methodsFor: 'as yet unclassified' stamp: 'jmv 2/17/2010 23:01'!
comeFullyUpOnReload: smartRefStream
	"Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.)  DataStream will substitute the object from this eval for the DiskProxy."
	| globalObj symbol |

	symbol _ globalObjectName.
	"See if class is mapped to another name"
	(smartRefStream respondsTo: #renamed) ifTrue: [
		symbol _ smartRefStream renamed at: symbol ifAbsent: [symbol]].	"map"
	globalObj _ Smalltalk at: symbol ifAbsent: [
		preSelector == nil & (constructorSelector = #yourself) ifTrue: [
			Transcript cr; show: symbol, ' is undeclared.'.
			(Undeclared includesKey: symbol) ifTrue: [^ Undeclared at: symbol].
			Undeclared at: symbol put: nil.
			^ nil].
		^ self error: 'Global "', symbol, '" not found'].

	preSelector ifNotNil: [
		Symbol hasInterned: preSelector ifTrue: [:selector |
			globalObj _ globalObj perform: selector]].

	constructorSelector ifNil: [^ globalObj].
	Symbol hasInterned: constructorSelector ifTrue: [:selector |
		^ globalObj perform: selector
				withArguments: constructorArgs].
				"args not checked against Renamed"
	^ nil 	"was not in proper form"! !


!ReferenceStream methodsFor: 'writing' stamp: 'jmv 2/17/2010 23:16'!
setStream: aStream
	"PRIVATE -- Initialization method."

	super setStream: aStream.
	references _ IdentityDictionary new: 4096 * 5.
	objects _ IdentityDictionary new: 4096 * 5.
	fwdRefEnds _ IdentityDictionary new.
	skipping _ IdentitySet new.
	blockers ifNil: [blockers _ IdentityDictionary new].	"keep blockers we just passed in"
! !

!ReferenceStream methodsFor: 'writing' stamp: 'jmv 2/17/2010 23:16'!
setStream: aStream reading: isReading
	"PRIVATE -- Initialization method."

	super setStream: aStream reading: isReading.
	"isReading ifFalse: [  when we are sure"
	references _ IdentityDictionary new: 4096 * 5.
	isReading ifTrue: [
		objects _ IdentityDictionary new: 4096 * 5.
		skipping _ IdentitySet new.
		fwdRefEnds _ IdentityDictionary new].
	blockers ifNil: [blockers _ IdentityDictionary new].	"keep blockers we just passed in"
! !


!SmartRefStream methodsFor: 'read write' stamp: 'jmv 2/17/2010 23:04'!
instVarInfo: anObject
	"Return the object to write on the outgoing file that contains the structure of each class we are about to write out.  Must be an Array whose first element is 'class structure'.  Its second element is a Dictionary of pairs of the form #Rectangle -> #(<classVersion> 'origin' 'corner').  "

	"Make a pass through the objects, not writing, but recording the classes.  Construct a database of their inst vars and any version info (classVersion)."

	| dummy refs cls newSupers |
	structures _ Dictionary new.
	superclasses _ Dictionary new.
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	refs _ dummy references.
	objCount _ refs size.		"for progress bar"
		"Note that Dictionary must not change its implementation!!  If it does, how do we read this reading information?"
	refs keysDo: [:each | 
		cls _ each class.
		"cls isObsolete ifTrue: [self error: 'Trying to write ', cls name]."
		(cls class ~~ Metaclass) & (cls isObsolete not) ifTrue: [
			structures at: cls name put: false]].
	"Save work by only computing inst vars once for each class"
	newSupers _ Set new.
	structures at: #Point put: false.	"writeRectangle: does not put out class pointer"
	structures at: #Rectangle put: false.
	structures at: #LargePositiveInteger put: false.	"used in slow case of WordArray"
	structures keysDo: [:nm | 
		cls _ (nm endsWith: ' class') 
			ifFalse: [Smalltalk at: nm]
			ifTrue: [(Smalltalk at: nm substrings first asSymbol) class].
		cls allSuperclasses do: [:aSuper |
			structures at: aSuper name ifAbsent: [newSupers add: aSuper name]]].
			"Don't modify structures during iteration"
	newSupers do: [:nm | structures at: nm put: 3].	"Get all superclasses into list"
	structures keysDo: [:nm | "Nothing added to classes during loop"
		cls _ (nm endsWith: ' class') 
			ifFalse: [Smalltalk at: nm]
			ifTrue: [(Smalltalk at: nm substrings first asSymbol) class].
		structures at: nm put: 
			((Array with: cls classVersion), (cls allInstVarNames)).
		superclasses at: nm ifAbsent: [
				superclasses at: nm put: cls superclass name]].
	^ (Array with: 'class structure' with: structures with: 'superclasses' with: superclasses)! !


!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/17/2010 23:05'!
saveAsEmbeddedImage
	"Save the current state of the system as an embedded image"

	| dir newName newImageName |
	dir _ FileDirectory default.
	newName _ FillInTheBlank
		request: 'Select existing VM file'
		initialAnswer: (FileDirectory localNameFor: '').
	newName = '' ifTrue: [^ self].
	newName _ FileDirectory baseNameFor: newName asFileName.

	newImageName _ newName.
	(dir includesKey: newImageName) ifFalse:
		[^ self inform: 'Unable to find name ', newName, ' Please choose another name.'].

	self logChange: '----SAVEAS (EMBEDDED) ', newName, '----', Date dateAndTimeNow printString.
	self imageName: (dir fullNameFor: newImageName).
	LastImageName _ self imageName.
	self closeSourceFiles.
	self snapshot: true andQuit: true embedded: true
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/17/2010 23:06'!
saveImageInFileNamed: aString
	self 
		changeImageNameTo: (FileDirectory default fullNameFor: aString);
		closeSourceFiles; openSourceFiles;  "so SNAPSHOT appears in new changes file"
		snapshot: true andQuit: false.! !

!SystemDictionary methodsFor: 'toDeprecate' stamp: 'jmv 2/17/2010 23:07'!
snapshot: save andQuit: quit embedded: embeddedFlag 
	"Mark the changes file and close all files as part of #processShutdownList.
	If save is true, save the current state of this Smalltalk in the image file.
	If quit is true, then exit to the outer OS shell.
	The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up."

	| resuming msg |
	Object flushDependents.
	Object flushEvents.
	(SourceFiles at: 2) ifNotNil: 
			[msg := String streamContents: 
							[:s | 
							s
								nextPutAll: '----';
								nextPutAll: (save 
											ifTrue: [quit ifTrue: ['QUIT'] ifFalse: ['SNAPSHOT']]
											ifFalse: [quit ifTrue: ['QUIT/NOSAVE'] ifFalse: ['NOP']]);
								nextPutAll: '----';
								print: Date dateAndTimeNow;
								space;
								nextPutAll: (FileDirectory default localNameFor: self imageName);
								nextPutAll: ' priorSource: ';
								print: LastQuitLogPosition].
			self assureStartupStampLogged.
			save 
				ifTrue: 
					[LastQuitLogPosition _ ((SourceFiles at: 2)
								setToEnd;
								position)].
			self logChange: msg.
			Transcript
				cr;
				show: msg].
	self processShutDownList: quit.
	Cursor write show.
	save 
		ifTrue: 
			[resuming := embeddedFlag 
						ifTrue: [self snapshotEmbeddedPrimitive]
						ifFalse: [self snapshotPrimitive].	"<-- PC frozen here on image file"
			]
		ifFalse: [resuming := false].
	quit & (resuming == false) ifTrue: [self quitPrimitive].
	Cursor normal show.
	self setGCParameters.
	resuming == true ifTrue: [self clearExternalObjects].
	self processStartUpList: resuming == true.
	resuming == true 
		ifTrue: 
			[self setPlatformPreferences.
			self readDocumentFile].
	SystemWindow wakeUpTopWindowUponStartup.
	"Now it's time to raise an error"
	resuming == nil 
		ifTrue: [self error: 'Failed to write image file (disk full?)'].
	^resuming! !


!SystemDictionary class methodsFor: 'initialization' stamp: 'jmv 2/17/2010 23:07'!
initialize
	"SystemDictionary initialize"

	| oldList |
	oldList := StartUpList.
	StartUpList := OrderedCollection new.
	"These get processed from the top down..."
	#(
		#Delay 
		#DisplayScreen 
		#Cursor 
		#InputSensor 
		#ProcessorScheduler 	"Starts low space watcher and bkground."
		#FileDirectory 			"Enables file stack dump and opens sources."
		#ShortIntegerArray 
		#ShortRunArray)
			do: [ :clsName | 	
				Smalltalk at: clsName ifPresent: [:cls | Smalltalk addToStartUpList: cls]].

	oldList ifNotNil: [
		oldList do: [ :className | 
			Smalltalk 
				at: className
				ifPresent: [:theClass | Smalltalk addToStartUpList: theClass]]].

	#(
		#PasteUpMorph) 
			do:  [ :clsName | 
				Smalltalk at: clsName ifPresent: [:cls | Smalltalk addToStartUpList: cls]].
			
	oldList := ShutDownList.
	ShutDownList := OrderedCollection new.
	"These get processed from the bottom up..."
	#(
		#Delay 
		#DisplayScreen 
		#InputSensor 
		#Form 
		#PasteUpMorph 
		#StrikeFont 
		#Color 
		#FileDirectory 
		#SoundPlayer ) 
			do: [ :clsName | 
				Smalltalk at: clsName ifPresent: [:cls | Smalltalk addToShutDownList: cls]].

	oldList ifNotNil: [
		oldList reverseDo: [ :className | 
			Smalltalk 
				at: className
				ifPresent: [:theClass | Smalltalk addToShutDownList: theClass]]]! !

SystemDictionary initialize!
SystemDictionary removeSelector: #computeImageSegmentation!
SystemDictionary removeSelector: #saveImageSegments!
SystemDictionary removeSelector: #writeImageSegmentsFrom:withKernel:!
SmartRefStream removeSelector: #recordImageSegment:!
ReferenceStream removeSelector: #insideASegment!
ReferenceStream removeSelector: #insideASegment:!
!classDefinition: #ReferenceStream category: #'System-Object Storage'!
DataStream subclass: #ReferenceStream
	instanceVariableNames: 'references objects currentReference fwdRefEnds blockers skipping'
	classVariableNames: 'RefTypes'
	poolDictionaries: ''
	category: 'System-Object Storage'!
Metaclass removeSelector: #allInstancesEverywhereDo:!
DataStream initialize!
ClassCommentReader removeSelector: #scanFromNoCompile:!
ClassCategoryReader removeSelector: #scanFromNoCompile:!
ClassCategoryReader removeSelector: #scanFromNoCompile:forSegment:!
Character removeSelector: #objectForDataStream:!
Behavior removeSelector: #allInstancesEverywhereDo:!
Behavior removeSelector: #rootStubInImageSegment:!
Object removeSelector: #rootStubInImageSegment:!
Smalltalk removeClassNamed: #ImageSegment!
Smalltalk removeClassNamed: #ImageSegmentRootStub!
Smalltalk removeClassNamed: #WordArrayForSegment!
"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
DataStream initialize!

