cleanup-moshi-image-methods.st

'From Moshi of 3 March 2007 [latest update: #1914] on 27 December 2010 at 11:40:40 pm'!
Object subclass: #MTestCase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MSqueak-Tests'!

!CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:41'!
decompiledSourceIntoContentsWithTempNames: showTempNames 
	"Obtain a source string by decompiling the method's code, and place 
	that source string into my contents.
	Also return the string.
	Get temps from source file if showTempNames is true."

	| tempNames class selector method |
	class := self selectedClassOrMetaClass.
	selector := self selectedMessageName.
	"Was method deleted while in another project?"
	method := class compiledMethodAt: selector ifAbsent: [^ ''].

	currentCompiledMethod := method.
	(showTempNames not
			or: [method fileIndex > 0
					and: [(SourceFiles at: method fileIndex) isNil]])
		ifTrue: [
			"Emergency or no source file -- decompile without temp names "
			contents := (class decompilerClass new
						decompile: selector
						in: class
						method: method) decompileString]
		ifFalse: [tempNames := (class compilerClass new
						parse: method getSourceFromFile asString
						in: class
						notifying: nil) tempNames.
			contents := ((class decompilerClass new withTempNames: tempNames)
						decompile: selector
						in: class
						method: method) decompileString].
	contents := contents asText makeSelectorBoldIn: class.
	^ contents copy! !


!CompiledMethod methodsFor: 'decompiling' stamp: 'yo 12/27/2010 23:21'!
methodNodeDecompileClass: aClass selector: selector
	"Return the parse tree that represents self"

	| source |
	^ ((source _ self getSourceFromFile) isNil or: [
		false or: [(OMeta2RuleParser isOMeta2Rule: source asString) or: [false]]]) ifTrue: [
			self decompileClass: aClass selector: selector
		] ifFalse: [
			self parserClass new parse: source class: (aClass ifNil: [self sourceClass])]
! !


!MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'yo 12/27/2010 23:30'!
buildSpecialObjectsArray
	"Build and answer the 'special objects' array, an array of all the objects needed by the Smalltalk virtual machine."

	| compactClasses specialObjects newSystem |
	compactClasses _ self buildCompactClassArray.
	newSystem := self newSystem.

	specialObjects _ Array new: 48.
	specialObjects at: 1 put: nil.
	specialObjects at: 2 put: false.
	specialObjects at: 3 put: true.
	specialObjects at: 4 put: (globals associationAt: #Processor).
	specialObjects at: 5 put: nil.  "Bitmap"
	specialObjects at: 6 put: (globals at: #SmallInteger).
	specialObjects at: 7 put: (globals at: #ByteString).
	specialObjects at: 8 put: (globals at: #Array).
	specialObjects at: 9 put: newSystem. 
	specialObjects at: 10 put: (globals at: #Float ifAbsent: [nil]).
	specialObjects at: 11 put: (globals at: #MethodContext).
	specialObjects at: 12 put: (globals at: #BlockContext).
	specialObjects at: 13 put: (globals at: #Point).
	specialObjects at: 14 put: (globals at: #LargePositiveInteger).
	specialObjects at: 15 put: nil.  "Display"
	specialObjects at: 16 put: (globals at: #Message).
	specialObjects at: 17 put: (globals at: #CompiledMethod).
	specialObjects at: 18 put: nil.  "low space Semaphore"
	specialObjects at: 19 put:  nil. "(globals at: #Semaphore)"
	specialObjects at: 20 put: (globals at: #Character).
	specialObjects at: 21 put: #doesNotUnderstand:.
	specialObjects at: 22 put: #cannotReturn:.
	specialObjects at: 23 put: nil.  "unused"

	"the 32 selectors that are compiled as special bytecodes, with the number of arguments of each"
	specialObjects at: 24 put: #(
		+ 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 @ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1
		at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 blockCopy: 1 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0).

	specialObjects at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).  "table of Characters in ascii order"
	"Sets the same value to the Character's CharacterTable class var."
	specialObjects at: 26 put: #mustBeBoolean.
	specialObjects at: 27 put: (globals at: #ByteArray).
	specialObjects at: 28 put: (globals at: #Process).
	specialObjects at: 29 put: compactClasses.  "array of up to 31 classes whose instances can have compact headers"
	specialObjects at: 30 put: nil.  "delay semaphore"
	specialObjects at: 31 put: nil.  "user input semaphore"

	"Prototype instances that can be copied for fast initialization"
	specialObjects at: 32 put:
		((globals includesKey: #Float) ifTrue: [Float new: 2] ifFalse: [LargePositiveInteger new: 4]).
	specialObjects at: 33 put: (LargePositiveInteger new: 4).
	specialObjects at: 34 put: (Association new). "replacement for Point new"
	specialObjects at: 35 put: #cannotInterpret:.

	"Note: This must be fixed once we start using context prototypes"
	specialObjects at: 36 put: ((globals at: #MethodContext) new: 56).  "size is CompiledMethod fullFrameSize"
	specialObjects at: 37 put: nil.
	specialObjects at: 38 put: ((globals at: #BlockContext) new: 56).  "size is CompiledMethod fullFrameSize"

	specialObjects at: 39 put: Array new.  "array of objects referred to by C support code"
	specialObjects at: 40 put: nil.  "was PseudoContext"
	specialObjects at: 41 put: nil.  "was TranslatedMethod"
	specialObjects at: 42 put: nil.  "finalization Semaphore"
	specialObjects at: 43 put: (globals at: #LargeNegativeInteger).

	"44-48 are are reserved for the foreign function interface (they are nil here)"

	^ specialObjects
! !

!MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'yo 12/27/2010 23:31'!
checkLayoutOfVMClasses
	"Verify that the layout of classes that the VM depends on is the same as the corresponding Squeak class."
	"MicroSqueakImageBuilder new checkLayoutOfVMClasses"

	| sClass mClass |
	#(	Behavior
		MethodDictionary
		Association
		BlockContext
		MethodContext
		Array
		ByteArray
		ByteString
		Character
		ByteSymbol
		Dictionary
		LargePositiveInteger
		LargeNegativeInteger
		Float
		Point
		Process
		ProcessorScheduler
	) do: [:n |
		sClass _ Smalltalk at: n.
		mClass _ Smalltalk at: ('M', n) asSymbol ifAbsent: [nil].
		mClass ifNotNil: [
			(sClass instSpec = mClass instSpec) ifFalse: [self error: 'Bad VM class layout: ', n]]].

	"compiled method is special"
	((MCompiledMethod instSpec = 8) & (MCompiledMethod instSize = 0)) ifFalse: [self error: 'Bad VM class layout: CompiledMethod'].! !


!MSystem class methodsFor: 'system startup' stamp: 'yo 12/27/2010 23:28'!
start
	"This method is called when the image is started. Add a call to your own code here."
	| doc strm save |
	(doc := self getSystemAttribute: 2) ifNil: [
		self runAllTests.
		self welcomeMessage.
		Object superclass ifNil: [self quit].  "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!"
	].

	System log: 'doc: ', doc.
	(doc endsWith: '.sto') ifTrue: [
		Symbol initialize.
		strm := (File new openReadOnly: doc) contentsOfEntireFile asByteArray readStream.
		BootStrapReader new readAllFrom: strm.
		System log: doc, ' loaded.'.
	] ifFalse: [
		strm := (File new openReadOnly: doc) contentsOfEntireFile readStream.
		strm chunksDo: [:pre :body |
			self processChunk: pre body: body]
	].

	save := (self getSystemAttribute: 3) notNil.
	save ifTrue: [
		doc := strm :=  save := nil.
		self snapshot: true andQuit: true.
		Processor restartStartProcess].
	Object superclass ifNil: [self quit].! !

!MSystem class methodsFor: 'primitives' stamp: 'yo 12/27/2010 23:28'!
snapshot: save andQuit: quit
	"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 |

	save ifTrue: [
		resuming _ self snapshot.  "<-- PC frozen here on image file"].
	quit & (resuming == false) ifTrue: [self quit].
	"Now it's time to raise an error"
	resuming == nil ifTrue: [self error:'Failed to write image file (disk full?)'].
	^ resuming! !


!SecurityManager methodsFor: 'initialize-release' stamp: 'yo 12/27/2010 23:22'!
startUp
	"Attempt to load existing keys"
	self loadSecurityKeys.
	(privateKeyPair == nil 
		and: [self isInRestrictedMode not
		and: [false
		and: [Preferences automaticKeyGeneration]]]) ifTrue:[
			self loadOLPCOwnerKey.
			privateKeyPair == nil ifTrue: 
				[self generateKeyPairInBackground]].! !

MSystem class removeSelector: #boxTest!
MSystem class removeSelector: #canvasTest!
MSystem class removeSelector: #getchar!
MSystem class removeSelector: #geziraTest!
MSystem class removeSelector: #glyphTest!
MSystem class removeSelector: #graphicsTest!
MSystem class removeSelector: #mouseTest!
MSystem class removeSelector: #primGetNextEvent:!
MSystem class removeSelector: #startEventFetcher!
MSystem class removeSelector: #textTest!
MSequenceableCollection removeSelector: #asFloatArray!
MPoint removeSelector: #extent:!
Smalltalk removeClassNamed: #MDelay!
Smalltalk removeClassNamed: #MGeziraTest!
Smalltalk removeClassNamed: #MSemaphore!
Smalltalk removeClassNamed: #MSharedQueue!