rsqueak-hotfixes.1.cs

'From Squeak5.0 of 15 January 2016 [latest update: #15117] on 4 February 2016 at 1:52:02 pm'!
Object subclass: #RSqueak
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'RSqueak'!

!AutoStart class methodsFor: 'initialization' stamp: 'tfel 2/4/2016 13:09'!
startUp: resuming
	"The image is either being newly started (resuming is true), or it's just been snapshotted.
	If this has just been a snapshot, skip all the startup stuff."

	| startupParameters launchers |
	RSqueak isRSqueak ifTrue: [^ self].
	self active ifTrue: [^self].
	self active: true.
	resuming ifFalse: [^self].

	HTTPClient determineIfRunningInBrowser.
	startupParameters := Smalltalk namedArguments.
	(startupParameters includesKey: 'apiSupported' asUppercase )
		ifTrue: [
			HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE').
			HTTPClient isRunningInBrowser
				ifFalse: [HTTPClient isRunningInBrowser: true]].
	"Some images might not have the UpdateStream package."
	((self respondsTo: #checkForUpdates) and: [self checkForUpdates]) ifTrue: [^self].
	self checkForPluginUpdate.
	launchers := self installedLaunchers collect: [:launcher |
		launcher new].
	launchers do: [:launcher |
		launcher parameters: startupParameters].
	launchers do: [:launcher |
		Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp]]]! !


!BalloonEngine methodsFor: 'copying' stamp: 'tfel 2/4/2016 13:45'!
copyLoopFaster
	"This is a copy loop drawing one scan line at a time"
	| edge fill reason |
	edge := BalloonEdgeData new.
	fill := BalloonFillData new.
	RSqueak isRSqueak ifFalse: [
	[self primFinishedProcessing] whileFalse:[
		reason := self primRenderScanline: edge with: fill.
		"reason ~= 0 means there has been a problem"
		reason = 0 ifFalse:[
			self processStopReason: reason edge: edge fill: fill.
		].
	].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !


!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'tfel 2/4/2016 13:29'!
setupColorMasksFrom: srcBits to: targetBits
	"Setup color masks for converting an incoming RGB pixel value from srcBits to targetBits."
	| mask shifts masks deltaBits |
	<var: #shifts declareC:'static int shifts[4] = {0, 0, 0, 0}'>
	<var: #masks declareC:'static unsigned int masks[4] = {0, 0, 0, 0}'>
	self cCode:'' inSmalltalk:[
		shifts := CArrayAccessor on: (IntegerArray new: 4).
		masks := CArrayAccessor on: (WordArray new: 4).
	].
	deltaBits := targetBits - srcBits.
	deltaBits = 0 ifTrue:[^0].
	deltaBits <= 0
		ifTrue:[	mask := 1 << targetBits - 1.
				"Mask for extracting a color part of the source"
				masks at: RedIndex put: mask << (srcBits*2 - deltaBits).
				masks at: GreenIndex put: mask << (srcBits - deltaBits).
				masks at: BlueIndex put: mask << (0 - deltaBits).
				masks at: AlphaIndex put: 0.
				deltaBits := 0 - deltaBits]
		ifFalse:[	mask := 1 << srcBits - 1.
				"Mask for extracting a color part of the source"
				masks at: RedIndex put: mask << (srcBits*2).
				masks at: GreenIndex put: mask << srcBits.
				masks at: BlueIndex put: mask].

	"Shifts for adjusting each value in a cm RGB value"
	shifts at: RedIndex put: deltaBits * 3.
	shifts at: GreenIndex put: deltaBits * 2.
	shifts at: BlueIndex put: deltaBits.
	shifts at: AlphaIndex put: 0.

	cmShiftTable := shifts.
	cmMaskTable := masks.
	cmFlags := cmFlags bitOr: (ColorMapPresent bitOr: ColorMapFixedPart).
! !


!Cursor class methodsFor: 'instance creation' stamp: 'tfel 2/4/2016 13:31'!
resizeForEdge: aSymbol
	"Cursor resizeForEdge: #top"
	"Cursor resizeForEdge: #bottomLeft"
	RSqueak isRSqueak ifTrue: [^ self].
	^self perform: ('resize', aSymbol first asString asUppercase, (aSymbol copyFrom: 2 to: aSymbol size)) asSymbol.! !


!Debugger class methodsFor: '*Morphic-opening' stamp: 'tfel 2/4/2016 13:18'!
morphicOpenOn: process context: context label: title contents: contentsStringOrNil fullView: bool
	"Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."

	| errorWasInUIProcess debugger |
	errorWasInUIProcess := Project current spawnNewProcessIfThisIsUI: process.
	RSqueak p: context longStack.
	[Preferences logDebuggerStackToFile
		ifTrue: [Smalltalk logSqueakError: title inContext: context]] on: Error do: [:ex | ex return: nil].
	WorldState addDeferredUIMessage: [ 
		"schedule debugger in deferred UI message to address redraw
		problems after opening a debugger e.g. from the testrunner."
		[
			debugger := self new process: process controller: nil context: context.
			bool
				ifTrue: [debugger openFullNoSuspendLabel: title]
				ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title].
			debugger errorWasInUIProcess: errorWasInUIProcess.
		] on: Error do: [:ex |
				self primitiveError: 
					'Original error: ', 
					title asString, '.
	Debugger error: ', 
				([ex description] on: Error do: ['a ', ex class printString]), ':'
			]
	].
	process suspend.
! !


!HandMorph methodsFor: 'cursor' stamp: 'tfel 2/4/2016 13:42'!
showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset 
	"Set the temporary cursor to the given Form.
	If the argument is nil, revert to the normal hardware cursor."
	RSqueak isRSqueak ifTrue: [^ self].
	self changed.
	temporaryCursorOffset 
		ifNotNil: [bounds := bounds translateBy: temporaryCursorOffset negated].
	cursorOrNil isNil 
		ifTrue: [temporaryCursor := temporaryCursorOffset := hardwareCursor := nil]
		ifFalse: 
			[temporaryCursor := cursorOrNil asCursorForm.
			temporaryCursorOffset := temporaryCursor offset - hotSpotOffset.
			(cursorOrNil isKindOf: Cursor) ifTrue: [hardwareCursor := cursorOrNil]].
	bounds := self cursorBounds.
	self
		userInitials: userInitials andPicture: self userPicture;
		layoutChanged;
		changed;
		showHardwareCursor: (temporaryCursor isNil).! !


!RSqueak class methodsFor: 'as yet unclassified' stamp: 'tfel 2/4/2016 13:09'!
isRSqueak

	<primitive: 'isRSqueak' module: 'VMDebugging'>
	^ false! !

!RSqueak class methodsFor: 'as yet unclassified' stamp: 'tfel 2/4/2016 13:03'!
p: anObject

	self privp: anObject asString.! !

!RSqueak class methodsFor: 'as yet unclassified' stamp: 'tfel 2/4/2016 13:04'!
privp: aString

	<primitive: 'debugPrint' module: 'VMDebugging'>! !


!SmallInteger class methodsFor: 'class initialization' stamp: 'tfel 2/4/2016 13:06'!
startUp: resuming
	"The image is either being newly started (resuming is true), or it's just been snapshotted.
	 If this has just been a snapshot, skip all the startup stuff."
	| next val |
	resuming ifFalse: [^self].
	val := -32768. "Assume at least 16 bits"
	[next := val + val.
	RSqueak p: next; p: next class.
	 next class == self] whileTrue:
		[val := next].
	RSqueak p: '==========='.
	minVal := val / 2.
	maxVal := -1 - minVal.
	RSqueak 
			p: minVal;
			p: maxVal;
			p: '==========='.! !


!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'tfel 2/4/2016 13:08'!
send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument
	"Send the message #startUp: or #shutDown: to each class named in the list.
	The argument indicates if the system is about to quit (for #shutDown:) or if
	the image is resuming (for #startUp:).
	If any name cannot be found, then remove it from the list."

	| removals |
	removals := OrderedCollection new.
	startUpOrShutDownList do:
		[:name | | class |
		RSqueak p: name.
		class := self at: name ifAbsent: [nil].
		class == nil
			ifTrue: [removals add: name]
			ifFalse: [class isInMemory ifTrue:
						[class perform: startUpOrShutDown with: argument]]].

	"Remove any obsolete entries, but after the iteration"
	startUpOrShutDownList removeAll: removals! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'tfel 2/4/2016 13:10'!
snapshot: save andQuit: quit withExitCode: exitCode 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.
	If exitCode is not nil, then use it as exit code.
	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
	].

	Smalltalk processShutDownList: quit.
	Cursor write show.
	save ifTrue: [resuming := embeddedFlag 
					ifTrue: [self snapshotEmbeddedPrimitive] 
					ifFalse: [self snapshotPrimitive].  "<-- PC frozen here on image file"
				resuming == false "guard against failure" ifTrue:
					["Time to reclaim segment files is immediately after a save"
					Smalltalk at: #ImageSegment
						ifPresent: [:theClass | theClass reclaimObsoleteSegmentFiles]]]
		ifFalse: [resuming := false].
	quit & (resuming == false) ifTrue: [
		exitCode
			ifNil: [ self quitPrimitive ]
			ifNotNil: [ self quitPrimitive: exitCode ] ].
	Cursor normal show.
	Smalltalk setGCParameters.
	resuming == true ifTrue: [Smalltalk clearExternalObjects].
	Smalltalk processStartUpList: resuming == true.
	resuming == true ifTrue:[
		self setPlatformPreferences.
		self recordStartupStamp].
	RSqueak p: 'waking up'.
	Project current wakeUpTopWindow.
	"Now it's time to raise an error"
	resuming == nil ifTrue: [self error:'Failed to write image file (disk full?)'].
	^ resuming! !