'From Squeak4.1 of 17 April 2010 [latest update: #9957] on 17 April 2010 at 5:22:05 pm'!


----STARTUP----{17 April 2010 . 5:21:54 pm} as C:\Squeak\4.0\4.1-final\Squeak4.1.image!


Smalltalk appendChangesTo: 'SqueakV41.sources'.!

----QUIT----{17 April 2010 . 5:22:11 pm} Squeak4.1.image priorSource: 89!

----STARTUP----{23 January 2011 . 2:40 pm} as /Users/piumarta/squeak/Squeak4.1.image!


SystemOrganization addCategory: #'VMMaker-Building'!

SystemOrganization addCategory: #'VMMaker-Interpreter'!

SystemOrganization addCategory: #'VMMaker-InterpreterSimulation'!

SystemOrganization addCategory: #'VMMaker-Plugins'!

SystemOrganization addCategory: #'VMMaker-SmartSyntaxPlugins'!

SystemOrganization addCategory: #'VMMaker-Translation to C'!

SystemOrganization addCategory: #'VMMaker-Tests'!
!ParseNode methodsFor: '*VMMaker-C translation' stamp: 'dtl 10/12/2010 19:40'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"

	^TNotImplementedNode new parseNode: self! !
!CascadeNode methodsFor: '*VMMaker-C translation' stamp: 'eem 10/2/2009 11:26'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"
	^TStmtListNode new
		setArguments: #()
		statements:
			(Array streamContents:
				[:s| | receiverNode |
				receiverNode := receiver asTranslatorNodeIn: aTMethod.
				receiverNode isLeaf ifFalse:
					[| varNode |
					 varNode := aTMethod newCascadeTempFor: receiverNode.
					 s nextPut: (TAssignmentNode new
								setVariable: varNode
								expression: receiverNode).
					receiverNode := varNode].
				messages do:
					[ :msg | s nextPut: ((msg asTranslatorNodeIn: aTMethod) receiver: receiverNode)]]);
		comment: comment! !

Model subclass: #VMMakerTool
	instanceVariableNames: 'vmMaker allPluginsList allPluginsSelection allPluginsSelectionsArray internalPluginsList internalPluginsSelection internalPluginsSelectionsArray externalPluginsList externalPluginsSelection externalPluginsSelectionsArray logger interpreterClassMorph platformPathMorph platformNameMorph generatedPathMorph configFileName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!VMMakerTool commentStamp: '<historical>' prior: 0!
VMMakerTool help information
------------------------------------
If you really get stuck, send mail to the Squeak mailing list, squeak-dev@lists.squeakfoundation.org

	VMMakerTool openInWorld

What this is
--------------
This tool is a simple interactive interface to VMMaker. You can change the directory paths for where the system looks for the platform files (those C files that are handwritten for each platform) and where it will put the assembled sources (the appropriate platform files and generated files) ready for you to compile into a new vm. You can change the platform for which it will generate files. You can choose which plugins are built and whether they are built for internal or external use. 

How to use it
---------------
To build a configuration, drag plugins from the leftmost  'Plugins not built' list to either the 'Internal Plugins' list or the 'External Plugins' list.  Plugins that cannot be built on your machine due to missing files will not be draggable.
Once you have a configuration, you can save it for later retrieval by pressing the 'Save Configuration' button. Unsurprisingly you can reload a saved configuration with the 'Load Configuration' button.

To generate an entire code tree, press the 'Generate All' button. This will process all the vm and plugin files needed for your configuration. To generate only the files for the vm and any internal plugins, use the 'Generate Core VM' button. This will be most useful if you are experimenting with the design of the vm internals or new object memory layouts etc. The 'Generate External Plugins' button will regenerate all the plugins in the External Plugins list. Note that 'excess' directories will be deleted each time you generate the vm in order to reduce potential confusion if you move a plugin from internal to external etc. If you repeatedly generate the vm only the files that appear to be out of date will be recreated; this drastically reduces the time taken if you have only changed a single plugin class for example.

You can also generate internal or external plugins singly, using the menus in the lists but be warned - internal plugins are tightly related to the generated file 'vm/sqNamedPrims.h' and adding or removing an internal plugin without regenerating this (via 'Generate Core VM' or 'Generate All') will cause much grief. The application attempts to prevent this, but there are surely ways to confuse both yourself and the code. In general when writing experimental plugins it is much simpler to build them as external during the development cycle. 

If the default path for the platforms code is not correct for your machine you can use the 'Find Path' button to search for a plausible directory. Note that this could take an arbitrarily long time on a machine with connections to other machines since you may end up searching all their disc space as well.

You can choose from a menu of all known platforms (at least, all those known in the set of files on your machine) by using the 'Find platform' button. This is useful if you want to generate files for some other platform and feel uncertain of the exact spelling. By default the platform will be set to that upon which you are running.

If you feel the need to delete all the generated files you can press the 'Clean out' button - this will recursively delete everything below the path for the generated sources.

Details
-------
You really ought to read the class comment for VMMaker. Really. Go on, do it now.

Errors
-------
A number of errors are possible, mostly relating to the two directory paths and the platform name. As much as possible these are trapped and you will see 'inform' menus to let you know. Inevitably, if you put in the effort, you will be able to confuse the tool and break it.
!
!VMMakerTool class methodsFor: 'instance creation' stamp: 'tbn 5/25/2010 19:03'!
initialize

	Smalltalk at: #TheWorldMenu ifPresent: [ :class |
		class class methodDict at: #registerOpenCommand: ifPresent: [ :method |
			(method sendsSelector: #deprecated:) 
				ifFalse: [ class registerOpenCommand: (Array with: 'VMMaker' with: (Array with: self with: #openInWorld)) ] ] ]! !
!VMMakerTool class methodsFor: 'world menu' stamp: 'tbn 5/25/2010 18:58'!
menuCommandOn: aBuilder 
	<worldMenu> 
	(aBuilder item: #'VMMaker')
		parent: #Tools;
		action:[self openInWorld]! !
!VMMakerTool class methodsFor: 'instance creation'!
openInWorld
	"Build a VMMakerTool and open it"
	"VMMakerTool openInWorld"

	^self new buildWindow openInWorld! !
!VMMakerTool class methodsFor: 'unloading' stamp: 'tbn 5/25/2010 19:02'!
unload
	Smalltalk at: #TheWorldMenu ifPresent: [ :class |
		class class methodDict at: #unregisterOpenCommandWithReceiver: ifPresent: [ :method |
			(method sendsSelector: #deprecated:) 
				ifFalse: [ class unregisterOpenCommandWithReceiver: self ] ] ]! !
!VMMakerTool methodsFor: 'drag and drop' stamp: 'nk 4/5/2005 23:02'!
acceptDroppingMorph: transferMorph event: evt inMorph: aMorph
	"Here we are fetching information from the dropped transferMorph and performing the correct action for this drop.
	As long as the source is part of this tool, move the dragged item from the source list to the destination list"

	^self moveItem: transferMorph passenger from: transferMorph source to: aMorph! !
!VMMakerTool methodsFor: 'window construction' stamp: 'dtl 5/27/2010 21:25'!
addSecondButtonRowToWindow: sysWin startingAt: initialVerticalOffset 
	| verticalOffset box |
	verticalOffset := initialVerticalOffset.
	"add a row of buttons to start up various actions"
	box := AlignmentMorph new vResizing: #shrinkWrap;  layoutInset: 6@3; cellInset: 6@0; wrapCentering: #center.
	box addMorph: (TextMorph new contents: 'Generate:' translated asText allBold) lock.
	box addMorphBack: (SimpleButtonMorph new target: self;
			 label: 'Entire';
			 actionSelector: #generateAll;
			 hResizing: #spaceFill;
			 setBalloonText: 'Generate the sources for the core VM and all chosen internal and external plugins').
	box addMorphBack: (SimpleButtonMorph new target: self;
			 label: 'Core+Internal';
			 actionSelector: #generateCore;
			 hResizing: #spaceFill;
			 setBalloonText: 'Generate the sources for the core vm and any internal plugins').

	box addMorphBack: (SimpleButtonMorph new target: self;
			 label: 'External Plugins';
			 actionSelector: #generateExternal;
			 hResizing: #spaceFill;
			 setBalloonText: 'Generate the sources for all external plugins').
	sysWin
		addMorph: box
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 0)
				offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset := verticalOffset + box height - 1))).

	^verticalOffset.! !
!VMMakerTool methodsFor: 'window construction' stamp: 'dtl 10/24/2009 10:00'!
addTopButtonRowToWindow: sysWin
	| verticalOffset box |
	verticalOffset := 0.

	"add a row of buttons to start up various actions"
	box := AlignmentMorph new vResizing: #shrinkWrap;
				 layoutInset: 6 @ 3;
				 cellInset: 6 @ 0;
				 wrapCentering: #center.
	box addMorphBack: (SimpleButtonMorph new target: self;
			 label: 'Help';
			 actionSelector: #helpText;
			 hResizing: #spaceFill;
			 setBalloonText: 'Open the help window').
	box addMorphBack: (TextMorph new contents: 'Configuration File:' translated asText allBold) lock.	
	box addMorphBack: (SimpleButtonMorph new target: self;
			 label: 'Load';
			 actionSelector: #loadConfig;
			 hResizing: #spaceFill;
			 setBalloonText: 'Load a previously saved configuration').
	box addMorphBack: (SimpleButtonMorph new target: self;
			 label: 'Save';
			 actionSelector: #saveConfig;
			 hResizing: #spaceFill;
			 setBalloonText: 'Save the current configuration').
	box addMorphBack: (SimpleButtonMorph new target: self;
			 label: 'Rescan';
			 actionSelector: #rescanPlugins;
			 hResizing: #spaceFill;
			 setBalloonText: 'Rescan image, adding any new plugins and removing those no longer available in the image').
	sysWin
		addMorph: box
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 0)
				offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset := verticalOffset + box height - 1))).
	^ verticalOffset! !
!VMMakerTool methodsFor: 'menus' stamp: 'nk 4/5/2005 20:24'!
availableListMenu: aMenu

	aMenu addTranslatedList: #(
			('make all external'						makeAllPluginsExternal)
			('make all internal'						makeAllPluginsInternal)
			('make all available'					makeAllPluginsAvailable)
			-
			('browse plugin' 						browseSelectedAvailablePlugin)).
	^ aMenu! !
!VMMakerTool methodsFor: 'list access' stamp: 'tpr 10/10/2001 12:36'!
availableListSelectionAt: index
"return the boolean to say if the available plugin at index is selected"
	^allPluginsSelectionsArray at: index! !
!VMMakerTool methodsFor: 'list access' stamp: 'tpr 10/10/2001 12:37'!
availableListSelectionAt: index put: bool
"set the boolean to say if the available plugin at index is selected"
	^allPluginsSelectionsArray at: index put: bool! !
!VMMakerTool methodsFor: 'list access'!
availableModules
	^vmMaker availablePlugins! !
!VMMakerTool methodsFor: 'menus' stamp: 'rww 9/25/2001 02:00'!
browseSelectedAvailablePlugin

	| plugin |
	plugin := self availableModules at: self currentAvailableModuleIndex ifAbsent: [^self].
	(Smalltalk classNamed: plugin) browseHierarchy! !
!VMMakerTool methodsFor: 'menus' stamp: 'rww 9/25/2001 02:00'!
browseSelectedExternalPlugin

	| plugin |
	plugin := self externalModules at: self currentExternalModuleIndex ifAbsent: [^self].
	(Smalltalk classNamed: plugin) browseHierarchy! !
!VMMakerTool methodsFor: 'menus' stamp: 'rww 9/25/2001 02:01'!
browseSelectedInternalPlugin

	| plugin |
	plugin := self internalModules at: self currentInternalModuleIndex ifAbsent: [^self].
	(Smalltalk classNamed: plugin) browseHierarchy! !
!VMMakerTool methodsFor: 'window construction' stamp: 'dtl 3/14/2010 18:38'!
buildCenterRows
	| rows color1 color2 labelWidth longestLabel |
	color1 := Color blue veryMuchLighter.
	color2 := Color green veryMuchLighter.
	longestLabel := 'Path to platforms code:'.	"calculate labelWidth for acceptable results on varous images"
	labelWidth := (TextMorph new contents: longestLabel translated asText allBold) width *1.13.
	rows := Morph new color: Color transparent;
				 layoutPolicy: TableLayout new;
				 vResizing: #spaceFill;
				 extent: 550 @ (TextStyle defaultFont height * 8);
				 hResizing: #spaceFill;
				 listDirection: #topToBottom;
				borderStyle: (BorderStyle complexAltRaised width: 2);
				 wrapDirection: #none;
				 wrapCentering: #center;
				 yourself.
	rows
		addMorphBack: ((self
				entryRowWithLabel: 'Interpreter class name:'
				labelWidth: labelWidth
				balloonText: 'The name of the Interpreter class'
				getFieldText: #interpreterClassName
				setFieldText: #interpreterClassName:
				buttonLabel: nil
				buttonAction: nil
				buttonBalloonText: nil)
				color: color1).
	interpreterClassMorph := rows submorphs last submorphs first.

	rows
		addMorphBack: ((self
				entryRowWithLabel: 'Path to platforms code:'
				labelWidth: labelWidth
				balloonText: 'The directory where the platform source tree is found; can be edited in text field to the right. Default of {working directory}/src is strongly recommended'
				getFieldText: #platformsPathText
				setFieldText: #platformsPathText:
				buttonLabel: 'Find Path'
				buttonAction: #findPlatformsPath
				buttonBalloonText: 'Choose the directory where you keep the platform specific code from a file dialogue')
				color: color2).
	platformPathMorph := rows submorphs last submorphs second.

	rows
		addMorphBack: ((self
				entryRowWithLabel: 'Platform name:'
				labelWidth: labelWidth
				balloonText: 'The platform name (as returned by Smalltalk platformName - unix, Mac OS, RISCOS, win32 etc); can be edited (in text field to the right) to cross generate'
				getFieldText: #platformNameText
				setFieldText: #platformNameText:
				buttonLabel: 'Find platform'
				buttonAction: #platformsListMenu
				buttonBalloonText: 'Choose from a list of known platforms. The default is this current platform.')
				color: color1).
	platformNameMorph := rows submorphs last submorphs second.

	rows
		addMorphBack: ((self
				entryRowWithLabel: 'Path to generated sources:'
				labelWidth: labelWidth
				balloonText: 'The directory where the built sources will be placed; can be edited in text field to the right. The default is strongly recommended; makefile alterations may be needed if you use a different path.'
				getFieldText: #sourcePathText
				setFieldText: #sourcePathText:
				buttonLabel: 'Clean out'
				buttonAction: #cleanoutSrcDir
				buttonBalloonText: 'Clean out all the files in the target directory, ready for a clean build')
				color: color2).
	generatedPathMorph := rows submorphs last submorphs second.

	^ rows! !
!VMMakerTool methodsFor: 'window construction' stamp: 'nk 4/5/2005 23:05'!
buildWindow
	"VMMakerTool openInWorld"
	| sysWin box verticalOffset |
	sysWin := (SystemWindow labelled: 'VMMaker')
				model: self.
	verticalOffset := self addTopButtonRowToWindow: sysWin.
	verticalOffset := self addSecondButtonRowToWindow: sysWin startingAt: verticalOffset.
	box := self buildCenterRows.
	sysWin
		addMorph: box
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 0)
				offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset := verticalOffset + box height - 1))).
	"Add the list of plugins that are available to build"
	allPluginsList := (PluggableListMorph
				on: self
				list: #availableModules
				selected: #currentAvailableModuleIndex
				changeSelected: #currentAvailableModuleIndex:
				menu: #availableListMenu:
				keystroke: nil) enableDragNDrop.
	allPluginsList hResizing: #spaceFill;
		 vResizing: #spaceFill;
		 borderWidth: 0.
	box := AlignmentMorph newColumn.
	box addMorphBack: (TextMorph new contents: 'Plugins not built' asText allBold;
			 lock);
		 setBalloonText: 'List of plugins that are available to build but not yet chosen. Drag to either other list or use menu option to move in bulk'.
	box addMorphBack: allPluginsList.
	sysWin
		addMorph: box
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 / 3 @ 1)
				offsets: (0 @ verticalOffset corner: 0 @ -100)).
	"make the list for plugins that will be built for internal linking"
	internalPluginsList := (PluggableListMorph
				on: self
				list: #internalModules
				selected: #currentInternalModuleIndex
				changeSelected: #currentInternalModuleIndex:
				menu: #internalListMenu:
				keystroke: nil) enableDragNDrop.
	internalPluginsList hResizing: #spaceFill;
		 vResizing: #spaceFill;
		 borderWidth: 0.
	box := AlignmentMorph newColumn.
	box addMorphBack: (TextMorph new contents: 'Internal Plugins' asText allBold;
			 lock);
		 setBalloonText: 'List of plugins chosen to be built internally'.
	box addMorphBack: internalPluginsList.
	sysWin
		addMorph: box
		fullFrame: (LayoutFrame
				fractions: (1 / 3 @ 0 corner: 2 / 3 @ 1)
				offsets: (0 @ verticalOffset corner: 0 @ -100)).
	"make the list for plugins to be built externally (ie as DLLs, SO
	or 
	whatever suits the platform"
	externalPluginsList := (PluggableListMorph
				on: self
				list: #externalModules
				selected: #currentExternalModuleIndex
				changeSelected: #currentExternalModuleIndex:
				menu: #externalListMenu:
				keystroke: nil) enableDragNDrop.
	externalPluginsList hResizing: #spaceFill;
		 vResizing: #spaceFill;
		 borderWidth: 0.
	box := AlignmentMorph newColumn.
	box addMorphBack: (TextMorph new contents: 'External Plugins' asText allBold;
			 lock);
		 setBalloonText: 'List of plugins chosen to be built externally'.
	box addMorphBack: externalPluginsList.
	sysWin
		addMorph: box
		fullFrame: (LayoutFrame
				fractions: (2 / 3 @ 0 corner: 1 @ 1)
				offsets: (0 @ verticalOffset corner: 0 @ -100)).
	sysWin
		addMorph: (PluggableTextMorph
				on: logger
				text: nil
				accept: nil
				readSelection: nil
				menu: nil)
		fullFrame: (LayoutFrame
				fractions: (0 @ 1 corner: 1 @ 1)
				offsets: (0 @ -100 corner: 0 @ 0)).
	^ sysWin! !
!VMMakerTool methodsFor: 'settings' stamp: 'nk 4/5/2005 23:31'!
checkOK
	"check as many settings as we can and report true if all seems ok"
	(interpreterClassMorph accept; hasUnacceptedEdits) ifTrue:[^false].
	(platformPathMorph accept; hasUnacceptedEdits) ifTrue:[^false].
	(platformNameMorph accept; hasUnacceptedEdits) ifTrue:[^false].
	(generatedPathMorph accept; hasUnacceptedEdits) ifTrue:[^false].

	[vmMaker platformPluginsDirectory; crossPlatformPluginsDirectory]
		on: VMMakerException
		do: [:ex| self inform: ex messageText.
			^ false].
	^ true! !
!VMMakerTool methodsFor: 'path access' stamp: 'tpr 3/27/2002 15:19'!
cleanoutSrcDir
	"remove the entire generated src tree, ready for a nice clean build"
	vmMaker deleteEntireGeneratedTree! !
!VMMakerTool methodsFor: 'configurations' stamp: 'dtl 12/17/2010 14:24'!
configFileName
	"Answer the full path to the most recently loaded configuration file, or a default if
	no configuration file was previously loaded."

	^ configFileName
		ifNil: [configFileName := FileDirectory default pathName , FileDirectory slash , 'vmmaker.config']! !
!VMMakerTool methodsFor: 'list access'!
currentAvailableModuleIndex
	allPluginsSelection ifNil:[^0].
	^allPluginsSelection! !
!VMMakerTool methodsFor: 'list access' stamp: 'nk 12/16/2002 08:49'!
currentAvailableModuleIndex: anInteger
	allPluginsSelection := anInteger.
	self changed: #currentAvailableModuleIndex! !
!VMMakerTool methodsFor: 'list access'!
currentExternalModuleIndex
	externalPluginsSelection ifNil:[^0].
	^externalPluginsSelection! !
!VMMakerTool methodsFor: 'list access' stamp: 'nk 12/16/2002 08:49'!
currentExternalModuleIndex: anInteger
	externalPluginsSelection := anInteger.
	self changed: #currentExternalModuleIndex! !
!VMMakerTool methodsFor: 'list access'!
currentInternalModuleIndex
	internalPluginsSelection ifNil:[^0].
	^internalPluginsSelection! !
!VMMakerTool methodsFor: 'list access' stamp: 'nk 12/16/2002 08:49'!
currentInternalModuleIndex: anInteger
	internalPluginsSelection := anInteger.
	self changed: #currentInternalModuleIndex! !
!VMMakerTool methodsFor: 'drag and drop' stamp: 'tpr 10/12/2001 15:27'!
dragPassengerFor: item inMorph: dragSource 
	(dragSource isKindOf: PluggableListMorph)
		ifFalse: [^item].
	^item contents! !
!VMMakerTool methodsFor: 'drag and drop'!
dragTransferTypeForMorph: dragSource 
	^(dragSource isKindOf: PluggableListMorph)
		ifTrue: [dragSource getListSelector]! !
!VMMakerTool methodsFor: 'window construction' stamp: 'dtl 3/14/2010 18:22'!
entryRowWithLabel: label labelWidth: lWidth balloonText: balloonText getFieldText: getTextSelector setFieldText: setTextSelector buttonLabel: buttonLabel buttonAction: buttonAction buttonBalloonText: buttonBalloonText 
	| row tm |
	row := Morph new color: Color transparent;
				 hResizing: #spaceFill;
				 vResizing: #spaceFill;
				 extent: 550 @ 40;
				 layoutPolicy: ProportionalLayout new;
				 borderWidth: 2;
				 setBalloonText: balloonText translated;
				 yourself.
	row
		addMorph: (TextMorph new contents: label translated asText allBold) lock
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 0 @ 1)
				offsets: (3 @ 3 corner: lWidth @ -3)).
	row
		addMorph: ((tm := PluggableTextMorph
				on: self
				text: getTextSelector
				accept: setTextSelector) hideVScrollBarIndefinitely: true;
				 acceptOnCR: true)
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 1)
				offsets: (lWidth + 10 @ 0 corner: (lWidth / 1.8 + 10) negated @ 0)).
	"Make the background a solid color so that eventual bleed from the labels doesn't make the entire input field unreadable. Happens when the bold font is significantly wider than the non-bold font or when the spacing of the font doesn't match the guess above"
	tm color: (Color gray: 0.9).
	buttonAction
		ifNotNil: [row
				addMorph: (SimpleButtonMorph new target: self;
						 label: buttonLabel translated;
						 actionSelector: buttonAction;
						 hResizing: #spaceFill;
						 setBalloonText: buttonBalloonText translated)
				fullFrame: (LayoutFrame
						fractions: (1 @ 0 corner: 1 @ 1)
						offsets: ((lWidth / 1.8 + 5) negated @ 3 corner: -5 @ -3))].
	^ row! !
!VMMakerTool methodsFor: 'menus' stamp: 'nk 4/5/2005 20:25'!
externalListMenu: aMenu

	aMenu addTranslatedList:#(
			('make all external'						makeAllPluginsExternal)
			('make all internal'						makeAllPluginsInternal)
			('make all available'					makeAllPluginsAvailable)
			-
			('browse plugin' 						browseSelectedExternalPlugin)
			-
			('generate plugin'						generateSelectedExternalPlugin)).
	^ aMenu! !
!VMMakerTool methodsFor: 'list access' stamp: 'tpr 10/10/2001 12:36'!
externalListSelectionAt: index
"return the boolean to say if the external plugin at index is selected"
	^externalPluginsSelectionsArray at: index! !
!VMMakerTool methodsFor: 'list access' stamp: 'tpr 10/10/2001 12:37'!
externalListSelectionAt: index put: bool
"set the boolean to say if the external plugin at index is selected"
	^externalPluginsSelectionsArray at: index put: bool! !
!VMMakerTool methodsFor: 'list access'!
externalModules
	^vmMaker externalModules! !
!VMMakerTool methodsFor: 'path access' stamp: 'dtl 8/24/2009 07:26'!
findPlatformsPath
	| dir |
	dir := self selectDirectory.
	dir ifNil: [^nil].
	self platformsPathText: dir pathName! !
!VMMakerTool methodsFor: 'path access' stamp: 'tpr 3/12/2002 14:10'!
findPlatformsPathFrom: fd
	| path |
	Utilities informUserDuring:[:bar|
		path := self findPlatformsPathFrom: fd informing: bar.
	].
	^path! !
!VMMakerTool methodsFor: 'path access' stamp: 'ar 3/10/2002 14:54'!
findPlatformsPathFrom: fd informing: bar
	| dirNames possiblePath |
	bar value: 'Searching in ', fd pathName.
	dirNames := fd directoryNames.
	(dirNames includes: 'platforms') ifTrue:[
		possiblePath := fd pathName, fd pathNameDelimiter asString, 'platforms'.
		(self confirm: 'Found a platforms directory at
', possiblePath,'
Do you want me to use it?') ifTrue:[^possiblePath].
	].
	dirNames do:[:dd|
		possiblePath := self findPlatformsPathFrom: (fd directoryNamed: dd) informing: bar.
		possiblePath ifNotNil:[^possiblePath].
	].
	^nil! !
!VMMakerTool methodsFor: 'generate sources' stamp: 'tpr 10/21/2001 11:00'!
generateAll
	"tell the vmMaker to build all the sources"
	self checkOK
		ifTrue: [[vmMaker generateEntire]
				on: VMMakerException
				do: [:ex| self inform: ex messageText]]! !
!VMMakerTool methodsFor: 'generate sources' stamp: 'tpr 10/21/2001 11:01'!
generateCore
	"tell the vmMaker to build all the core vm sources"
	self checkOK
		ifTrue: [[vmMaker generateMainVM]
		on: VMMakerException
		do: [:ex| self inform: ex messageText]]! !
!VMMakerTool methodsFor: 'generate sources' stamp: 'tpr 10/21/2001 11:02'!
generateExternal
	"tell the vmMaker to build all the externally linked plugin sources"
	self checkOK
		ifTrue: [[vmMaker generateExternalPlugins]
		on: VMMakerException
		do: [:ex | self inform: ex messageText]]! !
!VMMakerTool methodsFor: 'generate sources' stamp: 'tpr 10/21/2001 11:03'!
generateSelectedExternalPlugin

	| plugin |
	plugin := self externalModules at: self currentExternalModuleIndex ifAbsent: [^self].
	self checkOK
		ifTrue: [[vmMaker generateExternalPlugin: plugin]
		on: VMMakerException
		do: [:ex| self inform: ex messageText]]
! !
!VMMakerTool methodsFor: 'generate sources' stamp: 'tpr 10/21/2001 11:03'!
generateSelectedInternalPlugin

	| plugin |
	plugin := self internalModules at: self currentInternalModuleIndex ifAbsent: [^self].
	self checkOK
		ifTrue: [[vmMaker generateInternalPlugin: plugin]
		on: VMMakerException
		do: [:ex| self inform: ex messageText]]
! !
!VMMakerTool methodsFor: 'menus' stamp: 'tpr 10/14/2001 20:11'!
helpText
	(StringHolder new contents: self class comment)
		openLabel: 'VMMakerTool help'
! !
!VMMakerTool methodsFor: 'generate sources' stamp: 'tpr 5/28/2008 19:39'!
inform: aProblemString
"log the problem in the transcript window"
	logger show: aProblemString; cr! !
!VMMakerTool methodsFor: 'initialisation' stamp: 'ar 3/10/2002 15:09'!
initialExtent
 	^600@450! !
!VMMakerTool methodsFor: 'list access'!
initialModules
	^vmMaker availableModules! !
!VMMakerTool methodsFor: 'initialisation' stamp: 'ar 3/10/2002 15:06'!
initialize
	logger := TranscriptStream new.
	vmMaker := VMMaker default.
	vmMaker logger: logger.
	vmMaker addDependent: self.
	allPluginsSelectionsArray := Array new: self availableModules size withAll: false.
	internalPluginsSelectionsArray := Array new.
	externalPluginsSelectionsArray := Array new.! !
!VMMakerTool methodsFor: 'menus' stamp: 'nk 4/5/2005 20:25'!
internalListMenu: aMenu

	aMenu addTranslatedList:#(
			('make all external'						makeAllPluginsExternal)
			('make all internal'						makeAllPluginsInternal)
			('make all available'					makeAllPluginsAvailable)
			-
			('browse plugin' 						browseSelectedInternalPlugin)
			-
			('generate plugin'						generateSelectedInternalPlugin)).
	^ aMenu! !
!VMMakerTool methodsFor: 'list access' stamp: 'tpr 10/10/2001 12:36'!
internalListSelectionAt: index
"return the boolean to say if the internal plugin at index is selected"
	^internalPluginsSelectionsArray at: index! !
!VMMakerTool methodsFor: 'list access' stamp: 'tpr 10/10/2001 12:37'!
internalListSelectionAt: index put: bool
"set the boolean to say if the internal plugin at index is selected"
	^internalPluginsSelectionsArray at: index put: bool! !
!VMMakerTool methodsFor: 'list access'!
internalModules
	^vmMaker internalModules! !
!VMMakerTool methodsFor: 'path access' stamp: 'svp 11/14/2002 21:11'!
interpreterClassName
	"return a Text for the path to the generated sources"
	^[vmMaker interpreterClass name asString] 
		on: VMMakerException 
		do:[:ex| ex return:'<invalid class>'].! !
!VMMakerTool methodsFor: 'path access' stamp: 'tpr 5/28/2008 19:51'!
interpreterClassName: aText
	"set the interpreter class name"

	[vmMaker interpreterClassName: aText asString] 
		on: VMMakerException 
		do: [:ex| self inform:ex messageText. 
			^false].
	^true! !
!VMMakerTool methodsFor: 'deprecated' stamp: 'dtl 5/27/2010 21:31'!
isFor64BitVM
	"This selector may be used by obsolete instances of VMMakerTool. The
	64-bit setting of VMMaker is no longer functionally relevant, but this method
	is retained to prevent problems with existing VMMakerTool instances that
	may exist in some images."! !
!VMMakerTool methodsFor: 'list access' stamp: 'tpr 10/12/2001 15:29'!
listForMorph: aMorph
	"work out which list is the one associated with this morph"
	allPluginsList = aMorph ifTrue:[^allPluginsList getListSelector].
	internalPluginsList = aMorph ifTrue:[^internalPluginsList getListSelector].
	externalPluginsList =aMorph ifTrue:[^externalPluginsList getListSelector].
	^nil! !
!VMMakerTool methodsFor: 'list access'!
listMorphs
	^Array with: allPluginsList with: internalPluginsList with: externalPluginsList! !
!VMMakerTool methodsFor: 'configurations' stamp: 'dtl 12/19/2010 22:50'!
loadConfig

	((Smalltalk hasClassNamed: #UIManager)
			ifTrue: [ "Newer images use UIManager"
				(Smalltalk at: #UIManager) default
						chooseFileMatching: #('config' )
						label: 'Select VMMaker configuration...']
			ifFalse: [ "UIManager not present, use original StandardFileMenu implementation "
				(((Smalltalk at: #StandardFileMenu)
						oldFileMenu: FileDirectory default
						withPattern: '*.config')
						startUpWithCaption: 'Select VMMaker configuration...')
					ifNotNilDo: [ :fileResult | fileResult directory fullNameFor: fileResult name]])
		ifNotNilDo: [ :file |
			[vmMaker := VMMaker forConfigurationFile: file.
			vmMaker logger: logger.
			vmMaker platformDirectory]
				on: Error
				do: [self inform: 'Possible problem with path settings or platform name?'].
			configFileName := file. "set default config file name to the most recently loaded file"
			self updateAllViews]! !
!VMMakerTool methodsFor: 'menus' stamp: 'tpr 10/16/2001 09:58'!
makeAllPluginsAvailable


	vmMaker makeAllModulesAvailable! !
!VMMakerTool methodsFor: 'menus' stamp: 'tpr 10/16/2001 09:58'!
makeAllPluginsExternal


	vmMaker makeAllModulesExternal! !
!VMMakerTool methodsFor: 'menus' stamp: 'tpr 10/16/2001 09:58'!
makeAllPluginsInternal


	vmMaker makeAllModulesInternal! !
!VMMakerTool methodsFor: 'drag and drop' stamp: 'tpr 10/21/2001 11:19'!
moveItem: transferedMorph from: sourceListMorph to: destListMorph 
	"As part of a drag operation we have to move the item carried by the  
	transfer morph from a source list to a destination list"
	"work out which list is involved and add the item to it"
	| destlist srclist |

	"no need to do anything if we drop on the same place from which we dragged" 
	sourceListMorph = destListMorph
		ifTrue: [^ false].

	(destlist := self listForMorph: destListMorph)
		ifNil: [^ false].
	(srclist := self listForMorph: sourceListMorph)
		ifNil: [^ false].
	vmMaker
		movePlugin: transferedMorph contents
		from: srclist
		to: destlist.
	self changed: sourceListMorph getListSelector.
	self changed: destListMorph getListSelector.
	^ true! !
!VMMakerTool methodsFor: 'menus' stamp: 'rww 9/25/2001 01:02'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !
!VMMakerTool methodsFor: 'path access'!
platformNameText
	"return a Text for the platform name"
	^vmMaker platformName asText! !
!VMMakerTool methodsFor: 'menus' stamp: 'tpr 5/28/2008 19:56'!
platformNameText: aText 
	"set the platform name - this will almost certainly mean replacing the  
	vmMaker with one suited to the platform so we do it anyway."
	| prevVMMaker |
	prevVMMaker := vmMaker.
	"make a new vmmaker and ensure I depend on it correctly"
	vmMaker := VMMaker forPlatform: aText string.
	vmMaker logger: logger.
	vmMaker addDependent: self.
	prevVMMaker removeDependent: self.
	"configure the new vmmaker to match the old one"
	[vmMaker loadConfiguration: prevVMMaker configurationInfo.
	vmMaker platformDirectory]
		on: VMMakerException
		do: [:ex| self inform: ex messageText.
			^ false].
	^ true! !
!VMMakerTool methodsFor: 'menus' stamp: 'nk 4/5/2005 23:05'!
platformsListMenu
	"create a menu of all known platforms"

	| choice platnames |
	platnames := vmMaker platformRootDirectory directoryNames 
				copyWithoutAll: #('Cross' 'CVS' '.svn').
	choice := (PopUpMenu labelArray: platnames
				lines: #()) startUp.
	choice = 0 ifTrue: [^self].
	self platformNameText: (platnames at: choice) asText! !
!VMMakerTool methodsFor: 'path access' stamp: 'tpr 10/21/2001 11:24'!
platformsPathText
	"return a Text for the path to the platform sources"
	[^vmMaker platformRootDirectory fullName asText] on: VMMakerException do:[^'Problem with directory name for platform code: enter correct path or consult help text' asText]! !
!VMMakerTool methodsFor: 'path access' stamp: 'tpr 5/28/2008 19:55'!
platformsPathText: aText
	"set the path to the platform sources"
	[^vmMaker platformRootDirectoryName: aText asString] on: VMMakerException do:[:ex| self inform:'Problem with this directory name; check the path settings, permissions or spelling?'. ex return: false]! !
!VMMakerTool methodsFor: 'menus' stamp: 'nk 4/5/2005 20:27'!
release
	vmMaker ifNotNil: [ vmMaker removeDependent: self ].
	super release.! !
!VMMakerTool methodsFor: 'menus' stamp: 'dtl 10/23/2009 19:48'!
rescanPlugins


	vmMaker reinitializePluginsLists! !
!VMMakerTool methodsFor: 'configurations' stamp: 'dtl 12/21/2010 10:59'!
saveConfig
	"write info about the current configuration to a file."

	((Smalltalk hasClassNamed: #UIManager)
		ifTrue: [ "Newer images use UIManager"
			((Smalltalk at: #UIManager) default
					request: 'Save VMMaker configuration...'
					initialAnswer: self configFileName)
				ifNotNilDo: [:f | | file path |
					('*.config' match: f)
						ifTrue: [file := f]
						ifFalse: [file := f , '.config'].
					"If path is not valid, the image has probably been moved to a new location or
					to a different platform. Assume this is the case, and change the path to the
					current default."
					path := file copyUpToLast: FileDirectory pathNameDelimiter.
					(FileDirectory default directoryExists: path)
						ifTrue: [file]
						ifFalse: [file copyReplaceAll: path with: FileDirectory default pathName]]]
		ifFalse: [ "UIManager not present, use original StandardFileMenu implementation"
			(((Smalltalk at: #StandardFileMenu)
						newFileMenu: FileDirectory default
						withPattern: '*.config')
						startUpWithCaption: 'Save VMMaker configuration...')
				ifNotNilDo: [ :fileResult |
					('*.config' match: fileResult name)
						ifFalse: [fileResult name: fileResult name , '.config'].
								fileResult directory fullNameFor: fileResult name]])
		ifNotNilDo: [ :file |
			vmMaker saveConfigurationTo: file.
			configFileName := file]! !
!VMMakerTool methodsFor: 'path access' stamp: 'dtl 8/24/2009 07:25'!
selectDirectory
	"Newer images should use UIManager, but UIManager is not available on
	older images. Provide backward compatibility."

	(Smalltalk hasClassNamed: #UIManager)
		ifTrue: [^(Smalltalk at: #UIManager) default perform: #chooseDirectory]
		ifFalse: [^(Smalltalk at: #FileList2) perform: #modalFolderSelector].
	self error: 'directory selector dialog not available'! !
!VMMakerTool methodsFor: 'path access' stamp: 'ar 5/4/2002 21:06'!
sourcePathText
	"return a Text for the path to the generated sources"
	^[vmMaker sourceDirectory fullName asText] 
		on: VMMakerException 
		do:[:ex| ex return:'<path not valid>'].! !
!VMMakerTool methodsFor: 'path access'!
sourcePathText: aText
	"set the path to the generated sources"
	^vmMaker sourceDirectoryName: aText asString! !
!VMMakerTool methodsFor: 'deprecated' stamp: 'dtl 5/27/2010 21:33'!
toggle64BitVM
	"This selector may be used by obsolete instances of VMMakerTool. The
	64-bit setting of VMMaker is no longer functionally relevant, but this method
	is retained to prevent problems with existing VMMakerTool instances that
	may exist in some images."! !
!VMMakerTool methodsFor: 'initialisation' stamp: 'tpr 10/12/2001 18:06'!
update: anObject 
	"some related object has changed. Try to handle it"
	anObject == #reinitialize ifTrue: [self updateAllViews]! !
!VMMakerTool methodsFor: 'initialisation' stamp: 'tpr 10/12/2001 18:06'!
updateAllViews
	self changed: #platformsPathText;
				 changed: #platformNameText;
				 changed: #sourcePathText;
				 changed: #availableModules;
				 changed: #internalModules;
				 changed: #externalModules! !
!VMMakerTool methodsFor: 'drag and drop' stamp: 'nk 4/5/2005 23:14'!
wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM 
	"We are only interested in TransferMorphs as wrappers for             
	information. If their content is really interesting for us, will             
	determined later in >>acceptDroppingMorph:event:."

	"only want drops on the lists"

	(transferMorph isKindOf: HandleMorph) ifTrue: [ ^false ].

	(transferMorph isKindOf: TransferMorph) ifFalse: [ ^false ].

	transferMorph source model = self ifFalse:[^false].

	^self listMorphs includes: destinationLM! !
!String class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/19/1999 00:21'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asCharPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isBytes')! !
!String class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/18/1999 17:10'!
ccgDeclareCForVar: aSymbolOrString

	^'char *', aSymbolOrString! !
!String methodsFor: '*VMMaker-Translation to C' stamp: 'EstebanLorenzano 12/6/2010 19:19'!
replaceLastOccurrence: oldSubstring with: newSubstring 
	"Answer a copy with the last occurrence of oldSubstring replaced by newSubstring."

	" 'int i' replaceLastOccurrence: 'i' with: 'i2' "
	" 'void *v' replaceLastOccurrence: 'v' with: 'v2' "
	" 'int intxintxintx' replaceLastOccurrence: 'i' with: 'I2' "
	" 'int intxintxintx' replaceLastOccurrence: 'FOO' with: 'BAR' "
	" 'int intxintxintx' replaceLastOccurrence: '' with: 'BAZ' "

	^ self class streamContents: [:ws | | pos rs | 
			rs := ReadStream on: self.
			pos := self findLastOccurrenceOfString: oldSubstring startingAt: 1.
			pos > 0 ifTrue: [ws nextPutAll: (rs next: pos - 1); nextPutAll: newSubstring.
						rs next: oldSubstring size].
			ws nextPutAll: rs upToEnd]! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'eem 2/19/2009 18:33'!
asUnsignedInteger
	self assert: self >= 0.
	^self! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'nk 4/3/2004 12:46'!
coerceTo: cTypeString sim: interpreter

	| unitSize |

	cTypeString last = $* ifTrue: [  "C pointer"
		unitSize := cTypeString caseOf: {
		['char *'] -> [1].
		['int *'] -> [4].
		['float *'] -> [4].
		['unsigned *'] -> [4].
		['float *'] -> [4].
		}
		otherwise: [ (cTypeString beginsWith: 'char') ifTrue: [1] ifFalse: [4] ].
		^(CArray basicNew)
			interpreter: interpreter address: self unitSize: unitSize;
			yourself.
	].
	^ self  "C number (int, char, float, etc)"! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'eem 5/21/2010 11:09'!
hex8
	"Print the receiver in base 16 with prefixed base, using at least 8 digits.
	 DO NOT CHANGE THIS!!  The Cog VMMaker depends on this.
	 Consider using storeStringBase: 16 length: 11 padded: true instead."
	  "16r3333 hex8"
	| hex |
	hex := self hex.  "16rNNN"
	^hex size < 11
		ifTrue: [hex copyReplaceFrom: 4 to: 3
						 with: ('00000000' copyFrom: 1 to: 11-hex size)]
		ifFalse: [hex]! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'eem 3/19/2009 16:15'!
signedBitShift: anInteger
	"For historical reasons Slang generates an unsigned shift from all of the shift operators >>, << & bitShift:.
	 These are too deeply entrenched to try and redefine the semantics.  So instead we provide a signed bitShift:
	 that signals to Slang that its argument should be cast to signed, not to unsigned, when being shifted."
	^self bitShift: anInteger! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'eem 2/15/2009 10:17'!
signedIntFromLong
	"Self is a signed or unsigned 32-bit integer"

	| sign |
	self < 0 ifTrue: [^self].
	sign := self bitAnd: 16r80000000.
	sign = 0 ifTrue: [^ self].
	^ self - sign - sign! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'eem 3/2/2009 18:32'!
signedIntFromShort
	"Self is an unsigned 16-bit integer in twos-comp form"

	| shortBits |
	shortBits := self bitAnd: 16rFFFF.
	^(self bitAnd: 16r8000) "sign bit" = 0
		ifTrue: [shortBits]
		ifFalse: [shortBits - 16r10000]! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'di 7/14/2004 12:27'!
signedIntToLong
	"Produces a 32-bit value in twos-comp form.  Sorry no error checking"

	self >= 0
		ifTrue: [^ self]
		ifFalse: [^ self + 16r80000000 + 16r80000000]
! !
!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'eem 3/2/2009 17:03'!
signedIntToShort
	"Produces a 16-bit value (0-65k) in twos-comp form.  Sorry no error checking"

	^self bitAnd: 16rFFFF! !
!Float class methodsFor: '*VMMaker-plugin generation' stamp: 'bf 3/16/2000 19:06'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asFloatValueFrom: anInteger on: aStream! !
!Float class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 10/5/1999 06:05'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToFloatObjectFrom: aNode on: aStream! !
!Float class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 10/5/1999 06:10'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToFloatValueFrom: aNode on: aStream! !
!Float class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/18/1999 17:08'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asFloatValueFrom: anInteger! !
!Float class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/20/1999 11:22'!
ccgCanConvertFrom: anObject

	^anObject class == self! !
!Float class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:09'!
ccgDeclareCForVar: aSymbolOrString

	^'double ', aSymbolOrString! !

Object subclass: #CArray
	instanceVariableNames: 'interpreter arrayBaseAddress ptrOffset unitSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!CArray commentStamp: '<historical>' prior: 0!
For Simulating the Interpreter only.  Coercing an Integer to a pointer (eg. cCoerce:to: 'char *') returns a CArray.  A CArray responds to at: and at:put: by reading/writing from the memory of the interpreter that sent the cCoerce:to: message in the first place.  A CArray responds to arithmetic by returning the new address.  Since longAt: sends // to its given address this is where the CArray converts back to a Integer for the memory fetch to work.!

CArray subclass: #BalloonArray
	instanceVariableNames: 'simArray'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!BalloonArray commentStamp: '<historical>' prior: 0!
BalloonArray keeps a shadow copy of its raw memory data in a Smalltalk array.  This allows support for C's inhomogeneous access, returning floats where Floats were stored, and negative ints where they were stored.  This ruse only works, of course where we have control over all the access.!
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/16/2004 12:14'!
at: index
	| value |
	value := simArray at: index+1.
	"Debug only..."
	value ifNil:
		[self error: 'attempt to read an uninitialized field'.
		^ super at: index  "Maybe it was set in Squeak.  Return the raw value"].
	(self bitsOf: value) ~= (super at: index) ifTrue:
		[self error: 'inconsistent values'].
	^ value! !
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/16/2004 11:28'!
at: index put: value

	super at: index put: (self bitsOf: value).
	^ simArray at: index + 1 put: value.
	! !
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:34'!
bitsOf: value
	"Convert pos and neg ints and floats to 32-bit representations expected by C"

	value isInteger ifTrue:
		[value >= 0 ifTrue: [^ value].
		^ value + 16r80000000 + 16r80000000].
	value isFloat ifTrue:
		[^ value asIEEE32BitWord].
	self error: 'unexpected value for 32 bits'.
	^ 0! !
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 16:04'!
floatAt: index
	| value |
	value := self at: index.
	value isFloat ifFalse:
		[value = 0 ifTrue: [^ 0.0].
		self error: 'non-float was stored'.
		^ Float fromIEEE32Bit: value].
	^ value! !
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:00'!
floatAt: index put: value

	value isFloat
		ifFalse: [self error: 'inconsistent values'].
	^ self at: index put: value! !
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:02'!
intAt: index
	| value |
	value := self at: index.
	value isInteger
		ifFalse: [self error: 'inconsistent values'].
	^ value! !
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:01'!
intAt: index put: value

	value isInteger
		ifFalse: [self error: 'inconsistent values'].
	^ self at: index put: value! !
!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:17'!
setSimArray: anArray

	simArray := anArray! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 00:35'!
* n

	^ self ptrAddress * n! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 01:43'!
+ n

	^ self ptrAddress + n! !
!CArray methodsFor: 'pointer arithmetic' stamp: 'ajh 8/20/2002 01:34'!
+= increment

	ptrOffset := ptrOffset + increment! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 01:43'!
- n

	^ self ptrAddress - n! !
!CArray methodsFor: 'pointer arithmetic' stamp: 'ajh 8/20/2002 01:35'!
-= decrement

	ptrOffset := ptrOffset - decrement! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 00:35'!
// n

	^ self ptrAddress // n! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 00:35'!
<< n

	^ self ptrAddress bitShift: n! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 00:35'!
>> n

	^ self ptrAddress bitShift: 0 - n! !
!CArray methodsFor: 'converting' stamp: 'ajh 8/20/2002 01:29'!
adaptToNumber: rcvr andSend: selector

	^ rcvr perform: selector with: self asInteger! !
!CArray methodsFor: 'converting' stamp: 'di 7/15/2004 16:55'!
asCArrayAccessor

	^ (CArrayAccessor on: self)
			+= -1   "Defeat the +1 offset in the accessor"! !
!CArray methodsFor: 'converting' stamp: 'ajh 8/20/2002 01:10'!
asInteger

	^ self ptrAddress! !
!CArray methodsFor: 'accessing' stamp: 'di 7/6/2004 09:32'!
at: offset

	ptrOffset = 0 ifFalse: [self error: 'only expect base address to receive at: message'].
	unitSize = 1 ifTrue: [^ interpreter byteAt: arrayBaseAddress + offset].
	unitSize = 4 ifTrue: [^ interpreter long32At: arrayBaseAddress + (offset * 4)].
	self halt: 'Can''t handle unitSize ', unitSize printString
! !
!CArray methodsFor: 'accessing' stamp: 'di 7/19/2004 12:01'!
at: offset put: val

	ptrOffset = 0 ifFalse: [self error: 'only expect base address to receive at:put: message'].
	unitSize = 1 ifTrue: [^ interpreter byteAt: arrayBaseAddress + offset put: val].
	unitSize = 4 ifTrue: [^ interpreter long32At: arrayBaseAddress + (offset * 4) put: val].
	self halt: 'Can''t handle unitSize ', unitSize printString
! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 00:35'!
bitAnd: n

	^ self ptrAddress bitAnd: n! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 00:35'!
bitOr: n

	^ self ptrAddress bitOr: n! !
!CArray methodsFor: 'int arithmetic' stamp: 'ajh 8/20/2002 00:35'!
bitShift: n

	^ self ptrAddress bitShift: n! !
!CArray methodsFor: 'converting' stamp: 'tpr 3/23/2005 12:36'!
coerceTo: cTypeString sim: interpreterSimulator

	cTypeString = 'int' ifTrue: [^ self ptrAddress].
	cTypeString = 'float *' ifTrue: [^ self asCArrayAccessor asFloatAccessor].
	cTypeString = 'int *' ifTrue: [^ self asCArrayAccessor asIntAccessor].
	cTypeString = 'unsigned' ifTrue: [^ self ptrAddress].
	^ self! !
!CArray methodsFor: 'converting' stamp: 'ajh 8/20/2002 01:23'!
doesNotUnderstand: message

	^ self asInteger perform: message selector withArguments: message arguments! !
!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
floatAt: index
	^ Float fromIEEE32Bit: (self at: index)! !
!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
floatAt: index put: value
	^ self at: index put: value asIEEE32BitWord! !
!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
intAt: index
	^ (self at: index) signedIntFromLong! !
!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
intAt: index put: signedInt
	^ self at: index put: signedInt signedIntToLong! !
!CArray methodsFor: 'private' stamp: 'ajh 8/20/2002 00:30'!
interpreter: interpreterSimulator address: arrayAddress unitSize: numBytes

	interpreter := interpreterSimulator.
	arrayBaseAddress := arrayAddress.
	unitSize := numBytes.
	ptrOffset := 0.
! !
!CArray methodsFor: 'private' stamp: 'ajh 8/20/2002 00:36'!
ptrAddress

	^ arrayBaseAddress + ptrOffset! !

Object subclass: #CCodeGenerator
	instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict vmClass currentMethod'
	classVariableNames: 'UseRightShiftForDivide'
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.  
See VMMaker for more useful info!
!CCodeGenerator class methodsFor: 'class initialization' stamp: 'jm 8/19/1998 10:03'!
initialize
	"CCodeGenerator initialize"

	UseRightShiftForDivide := true.
		"If UseRightShiftForDivide is true, the translator will generate a right-shift when it encounters a division by a constant that is a small power of two. For example, 'x / 8' will generate '((int) x >> 3)'. The coercion to int is done to make it clear that the C compiler should generate a signed shift."
		"Note: The Kernighan and Ritchie 2nd Edition C manual, p. 49, leaves the semantics of right-shifting a negative number open to the discretion of the compiler implementor. However, it strongly suggests that most compilers should generate an arithmetic right shift (i.e., shifting in the sign bit), which is the same as dividing by a power of two. If your compiler does not generate or simulate an arithmetic shift, then make this class variable false and re-translate."
! !
!CCodeGenerator class methodsFor: 'removing from system' stamp: 'jm 5/16/1998 10:26'!
removeCompilerMethods
	"Before removing the C code generator classes from the system, use this method to remove the compiler node methods that support it. This avoids leaving dangling references to C code generator classes in the compiler node classes."

	ParseNode withAllSubclasses do: [ :nodeClass |
		nodeClass removeCategory: 'C translation'.
	].
	Smalltalk at: #AbstractSound ifPresent: [:abstractSound |
		 abstractSound class removeCategory: 'primitive generation'].
! !
!CCodeGenerator methodsFor: 'public' stamp: 'TPR 3/2/2000 11:22'!
addAllClassVarsFor: aClass
	"Add the class variables for the given class (and its superclasses) to the code base as constants."

	| allClasses |
	allClasses := aClass withAllSuperclasses.
	allClasses do: [:c | self addClassVarsFor: c].
! !
!CCodeGenerator methodsFor: 'public' stamp: 'tpr 2/27/2004 19:07'!
addClass: aClass 
	"Add the variables and methods of the given class to the code base."
	| source |
	self checkClassForNameConflicts: aClass.
	self addClassVarsFor: aClass.
	"ikp..."
	self addPoolVarsFor: aClass.
	variables addAll: aClass instVarNames.
	self retainMethods: aClass requiredMethodNames.
	
	'Adding Class ' , aClass name , '...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: aClass selectors size
		during: [:bar | aClass selectors
				doWithIndex: 
					[:sel :i | 
					bar value: i.
					source := aClass sourceCodeAt: sel.
					self addMethod: ((Compiler new
							parse: source
							in: aClass
							notifying: nil)
							asTranslationMethodOfClass: self translationMethodClass)]].
	aClass declareCVarsIn: self! !
!CCodeGenerator methodsFor: 'public' stamp: 'ar 7/8/2003 11:16'!
addClassVarsFor: aClass
	"Add the class variables for the given class to the code base as constants."
	| val node |
	aClass classPool associationsDo: [:assoc | 
		val := assoc value.
		(useSymbolicConstants and:[self isCLiteral: val])
			ifTrue:[node := TDefineNode new setName: assoc key asString value: assoc value]
			ifFalse:[node := TConstantNode new setValue: assoc value].
		constants at: assoc key asString put: node].
! !
!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/14/1999 01:08'!
addHeaderFile: aString
	"Add a header file. The argument must be a quoted string!!"
	headerFiles addLast: aString.! !
!CCodeGenerator methodsFor: 'utilities'!
addMethod: aTMethod
	"Add the given method to the code base."

	(methods includesKey:  aTMethod selector) ifTrue: [
		self error: 'Method name conflict: ', aTMethod selector.
	].
	methods at: aTMethod selector put: aTMethod.! !
!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/3/2001 17:55'!
addMethodsForPrimitives: classAndSelectorList 
	| sel aClass source verbose meth |
	classAndSelectorList do: 
		[:classAndSelector | 
		aClass := Smalltalk at: (classAndSelector at: 1).
		self addAllClassVarsFor: aClass.
"TPR - should pool vars also be added here?"

		"find the method in either the class or the metaclass"
		sel := classAndSelector at: 2.
		(aClass includesSelector: sel)
			ifTrue: [source := aClass sourceCodeAt: sel]
			ifFalse: [source := aClass class sourceCodeAt: sel].

		"compile the method source and convert to a suitable translation 
		method "
		meth := (Compiler new
					parse: source
					in: aClass
					notifying: nil)
					asTranslationMethodOfClass: self translationMethodClass.

		(aClass includesSelector: sel)
			ifTrue: [meth definingClass: aClass]
			ifFalse: [meth definingClass: aClass class].
		meth primitive > 0 ifTrue:[meth preparePrimitiveName].
		"for old-style array accessing: 
		meth covertToZeroBasedArrayReferences."
		meth replaceSizeMessages.
		self addMethod: meth].

	"method preparation"
	verbose := false.
	self prepareMethods.
	verbose
		ifTrue: 
			[self printUnboundCallWarnings.
			self printUnboundVariableReferenceWarnings.
			Transcript cr].

	"code generation"
	self doInlining: true.

	methods do:[:m|
		"if this method is supposed to be a primitive (rather than a helper 
		routine), add assorted prolog and epilog items"
		m primitive > 0 ifTrue: [m preparePrimitivePrologue]].! !
!CCodeGenerator methodsFor: 'public' stamp: 'ar 7/8/2003 11:16'!
addPoolVarsFor: aClass 
	"Add the pool variables for the given class to the code base as constants."
	| val node |
	aClass sharedPools do: [:pool |
		pool bindingsDo: [:assoc |
			val := assoc value.
			(useSymbolicConstants and:[self isCLiteral: val])
				ifTrue:[node := TDefineNode new setName: assoc key asString value: assoc value]
				ifFalse:[node := TConstantNode new setValue: assoc value].
			constants at: assoc key asString put: node]].! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'dtl 7/2/2008 16:46'!
builtin: sel 
	"Answer true if the given selector is one of the builtin selectors."
	^ sel = #error:
		or: [(self memoryAccessSelectors includes: sel)
				or: [translationDict includesKey: sel]]! !
!CCodeGenerator methodsFor: 'utilities'!
cCodeForMethod: selector
	"Answer a string containing the C code for the given method."
	"Example:
		((CCodeGenerator new initialize addClass: TestCClass1; prepareMethods)
			cCodeForMethod: #ifTests)"

	| m s |
	m := self methodNamed: selector.
	m = nil ifTrue: [ self error: 'method not found in code base: ', selector ].

	s := (ReadWriteStream on: '').
	m emitCCodeOn: s generator: self.
	^ s contents! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'ar 3/16/2002 15:33'!
cFunctionNameFor: aSelector
	"Create a C function name from the given selector by omitting colons
	and prefixing with the plugin name if the method is exported."
	^aSelector copyWithout: $:! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 8/3/2004 20:16'!
cLiteralFor: anObject
	"Return a string representing the C literal value for the given object."
	(anObject isKindOf: Integer) ifTrue: [
		(anObject < 16r7FFFFFFF)
			ifTrue: [^ anObject printString]
			ifFalse: [^ anObject printString , ObjectMemory unsignedIntegerSuffix "ikp"]].
	(anObject isKindOf: String) ifTrue: [^ '"', anObject, '"' ].
	(anObject isKindOf: Float) ifTrue: [^ anObject printString ].
	anObject == nil ifTrue: [^ 'null' ].
	anObject == true ifTrue: [^ '1' ].			"ikp"
	anObject == false ifTrue: [^ '0' ].			"ikp"
	(anObject isKindOf: Character) ifTrue:[^anObject asString printString]. "ar"
	self error:								"ikp"
		'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString.
	^'"XXX UNTRANSLATABLE CONSTANT XXX"'! !
!CCodeGenerator methodsFor: 'error notification' stamp: 'tpr 6/11/2003 16:36'!
checkClassForNameConflicts: aClass
	"Verify that the given class does not have constant, variable, or method names that conflict with those of previously added classes. Raise an error if a conflict is found, otherwise just return."

	"check for constant name collisions"
	aClass classPool associationsDo: [ :assoc |
		(constants includesKey: assoc key asString) ifTrue: [
			self error: 'Constant was defined in a previously added class: ', assoc key.
		].
	].
	"ikp..."
	aClass sharedPools do: [:pool |
		pool bindingsDo: [ :assoc |
			(constants includesKey: assoc key asString) ifTrue: [
				self error: 'Constant was defined in a previously added class: ', assoc key.
			].
		].
	].

	"check for instance variable name collisions"
	aClass instVarNames do: [ :varName |
		(variables includes: varName) ifTrue: [
			self error: 'Instance variable was defined in a previously added class: ', varName.
		].
	].

	"check for method name collisions"
	aClass selectors do: [ :sel |
		(methods includesKey: sel) ifTrue: [
			self error: 'Method was defined in a previously added class: ', sel.
		].
	].! !
!CCodeGenerator methodsFor: 'utilities'!
checkForGlobalUsage: vars in: aTMethod 
	| item |
	vars
		do: [:var | 
			"TPR - why the use of globalsAsSet here instead of globalVariables? 
			JMM - globalVariables is not initialized yet, variables is an OrderedCollection, 
				globalsAsSet returns variables as needed set"
			(self globalsAsSet includes: var)
				ifTrue: ["find the set of method names using this global var"
					item := globalVariableUsage
								at: var
								ifAbsent: [globalVariableUsage at: var put: Set new].
					"add this method name to that set"
					item add: aTMethod selector]].
	aTMethod referencesGlobalStructMakeZero! !
!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:48'!
codeString
	"Return a string containing all the C code for the code base. Used for testing."

	| stream |
	stream := ReadWriteStream on: (String new: 1000).
	self emitCCodeOn: stream doInlining: true doAssertions: true.
	^stream contents! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'dtl 6/7/2008 16:57'!
collectInlineList
	"Make a list of methods that should be inlined."
	"Details: The method must not include any inline C, since the translator cannot
	currently map variable names in inlined C code. The #inline: directive may be
	used to override this for cases in which the C code or declarations are harmless.
	Methods to be inlined must be small or called from only one place."

	| methodsNotToInline callsOf inlineIt hasCCode nodeCount senderCount
sel |
	methodsNotToInline := Set new: methods size.

	"build dictionary to record the number of calls to each method"
	callsOf := Dictionary new: methods size * 2.
	methods keys do: [ :s | callsOf at: s put: 0 ].

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"
	inlineList := Set new: methods size * 2.
	methods do: [ :m |
		inlineIt := #dontCare.
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode := true.
		] ifFalse: [
			hasCCode := m declarations size > 0.
			nodeCount := 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					sel := node selector.
					(sel = #cCode: or: [sel = #cCode:inSmalltalk:])
						ifTrue: [ hasCCode := true ].
					senderCount := callsOf at: sel ifAbsent: [ nil ].
					nil = senderCount ifFalse: [
						callsOf at: sel put: senderCount + 1.
					].
				].
				nodeCount := nodeCount + 1.
			].
			inlineIt := m extractInlineDirective.  "may be true, false, or
#dontCare"
		].
		(inlineIt ~= true and: [hasCCode or: [inlineIt = false]]) ifTrue: [
			"Don't inline if method has C code or if it contains a negative inline
			directive. If it contains a positive inline directive, permit inlining even
			if C code is present."
			methodsNotToInline add: m selector.
		] ifFalse: [
			((nodeCount < 40) or: [inlineIt = true]) ifTrue: [
				"inline if method has no C code and is either small or contains
inline directive"
				inlineList add: m selector.
			].
		].
	].

	callsOf associationsDo: [ :assoc |
		((assoc value = 1) and: [(methodsNotToInline includes: assoc key)
not]) ifTrue: [
			inlineList add: assoc key.
		].
	].! !
!CCodeGenerator methodsFor: 'accessing' stamp: 'eem 7/2/2008 16:01'!
currentMethod
	^currentMethod! !
!CCodeGenerator methodsFor: 'accessing' stamp: 'eem 7/2/2008 16:01'!
currentMethod: aTMethod
	currentMethod := aTMethod! !
!CCodeGenerator methodsFor: 'public' stamp: 'ar 3/16/2002 18:00'!
declareModuleName: nameString
	"add the declaration of a module name, version and local/external tag"

	self var: #moduleName declareC:'const char *moduleName =
#ifdef SQUEAK_BUILTIN_PLUGIN
	"', nameString,' (i)"
#else
	"', nameString,' (e)"
#endif
'.! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'qwaq 5/21/2010 12:17'!
doBasicInlining: inlineFlag
	"Inline the bodies of all methods that are suitable for inlining.
	This method does only the basic inlining suitable for both the core VM and plugins - no bytecode inlining etc"

	| pass progress |
	self collectInlineList.
	pass := 0.
	progress := true.
	[progress] whileTrue: [
		"repeatedly attempt to inline methods until no further progress is made"
		progress := false.
		('Inlining pass ', (pass := pass + 1) printString, '...')
			displayProgressAt: Sensor cursorPoint
			from: 0 to: methods size
			during: [:bar |
				(self sortMethods: methods) doWithIndex: [:m :i |
					bar value: i.
					currentMethod := m.
					(m tryToInlineMethodsIn: self)
						ifTrue: [progress := true]]]].

! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'dtl 9/8/2008 23:48'!
doInlining: inlineFlag
	"Inline the bodies of all methods that are suitable for inlining."
	"Modified slightly for the core VM translator, since the first level of inlining for the interpret loop must be performed in order that the instruction implementations can easily discover their addresses. Remember to inline the bytecode routines as well"

	inlineFlag ifFalse: [
		self inlineDispatchesInMethodNamed: #interpret localizingVars: #().
		^ self].
	self doBasicInlining: inlineFlag.
	self inlineCaseStatementBranchesInMethodNamed: #interpret localizingVars: #().
	'Inlining bytecodes'
		displayProgressAt: Sensor cursorPoint
		from: 1 to: 2
		during: [:bar |
			self inlineDispatchesInMethodNamed: #interpret
				localizingVars: #(currentBytecode localIP localSP localHomeContext localReturnContext localReturnValue).
			bar value: 1.
			self removeMethodsReferingToGlobals: #(
					currentBytecode localIP localSP localHomeContext)
				except: #(interpret).
			bar value: 2].

	"make receiver on the next line false to generate code for all methods, even those that are inlined or unused"
	true ifTrue: [
		(methods includesKey: #interpret) ifTrue: [
			"only prune when generating the interpreter itself"
			self pruneUnreachableMethods]].
! !
!CCodeGenerator methodsFor: 'utilities' stamp: ' 2/7/08 14:57'!
emitBuiltinConstructAsArgumentFor: msgNode on: aStream level: level
	"If the given selector is in the translation dictionary, translate it into a target code construct and return true. Otherwise, do nothing and return false."

	| action |
	action := asArgumentTranslationDict
				at: msgNode selector
				ifAbsent: [translationDict at: msgNode selector ifAbsent: [ ^false ]].
	self perform: action with: msgNode with: aStream with: level.
	^true! !
!CCodeGenerator methodsFor: 'utilities'!
emitBuiltinConstructFor: msgNode on: aStream level: level
	"If the given selector is in the translation dictionary, translate it into a target code construct and return true. Otherwise, do nothing and return false."

	| action |
	action := translationDict at: msgNode selector ifAbsent: [ ^false ].
	self perform: action with: msgNode with: aStream with: level.
	^true! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 1/28/2007 13:52'!
emitCCodeOn: aStream doAssertions: assertionFlag
	"Emit C code for all methods in the code base onto the given stream. All inlined method calls should already have been expanded."

	self emitCHeaderOn: aStream.
	self emitCConstantsOn: aStream.
	self emitCFunctionPrototypes: preparedMethodList on: aStream.
	self emitCVariablesOn: aStream.
'Writing Translated Code...'
displayProgressAt: Sensor cursorPoint
from: 0 to: methods size
during: [:bar |
	preparedMethodList doWithIndex: [ :m :i | bar value: i.
		m emitCCodeOn: aStream generator: self.
]].
	self emitExportsOn: aStream.
! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 1/28/2007 14:10'!
emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag
	"Emit C code for all methods in the code base onto the given stream. All inlined method calls should already have been expanded."

	self prepareMethodsInlined: inlineFlag doAssertions: assertionFlag.
	^ self emitCCodeOn: aStream doAssertions: assertionFlag
! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'jmv 10/26/2009 08:54'!
emitCConstantsOn: aStream
	"Store the global variable declarations on the given stream."
	| unused constList node |
	unused := constants keys asSet.
	methods do: [ :meth |
		meth parseTree nodesDo: [ :n |
			n isConstant ifTrue: [ unused remove: n name ifAbsent: []]]].
	constList := constants keys reject: [ :any | unused includes: any].
	aStream nextPutAll: '/*** Constants ***/';
		 cr.
	constList asSortedCollection do: [ :varName |
		node := constants at: varName.
		node name isEmpty ifFalse: [
			aStream nextPutAll: '#define '.
			aStream nextPutAll: node name.
			aStream space.
			aStream nextPutAll: (self cLiteralFor: node value).
			aStream cr
		].
	].
	aStream cr.! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 11/9/2006 06:22'!
emitCExpression: aParseNode on: aStream
	"Emit C code for the expression described by the given parse node."

	aParseNode isLeaf ifTrue: [
		"omit parens"
		aParseNode asExpression emitCCodeOn: aStream level: 0 generator: self.
	] ifFalse: [
		aStream nextPut: $(.
		aParseNode asExpression emitCCodeOn: aStream level: 0 generator: self.
		aStream nextPut: $).
	].! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'tpr 3/7/2003 19:55'!
emitCFunctionPrototypes: methodList on: aStream 
	"Store prototype declarations for all non-inlined methods on the given stream."
	| exporting |
	aStream nextPutAll: '/*** Function Prototypes ***/'; cr.
	exporting := false.
	methodList do: [:m | 
		m export
			ifTrue: [exporting
					ifFalse: 
						[aStream nextPutAll: '#pragma export on'; cr.
						exporting := true]]
			ifFalse: [exporting
					ifTrue: 
						[aStream nextPutAll: '#pragma export off'; cr.
						exporting := false]].
		m emitCFunctionPrototype: aStream generator: self.
		aStream nextPutAll: ';'; cr].
	exporting ifTrue: [aStream nextPutAll: '#pragma export off'; cr]! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 12/20/2009 23:39'!
emitCHeaderForPrimitivesOn: aStream
	"Write a C file header for compiled primitives onto the given stream."

	aStream
		nextPutAll: '/* Automatically generated from Squeak (';
		nextPutAll: VMMaker versionString;
		nextPutAll: ') on '.
	Time dateAndTimeNow do: [:e | aStream nextPutAll: e asString; nextPut: Character space].
	aStream
		nextPutAll: '*/';
		cr; cr;
		nextPutAll: '#include "sq.h"'; cr; cr.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].

	aStream nextPutAll: '
#include "sqMemoryAccess.h"

/*** Imported Functions/Variables ***/
extern sqInt stackValue(sqInt);
extern sqInt stackIntegerValue(sqInt);
extern sqInt successFlag;

/* allows accessing Strings in both C and Smalltalk */
#define asciiValue(c) c
'.
	aStream cr.! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 4/6/2010 00:14'!
emitCHeaderOn: aStream
	"Write a C file header onto the given stream."

	aStream nextPutAll: '/* '.
	aStream nextPutAll: VMMaker headerNotice.
	aStream nextPutAll: ' */'; cr.
	self emitGlobalStructFlagOn: aStream.
	aStream nextPutAll: '#include "sq.h"'; cr.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].

	"Default definitions for optional functions, provided for backward compatibility"
	self emitDefaultMacrosOn: aStream.

	aStream nextPutAll: '
#include "sqMemoryAccess.h"

sqInt printCallStack(void);
void defaultErrorProc(char *s) {
	/* Print an error message and exit. */
	static sqInt printingStack = false;

	printf("\n%s\n\n", s);
	if (!!printingStack) {
		/* flag prevents recursive error when trying to print a broken stack */
		printingStack = true;
		printCallStack();
	}
	exit(-1);
}
'.
	aStream cr.! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 11/9/2006 06:42'!
emitCTestBlock: aBlockNode on: aStream
	"Emit C code for the given block node to be used as a loop test."

	aBlockNode statements size > 1 ifTrue: [
		aBlockNode emitCCodeOn: aStream level: 0 generator: self.
	] ifFalse: [
		aBlockNode statements first asExpression emitCCodeOn: aStream level: 0 generator: self.
	].! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'tpr 4/12/2006 11:40'!
emitCVariablesOn: aStream 
	"Store the global variable declarations on the given stream."
	| varString |
	aStream nextPutAll: '/*** Variables ***/';
		 cr.
	variables asSortedCollection
		do: [:var | 
			varString := var asString.
			self isGeneratingPluginCode
				ifTrue: [varString = 'interpreterProxy'
						ifTrue: ["quite special..."
							aStream cr; nextPutAll: '#ifdef SQUEAK_BUILTIN_PLUGIN'.
							aStream cr; nextPutAll: 'extern'.
							aStream cr; nextPutAll: '#endif'; cr]
						ifFalse: [aStream nextPutAll: 'static ']].
			(variableDeclarations includesKey: varString)
				ifTrue: [aStream nextPutAll: (variableDeclarations at: varString) , ';'; cr]
				ifFalse: ["default variable declaration"
					aStream nextPutAll: 'sqInt ' , varString , ';'; cr]].
	aStream cr! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 4/6/2010 00:13'!
emitDefaultMacrosOn: aStream
	"Emit macros to provide default implementations of certain functions used by
	the interpreter. If not previously defined in config.h they will be defined here.
	The definitions will be available to any module that includes sqMemoryAccess.h.
	The default macros are chosen for backward compatibility with existing platform
	support code."

	aStream cr;
		nextPutAll: '#ifndef allocateMemoryMinimumImageFileHeaderSize'; cr;
		nextPutAll: ' /* Called by Interpreter>>allocateMemory:minimum:imageFile:headerSize: */'; cr;
		nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
		nextPutAll: ' #define allocateMemoryMinimumImageFileHeaderSize(',
						'heapSize, minimumMemory, fileStream, headerSize) \'; cr;
		nextPutAll: '    sqAllocateMemory(minimumMemory, heapSize)'; cr;
		nextPutAll: '#endif'; cr; cr;

		nextPutAll: '#ifndef sqImageFileReadEntireImage'; cr;
		nextPutAll: ' /* Called by Interpreter>>sqImage:read:size:length: */'; cr;
		nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
		nextPutAll: ' #define sqImageFileReadEntireImage(memoryAddress, ',
						'elementSize,  length, fileStream) \'; cr;
		nextPutAll: '    sqImageFileRead(memoryAddress, elementSize,  length, fileStream)'; cr;
		nextPutAll: '#endif'; cr; cr;

		nextPutAll: '#ifndef error'; cr;
		nextPutAll: ' /* error() function called from Interpreter */'; cr;
		nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
		nextPutAll: ' #define error(str) defaultErrorProc(str)'; cr;
		nextPutAll: '#endif'; cr; cr;

		nextPutAll: '#ifndef ioMicroSecondClock'; cr;
		nextPutAll: ' /* Called by Interpreter>>primitiveMicrosecondClock and GC methods */'; cr;
		nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
		nextPutAll: ' #define ioMicroSecondClock ioMSecs'; cr;
		nextPutAll: '#endif'; cr; cr;

		nextPutAll: '#ifndef ioUtcWithOffset'; cr;
		nextPutAll: ' /* Called by Interpreter>>primitiveUtcWithOffset */'; cr;
		nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
		nextPutAll: ' #define ioUtcWithOffset(clock, offset) setMicroSecondsandOffset(clock, offset)'; cr;
		nextPutAll: '#endif'; cr.

		self flag: #setMicroSeconds:andOffset:	"referenced by these macros"
! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 5/27/2010 21:40'!
emitDefineBytesPerWordOn: aStream
	"Define word size dependent constants. These are mirrored by class
	variables in ObjectMemory. The macro definitions here are used at compile
	time to permit building a VM for either 32-bit or 64-bit object memory from
	a single generated code base.
	
	If SQ_VI_BYTES_PER_WORD is defined as 8 (e.g. in config.h), then a VM for
	64-bit image will be built. Otherwise, a VM for 32-bit image is built."

	aStream cr;
		nextPutAll: '/*'; cr;
		nextPutAll: ' * define SQ_VI_BYTES_PER_WORD 8 for a 64-bit word size VM'; cr;
		nextPutAll: ' * and default to SQ_VI_BYTES_PER_WORD 4 for a 32-bit word size VM'; cr;
		nextPutAll: ' */'; cr;
		nextPutAll: '#ifndef SQ_VI_BYTES_PER_WORD'; cr;
		nextPutAll: '# define SQ_VI_BYTES_PER_WORD ';
		print: 4; cr; "default to word size 4"
		nextPutAll: '#endif'; cr; cr;
		nextPutAll: '#define BYTES_PER_WORD SQ_VI_BYTES_PER_WORD'; cr;
		nextPutAll: '#define BASE_HEADER_SIZE SQ_VI_BYTES_PER_WORD'; cr;

		"Define various constants that depend on BytesPerWord"
		nextPutAll: '#if (BYTES_PER_WORD == 4) // 32-bit object memory'; cr;
		nextPutAll: '# define WORD_MASK 0xffffffff'; cr; "(1 bitShift: BytesPerWord*8) - 1"
		nextPutAll: '# define SHIFT_FOR_WORD 2'; cr; "(BytesPerWord log: 2) rounded"
		nextPutAll: '# define SMALL_CONTEXT_SIZE 92'; cr; "ContextFixedSizePlusHeader + 16 * BytesPerWord"
		"Large contexts have 56 indexable fileds.  Max with single header word."
		"However note that in 64 bits, for now, large contexts have 3-word headers"
		nextPutAll: '# define LARGE_CONTEXT_SIZE 252'; cr; "ContextFixedSizePlusHeader + 56 * BytesPerWord."
		nextPutAll: '# define SIZE_MASK 0xfc'; cr; "Base header word bit field"
		nextPutAll: '# define LONG_SIZE_MASK 0xfffffffc'; cr; "Base header word bit field"
		nextPutAll: '# define SIZE_4_BIT 0'; cr;
		nextPutAll: '# define MARK_BIT 0x80000000'; cr; "Top bit, 1 bitShift: BytesPerWord*8 - 1"
		nextPutAll: '# define ROOT_BIT 0x40000000'; cr; "Next-to-top bit, 1 bitShift: BytesPerWord*8 - 2"
		nextPutAll: '# define ALL_BUT_MARK_BIT 0x7fffffff'; cr; "WordMask - MarkBit."
		nextPutAll: '# define ALL_BUT_ROOT_BIT 0xbfffffff'; cr; "WordMask - RootBit"
		nextPutAll: '# define ALL_BUT_TYPE_MASK 0xfffffffc'; cr; "WordMask - TypeMask"
		nextPutAll: '# define ALL_BUT_MARK_BIT_AND_TYPE_MASK 0x7ffffffc'; cr; "AllButTypeMask - MarkBit"
		nextPutAll: '# define ALL_BUT_HASH_BITS 0xe001ffff'; cr;

		nextPutAll: '#else // 64-bit object memory'; cr;
		nextPutAll: '# define WORD_MASK 0xffffffffffffffff'; cr;
		nextPutAll: '# define SHIFT_FOR_WORD 3'; cr;
		nextPutAll: '# define SMALL_CONTEXT_SIZE 184'; cr;
		nextPutAll: '# define LARGE_CONTEXT_SIZE 504'; cr;
		nextPutAll: '# define SIZE_MASK 0xf8'; cr; "Lose the 4 bit in temp 64-bit chunk format"
		nextPutAll: '# define LONG_SIZE_MASK 0xfffffffffffffff8'; cr;
		"The 4 bit is excluded from SIZE_MASK for 64-bit object memory, but need it"
		"for ST size, so define SIZE_4_BIT."
		nextPutAll: '# define SIZE_4_BIT 4'; cr;
		nextPutAll: '# define MARK_BIT 0x8000000000000000'; cr;
		nextPutAll: '# define ROOT_BIT 0x4000000000000000'; cr;
		nextPutAll: '# define ALL_BUT_MARK_BIT 0x7fffffffffffffff'; cr;
		nextPutAll: '# define ALL_BUT_ROOT_BIT 0xbfffffffffffffff'; cr;
		nextPutAll: '# define ALL_BUT_TYPE_MASK 0xfffffffffffffffc'; cr;
		nextPutAll: '# define ALL_BUT_MARK_BIT_AND_TYPE_MASK 0x7ffffffffffffffc'; cr;
		nextPutAll: '# define ALL_BUT_HASH_BITS 0xffffffffe001ffff'; cr;
		nextPutAll: '#endif //  (BYTES_PER_WORD == 4)'; cr
	
! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 4/6/2010 00:15'!
emitDefineMemoryAccessInImageOn: aStream
	"If MemoryAccess is present in the image, then define MEMORY_ACCESS_IN_IMAGE as
	a C preprocessor macro. When MEMORY_ACCESS_IN_IMAGE is defined, the traditional
	C preprocessor macros for low level memory access are ignored and will be replaced
	by directly translated (and inlined) SLANG versions of the same. This enables visibility
	of the memory access functions for debuggers and profilers."

	(Smalltalk classNamed: #MemoryAccess)
		ifNotNilDo: [:ma | ma isEnabled
			ifTrue: [aStream nextPutAll: '#define MEMORY_ACCESS_IN_IMAGE 1'; cr]]! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'tpr 1/10/2003 16:17'!
emitExportsOn: aStream
	"Store all the exported primitives in a form to be used by the internal named prim system"
	aStream nextPutAll:'

void* vm_exports[][3] = {'.
	self exportedPrimitiveNames do:[:primName|
		aStream cr;
			nextPutAll:'	{"", "'; 
			nextPutAll: primName; 
			nextPutAll:'", (void*)'; 
			nextPutAll: primName;
			nextPutAll:'},'.
	].
	aStream nextPutAll:'
	{NULL, NULL, NULL}
};
'.! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 9/10/2003 05:53'!
emitGlobalStructFlagOn: aStream
	"Default: do nothing.  Overridden in CCGenGlobalStruct."
! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 4/6/2010 00:16'!
emitVmmVersionOn: aStream
	"Emit a version string macro suitable for identifying source code version
	of this interpreter. This is expected to be used in conjunction with a similar
	identifier for platform source code version, such the the VM can identify
	the source code version for its platform source and matching VMMaker source."

	aStream nextPutAll: '#define VMMAKER_VERSION "';
		nextPutAll: VMMaker versionString;
		nextPut: $";
		cr
! !
!CCodeGenerator methodsFor: 'public' stamp: 'dtl 2/5/2007 07:45'!
exportedPrimitiveNames
	"Return an array of all exported primitives"
	^methods select:[:m| m export] thenCollect:[:m| m selectorForCodeGeneration copyWithout: $:].
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 10/5/2009 13:48'!
generateAddressOf: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPut: $(; nextPut: $&.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPut: $)! !
!CCodeGenerator methodsFor: 'C translation'!
generateAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' && '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'ar 10/3/1998 13:45'!
generateAsFloat: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'((double) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' )'.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 2/15/2009 16:38'!
generateAsInteger: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'((sqInt)'.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $)! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 1/3/2009 10:22'!
generateAsSymbol: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream.
	 The receiver is expected to be a TConstantNode."

	aStream nextPutAll: (self cFunctionNameFor: msgNode receiver nameOrValue)! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 2/15/2009 16:38'!
generateAsUnsignedInteger: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'((usqInt)'.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $)! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 6/24/2010 09:33'!
generateAt: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $[.
	msgNode args first emitCCodeAsExpressionOn: aStream level: level + 1 generator: self.
	aStream nextPut: $]! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 6/24/2010 09:33'!
generateAtPut: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $[.
	msgNode args first emitCCodeAsExpressionOn: aStream level: level + 1 generator: self.
	aStream nextPutAll: '] = '.
	self emitCExpression: msgNode args last on: aStream! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 5/18/2010 21:38'!
generateBaseHeaderSize: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: 'BASE_HEADER_SIZE'

! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 7/8/2008 20:21'!
generateBetweenAnd: msgNode on: aStream indent: level
	"Generate the C code for the between:and: message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' >= '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ') && ('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' <= '.
	self emitCExpression: msgNode args second on: aStream.
	aStream nextPutAll: '))'! !
!CCodeGenerator methodsFor: 'C translation'!
generateBitAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' & '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 7/16/2009 13:46'!
generateBitInvert32: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPut: $~.
	self emitCExpression: msgNode receiver on: aStream! !
!CCodeGenerator methodsFor: 'C translation'!
generateBitOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' | '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 8/4/2004 16:29'!
generateBitShift: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| arg rcvr |
	arg := msgNode args first.
	rcvr := msgNode receiver.
	arg isConstant ifTrue: [
		"bit shift amount is a constant"
		aStream nextPutAll: '((usqInt) '.
		self emitCExpression: rcvr on: aStream.
		arg value < 0 ifTrue: [
			aStream nextPutAll: ' >> ', arg value negated printString.
		] ifFalse: [
			aStream nextPutAll: ' << ', arg value printString.
		].
		aStream nextPutAll: ')'.
	] ifFalse: [
		"bit shift amount is an expression"
		aStream nextPutAll: '(('.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ' < 0) ? ((usqInt) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' >> -'.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ') : ((usqInt) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' << '.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: '))'.
	].! !
!CCodeGenerator methodsFor: 'C translation'!
generateBitXor: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' ^ '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 5/18/2010 21:33'!
generateBytesPerWord: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: 'BYTES_PER_WORD'
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 2/11/2009 13:53'!
generateCCoercion: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	aStream nextPutAll: msgNode args last value.
	aStream nextPutAll: ') '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPut: $)

! !
!CCodeGenerator methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:26'!
generateDeadCode
	"Answer whether we should generate 'dead code' branches. This can be useful for hacking the VM when used in conjunction with #useSymbolicConstants, e.g., for code like:
		DoAssertionChecks ifTrue:[
			...
		].

	we will generate

		#define DoAssertionChecks 0
		...
		if(DoAssertionChecks) {
			...
		}.

	allowing us to change the #define (or redefine it as a variable) for later use."
	^generateDeadCode! !
!CCodeGenerator methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:26'!
generateDeadCode: aBool
	"Indicate whether we should generate 'dead code' branches."
	generateDeadCode := aBool! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 6/9/2004 16:14'!
generateDivide: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| rcvr arg divisor |
	rcvr := msgNode receiver.
	arg := msgNode args first.
	(arg isConstant and:
	 [UseRightShiftForDivide and:
	 [(divisor := arg value) isInteger and:
	 [divisor isPowerOfTwo and:
	 [divisor > 0 and:
	 [divisor <= (1 bitShift: 31)]]]]])
	ifTrue: [
		"use signed (arithmetic) right shift instead of divide"
		aStream nextPutAll: '((sqInt) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' >> ', (divisor log: 2) asInteger printString.
		aStream nextPutAll: ')'.
	] ifFalse: [
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' / '.
		self emitCExpression: arg on: aStream].
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 11/9/2006 06:24'!
generateDoWhileFalse: msgNode on: aStream indent: level
	"Generate do {stmtList} while(!!(cond))"

	| stmts testStmt |
	stmts := msgNode receiver statements asOrderedCollection.
	testStmt := stmts removeLast.
	msgNode receiver setStatements: stmts.
	aStream nextPutAll: 'do {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} while(!!('.
	testStmt asExpression emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: '))'.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 11/9/2006 06:24'!
generateDoWhileTrue: msgNode on: aStream indent: level
	"Generate do {stmtList} while(cond)"

	| stmts testStmt |
	stmts := msgNode receiver statements asOrderedCollection.
	testStmt := stmts removeLast.
	msgNode receiver setStatements: stmts.
	aStream nextPutAll: 'do {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} while('.
	testStmt asExpression emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: ')'.! !
!CCodeGenerator methodsFor: 'C translation'!
generateEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' == '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThan: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' > '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThanOrEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' >= '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: ' 2/7/08 14:57'!
generateIfFalse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPutAll: 'if (!!('.
			msgNode receiver emitCCodeAsExpressionOn: aStream level: level + 1 generator: self.
			aStream nextPutAll: ')) {'; cr.
			msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
			level timesRepeat: [aStream tab].
			aStream nextPut: $}]
		ifNotNil:
			[:const |
			const ifFalse:
				[msgNode args first emitCCodeOn: aStream level: level generator: self]]! !
!CCodeGenerator methodsFor: 'C translation' stamp: ' 2/7/08 14:57'!
generateIfFalseAsArgument: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPutAll: '(!!('.
			 msgNode receiver emitCCodeAsArgumentOn: aStream level: 0 generator: self.
			aStream nextPut: $); crtab: level + 1; nextPut: $?; space.
			msgNode args last emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
			aStream crtab: level + 1; nextPutAll: ': 0)']
		ifNotNil:
			[:const|
			const ifFalse:
				[msgNode args first emitCCodeAsArgumentOn: aStream level: level generator: self]]! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 10/24/2010 16:15'!
generateIfFalseIfTrue: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPutAll: 'if ('.
			msgNode receiver emitCCodeAsExpressionOn: aStream level: level generator: self.
			aStream nextPutAll: ') {'; cr.
			msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
			aStream tab: level; nextPut: $}; nextPutAll: ' else {'; cr.
			msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
			aStream tab: level; nextPut: $}]
		ifNotNil:
			[:const |
			 (const ifTrue: [msgNode args last] ifFalse: [msgNode args first])
				emitCCodeOn: aStream level: level generator: self]! !
!CCodeGenerator methodsFor: 'C translation' stamp: ' 2/7/08 14:57'!
generateIfFalseIfTrueAsArgument: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPut: $(.
			msgNode receiver emitCCodeAsArgumentOn: aStream level: level generator: self.
			aStream crtab: level + 1; nextPut: $?; space.
			msgNode args last emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
			aStream crtab: level + 1; nextPut: $:; space.
			msgNode args first emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
			aStream nextPut: $)]
		ifNotNil:
			[:const|
			(const
				ifTrue: [msgNode args last]
				ifFalse: [msgNode args first])
					emitCCodeAsArgumentOn: aStream level: level generator: self]! !
!CCodeGenerator methodsFor: 'C translation' stamp: ' 2/7/08 14:57'!
generateIfTrue: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPutAll: 'if ('.
			msgNode receiver emitCCodeAsExpressionOn: aStream level: level generator: self.
			aStream nextPutAll: ') {'; cr.
			msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
			level timesRepeat: [ aStream tab ].
			aStream nextPut: $}]
		ifNotNil:
			[:const |
			const ifTrue:
				[msgNode args first emitCCodeOn: aStream level: level generator: self]]! !
!CCodeGenerator methodsFor: 'C translation' stamp: ' 2/7/08 14:57'!
generateIfTrueAsArgument: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPut: $(.
			 msgNode receiver emitCCodeAsArgumentOn: aStream level: level generator: self.
			 aStream crtab: level + 1; nextPut: $?; space.
			 msgNode args first emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
			 aStream crtab: level + 1; nextPutAll: ': 0)']
		ifNotNil:
			[:const|
			const ifTrue:
				[msgNode args first emitCCodeAsArgumentOn: aStream level: level generator: self]]! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 10/24/2010 16:14'!
generateIfTrueIfFalse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPutAll: 'if ('.
			msgNode receiver emitCCodeAsExpressionOn: aStream level: level generator: self.
			aStream nextPutAll: ') {'; cr.
			msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
			aStream tab: level; nextPut: $}; nextPutAll: ' else {'; cr.
			msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
			aStream tab: level; nextPut: $}]
		ifNotNil:
			[:const |
			(const ifTrue: [msgNode args first] ifFalse: [msgNode args last])
				emitCCodeOn: aStream level: level generator: self]! !
!CCodeGenerator methodsFor: 'C translation' stamp: ' 2/7/08 14:57'!
generateIfTrueIfFalseAsArgument: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	(self nilOrBooleanConstantReceiverOf: msgNode)
		ifNil:
			[aStream nextPut: $(.
			msgNode receiver emitCCodeAsArgumentOn: aStream level: level generator: self.
			aStream crtab: level + 1; nextPut: $?; space.
			msgNode args first emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
			aStream crtab: level + 1; nextPut: $:; space.
			msgNode args last emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
			aStream nextPut: $)]
		ifNotNil:
			[:const|
			(const ifTrue: [msgNode args first] ifFalse: [msgNode args last])
				emitCCodeAsArgumentOn: aStream level: level generator: self]! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 9/16/2009 18:06'!
generateInlineCCode: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream.
	 There are two forms, self cCode: aString ... and self cCode: aBlock."

	msgNode args first isConstant
		ifTrue: [aStream nextPutAll: msgNode args first value]
		ifFalse: [msgNode args first
					emitCCodeOn: aStream
					level: level
					generator: self]! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 12/14/2009 21:16'!
generateInlineCCodeAsArgument: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream.
	 There are two forms, self cCode: aString ... and self cCode: aBlock."

	msgNode args first isConstant
		ifTrue: [aStream nextPutAll: msgNode args first value]
		ifFalse: [msgNode args first
					emitCCodeAsArgumentOn: aStream
					level: level
					generator: self]! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 2/24/2009 14:54'!
generateInlineCPreprocessorDirective: msgNode on: aStream indent: level
	"Generate the C preprocessor directive for this message onto the given stream."

	aStream cr; nextPutAll: msgNode args first value! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 11/9/2006 19:47'!
generateInlineCppDirective: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream cr; nextPutAll: '# ', msgNode args first value.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 11/12/2006 17:30'!
generateInlineCppIfDef: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| comment |
	aStream cr; nextPutAll: '# ifdef ', msgNode args first value.
	comment := msgNode args third value.
	(comment isKindOf: String)
		ifTrue: [aStream nextPutAll: '  // ', comment]
		ifFalse: ["nil argument, ignore it"].
	aStream cr.
	msgNode isExpression
		ifTrue:
			[aStream tab: level + 1; nextPut: $(.
			msgNode args fourth asExpression
				emitCCodeOn: aStream level: level + 1 generator: self.
			aStream nextPut: $); cr]
		ifFalse:
			[msgNode args fourth
				emitCCodeOn: aStream level: level generator: self].
	aStream nextPutAll: '# endif  // ', msgNode args first value; cr; tab: level! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 11/12/2006 17:30'!
generateInlineCppIfDefElse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| comment alternateBlock alternateBlockIsNil |
	aStream cr; nextPutAll: '# ifdef ', msgNode args first value.
	comment := msgNode args third value.
	(comment isKindOf: String)
		ifTrue: [aStream nextPutAll: '  // ', comment]
		ifFalse: ["nil argument, ignore it"].
	aStream cr.
	msgNode isExpression
		ifTrue:
			[aStream tab: level + 1; nextPut: $(.
			msgNode args fourth asExpression
				emitCCodeOn: aStream level: level + 1 generator: self.
			aStream nextPut: $); cr]
		ifFalse:
			[msgNode args fourth
				emitCCodeOn: aStream level: level generator: self].
	alternateBlock := msgNode args fifth.
	alternateBlockIsNil := true. "check for nil #else clause"
	alternateBlock nodesDo: [:n |
		(n ~= alternateBlock and: [n name ~= 'nil'])
			ifTrue: [alternateBlockIsNil := false ]].
	(alternateBlockIsNil) ifFalse:
		[aStream nextPutAll: '# else'; cr.
		msgNode isExpression
			ifTrue:
				[aStream tab: level + 1; nextPut: $(.
				alternateBlock asExpression
					emitCCodeOn: aStream level: level + 1 generator: self.
				aStream nextPut: $); cr]
			ifFalse:
				[alternateBlock
					emitCCodeOn: aStream level: level generator: self]].
	aStream nextPutAll: '# endif  // ', msgNode args first value; cr; tab: level
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 5/17/2010 15:18'!
generateInlineCppIfElse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| comment alternateBlock alternateBlockIsNil |
	aStream cr; nextPutAll: '# if (', msgNode args first value, ')'.
	comment := msgNode args third value.
	(comment isKindOf: String)
		ifTrue: [aStream nextPutAll: '  // ', comment]
		ifFalse: ["nil argument, ignore it"].
	aStream cr.
	msgNode isExpression
		ifTrue:
			[aStream tab: level + 1; nextPut: $(.
			msgNode args fourth asExpression
				emitCCodeOn: aStream level: level + 1 generator: self.
			aStream nextPut: $); cr]
		ifFalse:
			[msgNode args fourth
				emitCCodeOn: aStream level: level generator: self].
	alternateBlock := msgNode args fifth.
	alternateBlockIsNil := true. "check for nil #else clause"
	alternateBlock nodesDo: [:n |
		(n ~= alternateBlock and: [n name ~= 'nil'])
			ifTrue: [alternateBlockIsNil := false ]].
	(alternateBlockIsNil) ifFalse:
		[aStream nextPutAll: '# else'; cr.
		msgNode isExpression
			ifTrue:
				[aStream tab: level + 1; nextPut: $(.
				alternateBlock asExpression
					emitCCodeOn: aStream level: level + 1 generator: self.
				aStream nextPut: $); cr]
			ifFalse:
				[alternateBlock
					emitCCodeOn: aStream level: level generator: self]].
	aStream nextPutAll: '# endif  // ', msgNode args first value; cr; tab: level
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 9/25/2010 10:13'!
generateInlineDirective: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '/* inline: '.
	aStream nextPutAll: msgNode args first value asString.
	aStream nextPutAll: ' */'.
! !
!CCodeGenerator methodsFor: 'C translation'!
generateIntegerObjectOf: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' << 1) | 1)'.! !
!CCodeGenerator methodsFor: 'C translation'!
generateIntegerValueOf: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' >> 1)'.! !
!CCodeGenerator methodsFor: 'C translation'!
generateIsIntegerObject: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' & 1)'.! !
!CCodeGenerator methodsFor: 'C translation'!
generateIsNil: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' == '.
	aStream nextPutAll: (self cLiteralFor: nil).! !
!CCodeGenerator methodsFor: 'C translation'!
generateLessThan: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation'!
generateLessThanOrEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' <= '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation'!
generateMax: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ') ? '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' : '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!CCodeGenerator methodsFor: 'C translation'!
generateMin: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ') ? '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' : '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ')'.! !
!CCodeGenerator methodsFor: 'C translation'!
generateMinus: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' - '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation'!
generateModulo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' % '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 7/8/2008 17:47'!
generateNegated: msgNode on: aStream indent: level
	"Generate the C code for teh negated message onto the given stream."

	aStream nextPut: $-.
	self emitCExpression: msgNode receiver on: aStream! !
!CCodeGenerator methodsFor: 'C translation'!
generateNot: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '!!'.
	self emitCExpression: msgNode receiver on: aStream.! !
!CCodeGenerator methodsFor: 'C translation'!
generateNotEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' !!= '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation'!
generateNotNil: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' !!= '.
	aStream nextPutAll: (self cLiteralFor: nil).! !
!CCodeGenerator methodsFor: 'C translation'!
generateOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' || '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 1/18/2009 23:34'!
generatePerform: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode args first on: aStream.
	aStream nextPut: $(.
	(msgNode args copyFrom: 2 to: msgNode args size) do:[:arg|
		self emitCExpression: arg on: aStream.
	] separatedBy:[aStream nextPutAll:', '].
	aStream nextPut: $)! !
!CCodeGenerator methodsFor: 'C translation'!
generatePlus: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' + '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'ATG 4/8/2004 15:03'!
generatePreDecrement: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode := msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'preDecrement can only be applied to variables' ].
	aStream nextPutAll: '--'.
	aStream nextPutAll: (self returnPrefixFromVariable: varNode name).
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 9/11/2003 20:08'!
generatePreIncrement: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode := msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'preIncrement can only be applied to variables' ].
	aStream nextPutAll: '++'.
	aStream nextPutAll: (self returnPrefixFromVariable: varNode name).
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'ar 2/15/1999 21:43'!
generateRaisedTo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'pow('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll:')'.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 10/24/2010 15:41'!
generateSequentialAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' && ('.
	self emitCTestBlock: msgNode args first on: aStream.
	aStream nextPut: $)! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 10/24/2010 15:41'!
generateSequentialOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."
	"Note: PP 2.3 compiler produces two arguments for or:, presumably
	 to help with inlining later. Taking the last agument should do the correct
	 thing even if your compiler is different."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' || ('.
	self emitCTestBlock: msgNode args last on: aStream.
	aStream nextPutAll: ')'! !
!CCodeGenerator methodsFor: 'C translation'!
generateSharedCodeDirective: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '/* common code: '.
	aStream nextPutAll: msgNode args first value.
	aStream nextPutAll: ' */'.
! !
!CCodeGenerator methodsFor: 'C translation'!
generateShiftLeft: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' << '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 8/4/2004 18:25'!
generateShiftRight: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((usqInt) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ')'.
	aStream nextPutAll: ' >> '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 3/19/2009 16:17'!
generateSignedBitShift: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| arg |
	(arg := msgNode args first) isConstant
		ifTrue: "bit shift amount is a constant"
			[aStream nextPut: $(; nextPutAll: '(signed)'.
			self emitCExpression: msgNode receiver on: aStream.
			arg value < 0
				ifTrue: [aStream nextPutAll: ' >> ', arg value negated printString]
				ifFalse: [aStream nextPutAll: ' << ', arg value printString].
			aStream nextPut: $)]
		ifFalse: "bit shift amount is an expression"
			[aStream nextPutAll: '(('.
			self emitCExpression: arg on: aStream.
			aStream nextPutAll: ' < 0) ? ('; nextPutAll: '(signed)'.
			self emitCExpression: msgNode receiver on: aStream.
			aStream nextPutAll: ' >> -'.
			self emitCExpression: arg on: aStream.
			aStream nextPutAll: ') : ('; nextPutAll: '(signed)'.
			self emitCExpression: msgNode receiver on: aStream.
			aStream nextPutAll: ' << '.
			self emitCExpression: arg on: aStream.
			aStream nextPutAll: '))']! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 3/5/2009 10:27'!
generateSignedIntFromLong: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((sqInt) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $)

! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 3/2/2009 20:48'!
generateSignedIntFromShort: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((short)'.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $)

! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 3/5/2009 10:28'!
generateSignedIntToLong: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((usqInt) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $)

! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 3/5/2009 10:28'!
generateSignedIntToShort: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((usqInt) (short)'.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPut: $)

! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 2/26/2009 10:18'!
generateSmalltalkMetaError: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: 'error("'; nextPutAll: msgNode selector; nextPutAll: '")'! !
!CCodeGenerator methodsFor: 'C translation'!
generateTimes: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' * '.
	self emitCExpression: msgNode args first on: aStream.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'eem 7/8/2008 17:40'!
generateToByDo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| iterationVar step negative |
	(msgNode args last args size = 1) ifFalse: [
		self error: 'wrong number of block arguments'.
	].
	iterationVar := msgNode args last args first.
	aStream nextPutAll: 'for (', iterationVar, ' = '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '; ', iterationVar.
	negative := ((step := msgNode args at: 2) isConstant and: [step value < 0])
				or: [step isSend and: [step selector == #negated
					and: [step receiver isConstant and: [step receiver value >= 0]]]].
	aStream nextPutAll: (negative ifTrue: [' >= '] ifFalse: [' <= ']).
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: '; ', iterationVar, ' += '.
	self emitCExpression: step on: aStream.
	aStream nextPutAll: ') {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !
!CCodeGenerator methodsFor: 'C translation'!
generateToDo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| iterationVar |
	(msgNode args last args size = 1) ifFalse: [
		self error: 'wrong number of block arguments'.
	].
	iterationVar := msgNode args last args first.
	aStream nextPutAll: 'for (', iterationVar, ' = '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '; ', iterationVar, ' <= '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: '; ', iterationVar, '++) {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'tpr 7/26/2003 10:23'!
generateTouch: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream - which is to say absolutely nothing"
! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:41'!
generateWhileFalse: msgNode on: aStream indent: level
	"Generate C code for a loop in one of the following formats, as appropriate:
		while(!!(cond)) { stmtList }
		do {stmtList} while(!!(cond))
		while(1) {stmtListA; if (cond) break; stmtListB}"

	msgNode receiver statements size <= 1
		ifTrue: [^self generateWhileFalseLoop: msgNode on: aStream indent: level].
	msgNode args first isNilStmtListNode
		ifTrue: [^self generateDoWhileFalse: msgNode on: aStream indent: level].
	^self generateWhileForeverBreakTrueLoop: msgNode on: aStream indent: level! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:41'!
generateWhileFalseLoop: msgNode on: aStream indent: level
	"Generate while(!!(cond)) {stmtList}."

	aStream nextPutAll: 'while (!!('.
	self emitCTestBlock: msgNode receiver on: aStream.
	aStream nextPutAll: ')) {'; cr.
	msgNode args first isNilStmtListNode ifFalse:
		[msgNode args first emitCCodeOn: aStream level: level + 1 generator: self].
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 11/9/2006 06:28'!
generateWhileForeverBreakFalseLoop: msgNode on: aStream indent: level
	"Generate while(1) {stmtListA; if(!!(cond)) break; stmtListB}."

	| stmts testStmt |
	stmts := msgNode receiver statements asOrderedCollection.
	testStmt := stmts removeLast.
	msgNode receiver setStatements: stmts.
	level - 1 timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'while (1) {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	(level + 1) timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'if (!!('.
	testStmt asExpression emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: ')) break;'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 11/9/2006 06:28'!
generateWhileForeverBreakTrueLoop: msgNode on: aStream indent: level
	"Generate while(1) {stmtListA; if(cond) break; stmtListB}."

	| stmts testStmt |
	stmts := msgNode receiver statements asOrderedCollection.
	testStmt := stmts removeLast.
	msgNode receiver setStatements: stmts.
	level - 1 timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'while (1) {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	(level + 1) timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'if ('.
	testStmt asExpression emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: ') break;'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:41'!
generateWhileTrue: msgNode on: aStream indent: level
	"Generate C code for a loop in one of the following formats, as appropriate:
		while(cond) { stmtList }
		do {stmtList} while(cond)
		while(1) {stmtListA; if (!!(cond)) break; stmtListB}"

	msgNode receiver statements size <= 1
		ifTrue: [^self generateWhileTrueLoop: msgNode on: aStream indent: level].
	msgNode args first isNilStmtListNode
		ifTrue: [^self generateDoWhileTrue: msgNode on: aStream indent: level].
	^self generateWhileForeverBreakFalseLoop: msgNode on: aStream indent: level! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:38'!
generateWhileTrueLoop: msgNode on: aStream indent: level
	"Generate while(cond) {stmtList}."

	aStream nextPutAll: 'while ('.
	self emitCTestBlock: msgNode receiver on: aStream.
	aStream nextPutAll: ') {'; cr.
	msgNode args first isNilStmtListNode ifFalse:
		[msgNode args first emitCCodeOn: aStream level: level + 1 generator: self].
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !
!CCodeGenerator methodsFor: 'public'!
globalsAsSet
	"Used by the inliner to avoid name clashes with global variables."

	((variablesSetCache == nil) or:
	 [variablesSetCache size ~= variables size]) ifTrue: [
		variablesSetCache := variables asSet.
	].
	^ variablesSetCache! !
!CCodeGenerator methodsFor: 'public' stamp: 'dtl 10/17/2010 19:12'!
initialize
	translationDict := Dictionary new.
	inlineList := Array new.
	constants := Dictionary new: 100.
	variables := OrderedCollection new: 100.
	variableDeclarations := Dictionary new: 100.
	methods := Dictionary new: 500.
	self initializeCTranslationDictionary.
	headerFiles := OrderedCollection new.
	globalVariableUsage := Dictionary new.
	useSymbolicConstants := true.
	generateDeadCode := true.
	scopeStack := OrderedCollection new.! !
!CCodeGenerator methodsFor: 'C translation' stamp: 'dtl 10/17/2010 19:54'!
initializeCTranslationDictionary 
	"Initialize the dictionary mapping message names to actions for C code generation."

	| pairs |
	translationDict := Dictionary new: 200.
	pairs := #(
	#&				#generateAnd:on:indent:
	#|				#generateOr:on:indent:
	#and:			#generateSequentialAnd:on:indent:
	#or:			#generateSequentialOr:on:indent:
	#not			#generateNot:on:indent:

	#+				#generatePlus:on:indent:
	#-				#generateMinus:on:indent:
	#negated		#generateNegated:on:indent:
	#*				#generateTimes:on:indent:
	#/				#generateDivide:on:indent:
	#//				#generateDivide:on:indent:
	#\\				#generateModulo:on:indent:
	#<<			#generateShiftLeft:on:indent:
	#>>			#generateShiftRight:on:indent:
	#min:			#generateMin:on:indent:
	#max:			#generateMax:on:indent:
	#between:and:	#generateBetweenAnd:on:indent:

	#bitAnd:		#generateBitAnd:on:indent:
	#bitOr:			#generateBitOr:on:indent:
	#bitXor:		#generateBitXor:on:indent:
	#bitShift:		#generateBitShift:on:indent:
	#signedBitShift:	#generateSignedBitShift:on:indent:
	#bitInvert32		#generateBitInvert32:on:indent:

	#<				#generateLessThan:on:indent:
	#<=			#generateLessThanOrEqual:on:indent:
	#=				#generateEqual:on:indent:
	#>				#generateGreaterThan:on:indent:
	#>=			#generateGreaterThanOrEqual:on:indent:
	#~=			#generateNotEqual:on:indent:
	#==			#generateEqual:on:indent:
	#~~			#generateNotEqual:on:indent:
	#isNil			#generateIsNil:on:indent:
	#notNil			#generateNotNil:on:indent:

	#whileTrue: 	#generateWhileTrue:on:indent:
	#whileFalse:	#generateWhileFalse:on:indent:
	#whileTrue 		#generateDoWhileTrue:on:indent:
	#whileFalse		#generateDoWhileFalse:on:indent:
	#to:do:			#generateToDo:on:indent:
	#to:by:do:		#generateToByDo:on:indent:

	#ifTrue:			#generateIfTrue:on:indent:
	#ifFalse:		#generateIfFalse:on:indent:
	#ifTrue:ifFalse:	#generateIfTrueIfFalse:on:indent:
	#ifFalse:ifTrue:	#generateIfFalseIfTrue:on:indent:

	#at:			#generateAt:on:indent:
	#at:put:			#generateAtPut:on:indent:
	#basicAt:		#generateAt:on:indent:
	#basicAt:put:	#generateAtPut:on:indent:

	#integerValueOf:			#generateIntegerValueOf:on:indent:
	#integerObjectOf:			#generateIntegerObjectOf:on:indent:
	#isIntegerObject: 			#generateIsIntegerObject:on:indent:
	#cCode:					#generateInlineCCode:on:indent:
	#cCode:inSmalltalk:			#generateInlineCCode:on:indent:
	#cPreprocessorDirective:	#generateInlineCPreprocessorDirective:on:indent:
	#preprocessorExpression:	#generateInlineCppDirective:on:indent:
	#isDefined:inSmalltalk:comment:ifTrue:	#generateInlineCppIfDef:on:indent:
	#isDefined:inSmalltalk:comment:ifTrue:ifFalse:	#generateInlineCppIfDefElse:on:indent:
	#isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse:	#generateInlineCppIfElse:on:indent:
	#cCoerce:to:				#generateCCoercion:on:indent:
	#cCoerceSimple:to:			#generateCCoercion:on:indent:
	#addressOf:				#generateAddressOf:on:indent:
	#signedIntFromLong			#generateSignedIntFromLong:on:indent:
	#signedIntToLong			#generateSignedIntToLong:on:indent:
	#signedIntFromShort		#generateSignedIntFromShort:on:indent:
	#signedIntToShort			#generateSignedIntToShort:on:indent:
	#preIncrement				#generatePreIncrement:on:indent:
	#preDecrement				#generatePreDecrement:on:indent:
	#inline:						#generateInlineDirective:on:indent:
	#asFloat					#generateAsFloat:on:indent:
	#asInteger					#generateAsInteger:on:indent:
	#asUnsignedInteger			#generateAsUnsignedInteger:on:indent:
	#asSymbol					#generateAsSymbol:on:indent:
	#anyMask:					#generateBitAnd:on:indent:
	#raisedTo:					#generateRaisedTo:on:indent:
	#touch:						#generateTouch:on:indent:
	#bytesPerWord		#generateBytesPerWord:on:indent:
	#baseHeaderSize		#generateBaseHeaderSize:on:indent:

	#sharedCodeNamed:inCase:		#generateSharedCodeDirective:on:indent:

	#perform:							#generatePerform:on:indent:
	#perform:with:						#generatePerform:on:indent:
	#perform:with:with:					#generatePerform:on:indent:
	#perform:with:with:with:				#generatePerform:on:indent:
	#perform:with:with:with:with:		#generatePerform:on:indent:
	#perform:with:with:with:with:with:	#generatePerform:on:indent:

	#shouldNotImplement				#generateSmalltalkMetaError:on:indent:
	#shouldBeImplemented				#generateSmalltalkMetaError:on:indent:
	).

	1 to: pairs size by: 2 do: [:i |
		translationDict at: (pairs at: i) put: (pairs at: i + 1)].

	pairs := #(
	#ifTrue:				#generateIfTrueAsArgument:on:indent:	
	#ifFalse:			#generateIfFalseAsArgument:on:indent:
	#ifTrue:ifFalse:		#generateIfTrueIfFalseAsArgument:on:indent:
	#ifFalse:ifTrue:		#generateIfFalseIfTrueAsArgument:on:indent:
	#cCode:			#generateInlineCCodeAsArgument:on:indent:
	#cCode:inSmalltalk:	#generateInlineCCodeAsArgument:on:indent:
	).

	asArgumentTranslationDict := Dictionary new: 8.
	1 to: pairs size by: 2 do: [:i |
		asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'dtl 6/21/2008 12:54'!
inlineCaseStatementBranchesInMethodNamed: selector localizingVars: varsList 
	"Inline case statement branches in the method with the given name."
	(self methodNamed: selector)
		ifNotNilDo: [:m | m inlineCaseStatementBranchesIn: self localizingVars: varsList]! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'ar 7/8/2003 11:27'!
inlineDispatchesInMethodNamed: selector localizingVars: varsList
	"Inline dispatches (case statements) in the method with the given name."

	| m varString |
	m := self methodNamed: selector.
	m = nil ifFalse: [
		m inlineCaseStatementBranchesIn: self localizingVars: varsList.
		m parseTree nodesDo: [ :n |
			n isCaseStmt ifTrue: [
				n customizeShortCasesForDispatchVar: 'currentBytecode' in: self method: m.
			].
		].
	].
	variables := variables asOrderedCollection.
	varsList do: [ :v |
		varString := v asString.
		variables remove: varString ifAbsent: [].
		(variableDeclarations includesKey: varString) ifTrue: [
			m declarations at: v asString put: (variableDeclarations at: varString).
			variableDeclarations removeKey: varString.
		].
	].
! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'ar 7/8/2003 11:04'!
isCLiteral: anObject
	(anObject isKindOf: Integer) ifTrue: [^true].
	(anObject isKindOf: String) ifTrue: [^true].
	(anObject isKindOf: Float) ifTrue: [^true].
	anObject == nil ifTrue: [^true].
	anObject == true ifTrue: [^true].			"ikp"
	anObject == false ifTrue: [^true].			"ikp"
	(anObject isKindOf: Character) ifTrue:[^true]. "ar"
	^false! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'ar 10/7/1998 17:53'!
isGeneratingPluginCode
	^false! !
!CCodeGenerator methodsFor: 'public' stamp: 'JMM 11/28/2002 11:52'!
isGlobalStructureBuild
	^false! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'eem 2/9/2009 20:41'!
isNonArgumentImplicitReceiverVariableName: aString
	^(self typeOfVariable: aString) == #implicit
	    or: [vmClass
			ifNil: [#('interpreterProxy' 'self') includes: aString]
	 		ifNotNil: [vmClass isNonArgumentImplicitReceiverVariableName: aString]]! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'eem 12/15/2008 18:38'!
isPointerToStructVariableName: varName "<String>"
	^self isTypePointerToStruct: (self typeOfVariable: varName)! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'eem (auto rename) 12/15/2008 18:38'!
isTypePointerToStruct: type "<String>"
	^vmClass notNil
	  and: [vmClass isTypePointerToStruct: type]! !
!CCodeGenerator methodsFor: 'utilities'!
localizeGlobalVariables
	| candidates procedure |

	"find all globals used in only one method"
	candidates := globalVariableUsage select: [:e | e size = 1].
	variables removeAllFoundIn: candidates keys.

	"move any suitable global to be local to the single method using it"
	candidates keysAndValuesDo: [:key :targets | 
		targets do: [:name |
			procedure := methods at: name.
			procedure locals add: key.
			variableDeclarations at: key ifPresent: [:v | 
				procedure declarations at: key put: v.
				variableDeclarations removeKey: key]]].! !
!CCodeGenerator methodsFor: 'inlining'!
mayInline: sel
	"Answer true if the method with the given selector may be inlined."

	^ inlineList includes: sel! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'dtl 7/3/2008 12:16'!
memoryAccessSelectors
	"Answer the selectors used for low level memory access. These are traditionally
	implemented as C preprocessor macros (or static inlined functions) in the external
	support code, but may also be implemented as Smalltalk methods for translation to C."

	^ { #byteAt: . #byteAt:put: .
		#shortAt: . #shortAt:put: .
		#intAt: . #intAt:put: .
		#longAt: . #longAt:put: .
		#byteAtPointer: . #byteAtPointer:put: .
		#shortAtPointer: . #shortAtPointer:put: .
		#intAtPointer: . #intAtPointer:put: .
		#longAtPointer: . #longAtPointer:put: }! !
!CCodeGenerator methodsFor: 'utilities'!
methodNamed: selector
	"Answer the method in the code base with the given selector."

	^ methods at: selector ifAbsent: [ nil ]! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'ls 10/10/1999 13:55'!
methodStatsString
	"Return a string describing the size, # of locals, and # of senders of
each method. Note methods that have inline C code or C declarations."

	| methodsWithCCode sizesOf callsOf hasCCode nodeCount senderCount s
calls registers selr m |
	methodsWithCCode := Set new: methods size.
	sizesOf := Dictionary new: methods size * 2.  "selector -> nodeCount"
	callsOf := Dictionary new: methods size * 2.  "selector -> senderCount"

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"

	methods do: [ :m0 |  m := m0.
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode := true.
		] ifFalse: [
			hasCCode := m declarations size > 0.
			nodeCount := 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					selr := node selector.
					selr = #cCode: ifTrue: [ hasCCode := true ].
					senderCount := callsOf at: selr ifAbsent: [ 0 ].
					callsOf at: selr put: senderCount + 1.
				].
				nodeCount := nodeCount + 1.
			].
		].
		hasCCode ifTrue: [ methodsWithCCode add: m selector ].
		sizesOf at: m selector put: nodeCount.
	].

	s := WriteStream on: (String new: 5000).
	methods keys asSortedCollection do: [ :sel |
		m := methods at: sel.
		registers := m locals size + m args size.
		calls := callsOf at: sel ifAbsent: [0].
		registers > 11 ifTrue: [
			s nextPutAll: sel; tab.
			s nextPutAll: (sizesOf at: sel) printString; tab.
			s nextPutAll: calls printString; tab.
			s nextPutAll: registers printString; tab.
			(methodsWithCCode includes: sel) ifTrue: [ s nextPutAll: 'CCode' ].
		s cr.
		].
	].
	^ s contents! !
!CCodeGenerator methodsFor: 'utilities'!
methodsReferringToGlobal: v
	"Return a collection of methods that refer to the given global variable."

	| out |
	out := OrderedCollection new.
	methods associationsDo: [ :assoc |
		(assoc value freeVariableReferences includes: v) ifTrue: [
			out add: assoc key.
		].
	].
	^ out! !
!CCodeGenerator methodsFor: 'utilities'!
methodsThatCanInvoke: aSelectorList
	"Return a set of methods that can invoke one of the given selectors, either directly or via a sequence of intermediate methods."

	| out todo sel mSelector |
	out := Set new.
	todo := aSelectorList copy asOrderedCollection.
	[todo isEmpty] whileFalse: [
		sel := todo removeFirst.
		out add: sel.
		methods do: [ :m |
			(m allCalls includes: sel) ifTrue: [
				mSelector := m selector.
				((out includes: mSelector) or:
				 [todo includes: mSelector]) ifFalse: [
					todo add: mSelector.
				].
			].
		].
	].
	^ out
	! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'ar 7/8/2003 11:16'!
nilOrBooleanConstantReceiverOf: sendNode
	"Answer nil or the boolean constant that is the receiver of the given message send. Used to suppress conditional code when the condition is a translation-time constant."

	| rcvr val |
	generateDeadCode ifTrue:[^nil].
	rcvr := sendNode receiver.
	rcvr isConstant ifTrue: [
		val := rcvr value.
		((val == true) or: [val == false]) ifTrue: [^ val]].
	^ nil
! !
!CCodeGenerator methodsFor: 'utilities'!
prepareMethods
	"Prepare methods for browsing."

	| globals |
	globals := Set new: 200.
	globals addAll: variables.
	methods do: [ :m |
		(m locals, m args) do: [ :var |
			(globals includes: var) ifTrue: [
				self error: 'Local variable name may mask global when inlining: ', var.
			].
			(methods includesKey: var) ifTrue: [
				self error: 'Local variable name may mask method when inlining: ', var.
			].	
		].
		m bindClassVariablesIn: constants.
		m prepareMethodIn: self.
	].! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'dtl 1/28/2007 14:10'!
prepareMethodsInlined: inlineFlag doAssertions: assertionFlag
	"Prepare to emit C code for all methods in the code base. All inlined method calls should be expanded. Answer a list of methods to be emitted as C code."

	| verbose methodList |
	"method preparation"
	verbose := false.
	self prepareMethods.
	verbose ifTrue: [
		self printUnboundCallWarnings.
		self printUnboundVariableReferenceWarnings.
		Transcript cr.
	].
	assertionFlag ifFalse: [ self removeAssertions ].
	self doInlining: inlineFlag.

	"code generation"

	methodList := methods asSortedCollection: [ :m1 :m2 | m1 selector < m2 selector ].
	"clean out no longer valid variable names and then handle any global
		variable usage in each method"
	methodList do: [:m | self checkForGlobalUsage: m removeUnusedTemps in: m].
	self localizeGlobalVariables.
	^ preparedMethodList := methodList
! !
!CCodeGenerator methodsFor: 'private' stamp: 'sma 3/3/2000 12:08'!
printArray: array on: aStream
	| first |
	first := true.
	1 to: array size do:
		[:i |
		first 
			ifTrue: [first := false]
			ifFalse: [aStream nextPutAll: ', '].
		i \\ 16 = 1 ifTrue: [aStream cr].
		self printInt: (array at: i) on: aStream]! !
!CCodeGenerator methodsFor: 'private' stamp: 'sma 3/3/2000 12:13'!
printInt: int on: aStream
	aStream print: int.
	(int between: -2147483648 and: 2147483647)
		ifFalse: [(int between: 2147483648 and: 4294967295)
			ifTrue: [aStream nextPut: $U]
			ifFalse: [aStream nextPut: $L]]! !
!CCodeGenerator methodsFor: 'error notification'!
printUnboundCallWarnings
	"Print a warning message for every unbound method call in the code base."

	| knownSelectors undefinedCalls |
	undefinedCalls := Dictionary new.
	knownSelectors := translationDict keys asSet.
	knownSelectors add: #error:.
	methods do: [ :m | knownSelectors add: m selector ].
	methods do: [ :m |
		m allCalls do: [ :sel |
			(knownSelectors includes: sel) ifFalse: [
				(undefinedCalls includesKey: sel)
					ifTrue: [ (undefinedCalls at: sel) add: m selector ]
					ifFalse: [ undefinedCalls at: sel put: (OrderedCollection with: m selector) ].
			].
		].
	].

	Transcript cr.
	undefinedCalls keys asSortedCollection do: [ :undefined |
		Transcript show: undefined, ' -- undefined method sent by:'; cr.
		(undefinedCalls at: undefined) do: [ :caller |
			Transcript tab; show: caller; cr.
		].
	].! !
!CCodeGenerator methodsFor: 'error notification'!
printUnboundVariableReferenceWarnings
	"Print a warning message for every unbound variable reference in the code base."

	| undefinedRefs globalVars knownVars |
	undefinedRefs := Dictionary new.
	globalVars := Set new: 100.
	globalVars addAll: variables.
	methods do: [ :m |
		knownVars := globalVars copy.
		m args do: [ :var | knownVars add: var ].
		m locals do: [ :var | knownVars add: var ].
		m freeVariableReferences do: [ :varName |
			(knownVars includes: varName) ifFalse: [
				(undefinedRefs includesKey: varName)
					ifTrue: [ (undefinedRefs at: varName) add: m selector ]
					ifFalse: [ undefinedRefs at: varName put: (OrderedCollection with: m selector) ].
			].
		].
	].

	Transcript cr.
	undefinedRefs keys asSortedCollection do: [ :var |
		Transcript show: var, ' -- undefined variable used in:'; cr.
		(undefinedRefs at: var) do: [ :sel |
			Transcript tab; show: sel; cr.
		].
	].! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'ar 2/3/2001 17:08'!
pruneMethods: selectorList
	"Explicitly prune some methods"
	selectorList do:[:sel| methods removeKey: sel ifAbsent:[]].! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'tpr 3/2/2004 11:09'!
pruneUnreachableMethods
	"Remove any methods that are not reachable. Retain methods needed by the translated classes - see implementors of requiredMethodNames"
 	
	| newMethods |
	"add all the exported methods and all the called methods to the dNRML"
	methods do: [ :m |
		m export ifTrue:[doNotRemoveMethodList add: m selector].
		doNotRemoveMethodList addAll: m allCalls].

	"build a new dictionary of methods from the collection of all the ones to keep"			
	newMethods := Dictionary new: doNotRemoveMethodList size.
	doNotRemoveMethodList do:[:sel|
		methods at: sel ifPresent:[:meth| newMethods at: sel put: meth]].
	methods := newMethods! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'eem 7/2/2008 14:21'!
pushScope: variableToType "<Dictionary>" while: aBlock
	scopeStack addLast: variableToType.
	^aBlock ensure: [scopeStack removeLast]! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	"Remove all assertions in method bodies.  This is for the benefit of inlining, which
	fails to recognise and disregard empty method bodies when checking the inlinability
	of sends."

	| newMethods |
	newMethods := Dictionary new.
	'Removing assertions...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: methods size
		during: [ :bar |
			methods doWithIndex: [ :m :i |
				bar value: i.
				m isAssertion ifFalse: [
					newMethods at: m selector put: m.
					m removeAssertions]]].
	methods := newMethods.! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'dtl 6/21/2008 09:21'!
removeMethodsReferingToGlobals: varList except: methodNames
	"Remove any methods (presumably inlined) that still contain references to the given obsolete global variables."

	| varListAsStrings mVars |
	varListAsStrings := varList collect: [ :sym | sym asString ].
		(methods keys copyWithoutAll: methodNames) do: [ :sel |
			mVars := (self methodNamed: sel) freeVariableReferences asSet.
			(mVars includesAnyOf: varListAsStrings)
				ifTrue: [methods removeKey: sel ifAbsent: []]]
! !
!CCodeGenerator methodsFor: 'utilities'!
reportRecursiveMethods
	"Report in transcript all methods that can call themselves directly or indirectly or via a chain of N intermediate methods."

	| visited calls newCalls sel called |
	methods do: [: m |
		visited := translationDict keys asSet.
		calls := m allCalls asOrderedCollection.
		5 timesRepeat: [
			newCalls := Set new: 50.
			[calls isEmpty] whileFalse: [
				sel := calls removeFirst.
				sel = m selector ifTrue: [
					Transcript show: m selector, ' is recursive'; cr.
				] ifFalse: [
					(visited includes: sel) ifFalse: [
						called := self methodNamed: sel.
						called = nil ifFalse: [ newCalls addAll: called allCalls ].
					].
					visited add: sel.
				].
			].
			calls := newCalls asOrderedCollection.
		].
	].! !
!CCodeGenerator methodsFor: 'inlining' stamp: 'tpr 2/27/2004 18:49'!
retainMethods: aListOfMethodsToKeep
"add aListOfMethodsToKeep to doNotRemoveMethodList so that they will not be pruned"
	doNotRemoveMethodList ifNil:[doNotRemoveMethodList := Set new:100].
	doNotRemoveMethodList addAll: aListOfMethodsToKeep.
	^aListOfMethodsToKeep! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'JMM 4/16/2002 22:39'!
returnPrefixFromVariable: aName
	^aName! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'eem (auto rename) 12/16/2008 08:46'!
selectorReturnsPointerToStruct: selector "<Symbol>"
	| tMethod |
	^vmClass notNil
	  and: [(tMethod := methods at: selector ifAbsent: []) notNil
	  and: [vmClass isTypePointerToStruct: tMethod returnType]]! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'eem 5/20/2010 20:46'!
sortMethods: aTMethodCollection
	"We need to define this since different Squeak versions answer different results
	 for asSortedCollection and if sort order changes, generated code changes too."
	^aTMethodCollection asSortedCollection:
		[:a :b| a selector caseSensitiveLessOrEqual: b selector]! !
!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:50'!
storeCodeOnFile: fileName doInlining: inlineFlag
	"Store C code for this code base on the given file."

	self storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: true! !
!CCodeGenerator methodsFor: 'public' stamp: 'tpr 9/26/2001 07:28'!
storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: assertionFlag
	"Store C code for this code base on the given file."

	| stream |
	stream := CrLfFileStream forceNewFileNamed: fileName.
	stream ifNil: [Error signal: 'Could not open C code file: ', fileName].
	self emitCCodeOn: stream doInlining: inlineFlag doAssertions: assertionFlag.
	stream close! !
!CCodeGenerator methodsFor: 'public' stamp: 'dtl 5/27/2010 21:41'!
storeHeaderOnFile: fileName
	"Store C header code for this interpreter on the given file."

	| aStream |
	aStream := CrLfFileStream forceNewFileNamed: fileName.
	aStream ifNil: [Error signal: 'Could not open C header file: ', fileName].
	aStream
		nextPutAll: '/* ';
		nextPutAll: VMMaker headerNotice;
		nextPutAll: ' */'; cr; cr.
	self emitVmmVersionOn: aStream.
	self emitDefineBytesPerWordOn: aStream.
	self emitDefineMemoryAccessInImageOn: aStream.
	aStream cr.
	aStream close
! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'TPR 3/2/2000 11:45'!
translationMethodClass
	"return the class used to produce C translation methods from MethodNodes"
	^TMethod! !
!CCodeGenerator methodsFor: 'C code generator' stamp: 'eem 2/9/2009 20:39'!
typeOfVariable: varName "<String>" 
	scopeStack reverseDo:
		[:dict|
		(dict includesKey: varName) ifTrue:
			[^dict at: varName]].
	^variableDeclarations at: varName ifAbsent: nil! !
!CCodeGenerator methodsFor: 'utilities' stamp: 'ar 7/17/1999 15:06'!
unreachableMethods
	"Return a collection of methods that are never invoked."

	| sent out |
	sent := Set new.
	methods do: [ :m |
		m export ifTrue:[sent add: m selector].
		sent addAll: m allCalls.
	].

	out := OrderedCollection new.
	methods keys do: [ :sel |
		(sent includes: sel) ifFalse: [ out add: sel ].
	].
	^ out! !
!CCodeGenerator methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:23'!
useSymbolicConstants
	"Answer whether we should generate symbolic constants instead of their actual values"
	^useSymbolicConstants! !
!CCodeGenerator methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:23'!
useSymbolicConstants: aBool
	"Indicate whether we should generate symbolic constants instead of their actual values"
	useSymbolicConstants := aBool! !
!CCodeGenerator methodsFor: 'public' stamp: 'eem 7/16/2009 14:07'!
var: varName declareC: declarationString
	"Record the given C declaration for a global variable."

	(declarationString includesSubString: varName) ifFalse:
		[self error: 'declaration omits variable name.  probably an error.  use e.g. var:type:'].
	variableDeclarations at: varName asString put: declarationString.! !
!CCodeGenerator methodsFor: 'public' stamp: 'tpr 12/29/2005 15:59'!
var: varName type: type
"Use this in preference to #var:declareC: whenver possible since it avoids typing the varname twice and thus avoids the potential for a typo. See also #var:type:array:"
	self var: varName declareC: type , ' ' , varName! !
!CCodeGenerator methodsFor: 'public' stamp: 'tpr 12/29/2005 16:00'!
var: varName type: type array: array
"use this in preference to #var:declareC: when possible. This produces a C statment of the form
int * fooArray[]={1,2,3}
See also #var:type: for simple var decls" 
	self
		var: varName
		declareC: (String streamContents: [:s |
			s nextPutAll: type.
			s space.
			s nextPutAll: varName.
			s nextPutAll: '[] = {'.
			self printArray: array on: s.
			s nextPut: $}])! !

CCodeGenerator subclass: #CCodeGeneratorGlobalStructure
	instanceVariableNames: 'localStructDef'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!CCodeGeneratorGlobalStructure commentStamp: 'tpr 5/23/2003 11:17' prior: 0!
This subclass of CCodeGenerator adds support for sticking most global variables into a large global array. This in turn means that suitably minded C compilers can do a better job of accessing those variables; in particular the Mac OS use of PPC and Acorn use of ARM benfits by a substantial margin. 

Only simple globals are currently put in the array. Someday we might try adding pointers to the various arrays etc.!
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator'!
buildSortedVariablesCollection
	"Build sorted vars, end result will be sorted collection based on static usage, 
	perhaps cache lines will like this!!"

	| globalNames sorted |

	globalNames := Bag new: globalVariableUsage size.
	globalVariableUsage keysAndValuesDo: [:k :v | 
		(variableDeclarations includesKey: k) ifFalse: 
			[globalNames add: k withOccurrences: v size]].	
	variableDeclarations keysDo: 
		[:e | globalNames add: e withOccurrences: 0].
	sorted := SortedCollection sortBlock: 
		[:a :b | (globalNames occurrencesOf: a) > (globalNames occurrencesOf: b)].
	sorted addAll: variables.
	^sorted! !
!CCodeGeneratorGlobalStructure methodsFor: 'utilities'!
checkForGlobalUsage: vars in: aTMethod 
	"override to handle global struct needs"
	super checkForGlobalUsage: vars in: aTMethod.
	"if localStructDef is false, we  don't ever need to include a reference to it in a function"
	localStructDef ifFalse:[^self].
	vars asSet do: [:var |
		"if any var is global and in the global var struct 
		tell the TMethod it will be refering to the  struct"
			  ((self globalsAsSet includes: var )
					and: [self placeInStructure: var ])
				ifTrue: [aTMethod referencesGlobalStructIncrementBy: (vars occurrencesOf: var)]]! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'tpr 10/29/2002 14:00'!
emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag
	super emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag.

	"if the machine needs the globals structure defined locally in the interp.c file, don't add the folowing function"
	localStructDef ifFalse:[self emitStructureInitFunctionOn: aStream]! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'dtl 12/4/2010 11:51'!
emitCVariablesOn: aStream
	"Store the global variable declarations on the given stream.
	break logic into vars for structure and vars for non-structure"
	| varString structure nonstruct target |

	structure := WriteStream on: (String new: 32768).
	nonstruct := WriteStream on: (String new: 32768).
	aStream nextPutAll: '/*** Variables ***/'; cr.
	structure nextPutAll: 'static struct foo {'; cr.
	self buildSortedVariablesCollection do: [ :var |
		varString := var asString.
		target := (self placeInStructure: var) 
			ifTrue: [structure]
			ifFalse: [nonstruct].
		(self isGeneratingPluginCode) ifTrue:[
			varString = 'interpreterProxy' ifTrue:[
				"quite special..."
				aStream cr; nextPutAll: '#ifdef SQUEAK_BUILTIN_PLUGIN'.
				aStream cr; nextPutAll: 'extern'.
				aStream cr; nextPutAll: '#endif'; cr.
			] ifFalse:[aStream nextPutAll:'static '].
		].
		(variableDeclarations includesKey: varString) ifTrue: [
			target nextPutAll: (variableDeclarations at: varString), ';'; cr.
		] ifFalse: [
			"default variable declaration"
			target nextPutAll: 'sqInt ', varString, ';'; cr.
		].
	].
	structure nextPutAll: ' } fum;';cr.

	"if the machine needs the fum structure defining locally, do it now"
	localStructDef ifTrue:[structure nextPutAll: 'struct foo * foo = &fum;';cr;cr].

	aStream nextPutAll: structure contents.
	aStream nextPutAll: nonstruct contents.
	aStream cr.! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'ikp 9/10/2003 05:55'!
emitGlobalStructFlagOn: aStream
	"Define SQ_USE_GLOBAL_STRUCT before including the header."

	aStream nextPutAll: '#define SQ_USE_GLOBAL_STRUCT 1'; cr; cr! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'tpr 10/9/2002 15:40'!
emitStructureInitFunctionOn: aStream 
	"For the VM using a global struct for most of the global vars (useful for ARM and PPC so far), append the initGlobalStructure() function"
	aStream 
		cr;
		nextPutAll: 'void initGlobalStructure(void) {foo = &fum;}';
		cr! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'tpr 10/29/2002 15:01'!
globalStructDefined: aBool
	localStructDef := aBool! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'tpr 10/29/2002 16:11'!
initialize
	super initialize.
	localStructDef := false! !
!CCodeGeneratorGlobalStructure methodsFor: 'public'!
isGlobalStructureBuild
	^true! !
!CCodeGeneratorGlobalStructure methodsFor: 'utilities'!
localizeGlobalVariables
"TPR - remove all the global vars destined for the structure that are only used once - not worth the space,
actually what will happen is the folding code will fold these variables into the method"

	super localizeGlobalVariables.
	globalVariableUsage := globalVariableUsage select: [:e | e size > 1].
! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'tpr 12/22/2005 16:03'!
placeInStructure: var
	"See if we should put this array into a structure
	This has hard coded vars, should go somewhere else!!
	The variables listed are hardcoded as C in the interpreter thus they don't get resolved via TVariableNode logic
	Also let's ignore variables that have special definitions that require initialization, and the function def which has problems"

	| check |
	check := variableDeclarations at: var ifAbsent: [''].
	(check includes: $=) ifTrue: [^false].
	(check includes: $() ifTrue: [^false].

	(#( 'showSurfaceFn' 'memory' 'extraVMMemory' 'interpreterProxy') includes: var) ifTrue: [^false].
	^true.
	! !
!CCodeGeneratorGlobalStructure methodsFor: 'C code generator'!
returnPrefixFromVariable: aName
	^((self globalsAsSet includes: aName) and: [self placeInStructure: aName])
		ifTrue: ['foo->',aName]
		ifFalse: [aName]! !

CCodeGenerator subclass: #VMPluginCodeGenerator
	instanceVariableNames: 'pluginName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!VMPluginCodeGenerator commentStamp: '<historical>' prior: 0!
I generate code that can be loaded dynamically from external libraries (e.g., DSOs on Unix or DLLs on Windows)!

VMPluginCodeGenerator subclass: #SmartSyntaxPluginCodeGenerator
	instanceVariableNames: 'debugFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-SmartSyntaxPlugins'!
!SmartSyntaxPluginCodeGenerator commentStamp: 'tpr 5/5/2003 16:03' prior: 0!
Subclass of CCodeGenerator, used in connection with TestInterpreterPlugin to generate named primitives with type coercion specifications. See the plugins implemeted as subclasses of TestInterpreterPlugin!
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:32'!
ccgLoad: aBlock expr: aString asBooleanValueFrom: anInteger
	"Answer codestring for boolean coercion (with validating side-effect) of object, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy booleanValueOf:';
		crtab: 2;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	')'])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asCharPtrFrom: anInteger
	"Answer codestring for character pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''char *'''])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asCharPtrFrom: anInteger andThen: valBlock
	"Answer codestring for character pointer to first indexable field of object (without validating side-effect unless specified in valBlock), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''char *''']))
	 ! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asFloatValueFrom: anInteger
	"Answer codestring for double precision coercion (with validating side-effect) of oop, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackFloatValue: ';
		nextPutAll: anInteger asString])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asIntPtrFrom: anInteger
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''int *'''])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asIntPtrFrom: anInteger andThen: valBlock
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect unless specified in valBlock), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''int *''']))! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asIntegerValueFrom: anInteger
	"Answer codestring for integer coercion (with validating side-effect) of oop, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackIntegerValue: ';
		nextPutAll: anInteger asString])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 9/19/1999 20:28'!
ccgLoad: aBlock expr: aString asKindOf: aClass from: anInteger

	^String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy success: (interpreterProxy';
		crtab: 2;
		nextPutAll: 'is: (interpreterProxy stackValue: ';
		nextPutAll: anInteger asString;
		nextPutAll: ')';
		crtab: 2;
		nextPutAll: 	'KindOf: ''';
		nextPutAll:	aClass asString;
		nextPutAll: ''').';
		crtab;
		nextPutAll: (self 
						ccgLoad: aBlock 
						expr: aString 
						asRawOopFrom: anInteger)]! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 9/19/1999 20:28'!
ccgLoad: aBlock expr: aString asMemberOf: aClass from: anInteger

	^String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy success: (interpreterProxy';
		crtab: 2;
		nextPutAll: 'is: (interpreterProxy stackValue: ';
		nextPutAll: anInteger asString;
		nextPutAll: ')';
		crtab: 2;
		nextPutAll: 	'MemberOf: ''';
		nextPutAll:	aClass asString;
		nextPutAll: ''').';
		crtab;
		nextPutAll: (self 
						ccgLoad: aBlock 
						expr: aString 
						asRawOopFrom: anInteger)]! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: exprString asNamedPtr: recordString from: anInteger
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''';
		nextPutAll: recordString;
		nextPutAll: ' *'''])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: exprString asNamedPtr: recordString from: anInteger andThen: valBlock
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''';
		nextPutAll: recordString;
		nextPutAll: ' *''']))! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asNonIntegerValueFrom: anInteger
	"Answer codestring for oop (with validating side effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackObjectValue: ';
		nextPutAll: anInteger asString])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:32'!
ccgLoad: aBlock expr: aString asRawOopFrom: anInteger
	"Answer a string for a Slang expression that will load an oop (without validation) from stack index anInteger.  Apply aBlock, a BlockContext instance that when passed an expression, will return a string assigning the expression to the desired identifier, to the string before answering.  aString is a Slang expression that refers to the stack value, once it has been loaded."

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackValue: ';
		nextPutAll: anInteger asString])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asUnsignedPtrFrom: anInteger andThen: valBlock
	"Answer a codestring for integer pointer to first indexable field of object (without validating side-effect unless specified in valBlock), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''unsigned *''']))! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asUnsignedValueFrom: anInteger
	"Answer a codestring for positive integer coercion (with validating side-effect) of oop, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy positive32BitValueOf:';
		crtab: 2;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	')'])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asWBCharPtrFrom: anInteger
	"Answer codestring for char pointer to first indexable field of object (with validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy arrayValueOf:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''char *'''])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asWBFloatPtrFrom: anInteger
	"Answer codestring for single-precision float pointer to first indexable field of object (with validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy arrayValueOf:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''float *'''])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asWBIntPtrFrom: anInteger
	"Answer codestring for integer pointer to first indexable field of object (with validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy arrayValueOf:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''int *'''])! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'ar 4/4/2006 21:10'!
ccgSetBlock: aString

	^[:expr | aString, ' := ', expr]! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'acg 9/19/1999 13:05'!
ccgTVarBlock: anInteger

	^[:expr | '(thisContext tempAt: 1) tempAt: ', anInteger asString, ' put: (', expr, ')']! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'coercing' stamp: 'EstebanLorenzano 12/6/2010 19:19'!
ccgValBlock: valString
	^[:index | String streamContents:
		[:aStream | aStream
			nextPutAll: 'interpreterProxy success: (interpreterProxy ';
			nextPutAll: valString;
			nextPutAll: ': (interpreterProxy stackValue: ';
			nextPutAll: index asString;
			nextPutAll: '))']]! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asBooleanValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: ' = interpreterProxy->booleanValueOf(';
		crtab: 2;
		nextPutAll: 'interpreterProxy->stackValue(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asCharPtrFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = (char *) interpreterProxy->firstIndexableField(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValueOf(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asFloatPtrFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = (float *) interpreterProxy->firstIndexableField(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValueOf(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asFloatValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy->stackFloatValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asIntPtrFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = (int *) interpreterProxy->firstIndexableField(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValueOf(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asIntegerValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy stackIntegerValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:42'!
emitLoad: aString asKindOf: aClass from: anInteger on: aStream

	self emitLoad: aString asNakedOopFrom: anInteger on: aStream.
	aStream
		crtab;
		nextPutAll: 'interpreterProxy->success(interpreterProxy->isKindOf(';
		nextPutAll: aString;
		nextPutAll: 	', ''';
		nextPutAll:	aClass asString;
		nextPutAll: '''))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'bf 3/16/2000 19:20'!
emitLoad: aString asMemberOf: aClass from: anInteger on: aStream

	self emitLoad: aString asNakedOopFrom: anInteger on: aStream.
	aStream
		crtab;
		nextPutAll: 'interpreterProxy->success(interpreterProxy->isMemberOf(';
		nextPutAll: aString;
		nextPutAll: 	', ''';
		nextPutAll:	aClass asString;
		nextPutAll: '''))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/18/1999 14:23'!
emitLoad: aString asNakedOopFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: ' = interpreterProxy stackValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:44'!
emitLoad: aString asNonIntegerValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy stackObjectValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:44'!
emitLoad: aString asUnsignedValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy->positive32BitValueOf(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValue(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:08'!
generateAsBooleanObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: '('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: 
		') ? interpreterProxy->trueObject(): interpreterProxy->falseObject()'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:09'!
generateAsCBoolean: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->booleanValueOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:09'!
generateAsCDouble: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->floatValueOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 21:53'!
generateAsCInt: aNode on: aStream indent: anInteger

	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ' >> 1'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:09'!
generateAsCUnsigned: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->positive32BitValueOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsCharPtr: aNode on: aStream indent: anInteger

	aStream nextPutAll: '(char *) interpreterProxy->firstIndexableField('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsFloatObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->floatObjectOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'TPR 2/25/2000 16:21'!
generateAsIfVar: aNode on: aStream indent: anInteger

	| cName fName class index |
	cName := String streamContents: 
		[:scStr | self emitCExpression: aNode args first on: scStr].
	class := Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	fName := aNode args second value.
	index := class allInstVarNames
		indexOf: fName
		ifAbsent: [^self error: 'second arg must be instVar'].
	aStream 
		nextPutAll: 'interpreterProxy->fetchPointerofObject(';
		nextPutAll: (index - 1) asString;
		nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'TPR 2/25/2000 16:41'!
generateAsIfVarAsValue: aNode on: aStream indent: anInteger

	| cName fName class index fetchNode |
	cName := String streamContents: 
		[:scStr | self emitCExpression: aNode args first on: scStr].
	class := Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	fName := aNode args second value.
	index := class allInstVarNames
		indexOf: fName
		ifAbsent: [^self error: 'second arg must be instVar'].
	fetchNode := TSendNode new
		setSelector: #fetchPointer:ofObject:
		receiver: (TVariableNode new setName: 'interpreterProxy')
		arguments: (Array
			with: (TConstantNode new setValue: index - 1)
			with: aNode receiver).
	cName := aNode args third nameOrValue.
	class := Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'third arg must identify class'].
	class ccg: self generateCoerceToValueFrom: fetchNode on: aStream
! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'TPR 2/25/2000 16:41'!
generateAsIfVarPut: aNode on: aStream indent: anInteger

	| cName fName class index |
	cName := String streamContents: 
		[:scStr | self emitCExpression: aNode args first on: scStr].
	class := Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	fName := aNode args second value.
	index := class allInstVarNames
		indexOf: fName
		ifAbsent: [^self error: 'second arg must be instVar'].
	aStream 
		nextPutAll: 'interpreterProxy->storePointerofObjectwithValue(';
		nextPutAll: (index - 1) asString;
		nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args third on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsIntPtr: aNode on: aStream indent: anInteger

	aStream nextPutAll: '(int *) interpreterProxy->firstIndexableField('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 12/17/1999 07:23'!
generateAsOop: aNode on: aStream indent: anInteger

	| cName class |
	cName := aNode args first nameOrValue.
	class := Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	class ccg: self generateCoerceToOopFrom: aNode receiver on: aStream! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsPositiveIntegerObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->positive32BitIntegerFor('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:47'!
generateAsSmallIntegerObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->integerObjectOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 12/17/1999 07:22'!
generateAsValue: aNode on: aStream indent: anInteger

	| cName class |
	cName := aNode args first nameOrValue.
	class := Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	class ccg: self generateCoerceToValueFrom: aNode receiver on: aStream! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'dtl 5/19/2010 21:35'!
generateCPtrAsOop: aNode on: aStream indent: anInteger 

	aStream nextPutAll: '('.
	aStream nextPutAll: 'oopForPointer( '.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ' ) - BASE_HEADER_SIZE)'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:11'!
generateClass: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->fetchClassOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 12/25/1999 10:00'!
generateCoerceToBooleanObjectFrom: aNode on: aStream

	aStream nextPutAll: '('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: '? interpreterProxy->trueObject(): interpreterProxy->falseObject())'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:07'!
generateCoerceToBooleanValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->booleanValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:03'!
generateCoerceToFloatObjectFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->floatObjectOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 05:53'!
generateCoerceToFloatValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->floatValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'dtl 5/19/2010 21:34'!
generateCoerceToObjectFromPtr: aNode on: aStream
	"This code assumes no named instance variables"

	aStream nextPutAll: 'oopForPointer('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ') - BASE_HEADER_SIZE'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 05:57'!
generateCoerceToPtr: aString fromObject: aNode on: aStream
	"This code assumes no named instance variables"

	aStream 
		nextPutAll: '((';
		nextPutAll: aString;
		nextPutAll: ') interpreterProxy->firstIndexableField('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: '))'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:03'!
generateCoerceToSmallIntegerObjectFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->integerObjectOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 05:59'!
generateCoerceToSmallIntegerValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->integerValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:03'!
generateCoerceToUnsignedObjectFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->positive32BitIntegerFor('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:00'!
generateCoerceToUnsignedValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->positive32BitValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'debug code' stamp: 'sr 4/8/2000 00:52'!
generateDebugCode
	^ debugFlag! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'debug code' stamp: 'sr 4/8/2000 00:52'!
generateDebugCode: aBool 
	debugFlag := aBool! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'sr 4/8/2000 02:38'!
generateDebugCode: aNode on: aStream indent: level 
	"Generate the C debug code for this message onto the given stream, if  
	compiled in debugMode."
	self generateDebugCode
		ifTrue: 
			[aStream nextPutAll: '/* DebugCode... */';
			 cr.
			aNode args first
				emitCCodeOn: aStream
				level: level
				generator: self.
			aStream tab: level.
			aStream nextPutAll: '/* ...DebugCode */']
		ifFalse: [aStream nextPutAll: '/* missing DebugCode */']! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:11'!
generateField: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->fetchPointerofObject('.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 23:40'!
generateFieldPut: aNode on: aStream indent: anInteger
		
	aStream nextPutAll: 'interpreterProxy->storePointerofObjectwithValue('.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args second on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/16/1999 08:02'!
generateFromStack: aNode on: aStream indent: anInteger

	| idList |
	aNode args first isConstant ifFalse: [^self error: 'arg must be constant'].
	idList := aNode args first value.
	(1 to: idList size)
		do: [:i | 
			aStream 
				nextPutAll: (idList at: i);
				nextPutAll: ' = interpreterProxy->stackValue(';
				nextPutAll: (idList size - i) asString;
				nextPutAll: ')']
		separatedBy: [aStream nextPut: $;; crtab: anInteger].
! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:50'!
generateIsBytes: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isBytes('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:50'!
generateIsFloat: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isFloatObject('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:49'!
generateIsIndexable: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIndexable('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:49'!
generateIsInteger: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIntegerValue('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:13'!
generateIsIntegerOop: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIntegerObject('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:13'!
generateIsIntegerValue: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIntegerValue('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:20'!
generateIsKindOf: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isKindOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','''.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ''')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:20'!
generateIsMemberOf: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isMemberOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','''.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ''')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:14'!
generateIsPointers: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isPointers('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:14'!
generateIsWords: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isWords('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:13'!
generateIsWordsOrBytes: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isWordsOrBytes('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 01:56'!
generateNext: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode := msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'next can only be applied to variables' ].
	aStream nextPutAll: '*'.
	aStream nextPutAll: varNode name.
	aStream nextPutAll: '++'
! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 12/31/1999 16:37'!
generateRemapOopIn: aNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| idList |
	idList := aNode args first nameOrValue.
	idList class == Array ifFalse: [idList := Array with: idList].
	idList do:
		[:each | 
		 aStream 
			nextPutAll: 'interpreterProxy->pushRemappableOop(';
			nextPutAll: each asString;
			nextPutAll: ');']
		separatedBy: [aStream crtab: level].
	aStream cr.
	aNode args second emitCCodeOn: aStream level: level generator: self.
	level timesRepeat: [aStream tab].
	idList reversed do:
		[:each |
		 aStream 
			nextPutAll: each asString;
			nextPutAll: ' = interpreterProxy->popRemappableOop()']
		separatedBy: [aStream nextPut: $;; crtab: level].! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:15'!
generateStAt: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->stObjectat('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ')'
! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:17'!
generateStAtPut: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->stObjectatput('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args second on: aStream.
	aStream nextPutAll: ')'
! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 1/1/2000 22:41'!
generateStSize: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->stSizeOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'initialize' stamp: 'sr 4/8/2000 00:53'!
initialize
	super initialize.
	debugFlag := false! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'translating builtins' stamp: 'tpr 12/21/2005 17:25'!
initializeCTranslationDictionary 
	"Initialize the dictionary mapping message names to actions for C code generation."

	| pairs |
	super initializeCTranslationDictionary.
	pairs := #(
		#asCInt						#generateAsCInt:on:indent:
		#asCUnsigned				#generateAsCUnsigned:on:indent:
		#asCBoolean					#generateAsCBoolean:on:indent:
		#asCDouble					#generateAsCDouble:on:indent:

		#asSmallIntegerObj			#generateAsSmallIntegerObj:on:indent:
		#asPositiveIntegerObj		#generateAsPositiveIntegerObj:on:indent:
		#asBooleanObj				#generateAsBooleanObj:on:indent:
		#asFloatObj					#generateAsFloatObj:on:indent:

		#asIf:var:					#generateAsIfVar:on:indent:
		#asIf:var:asValue:			#generateAsIfVarAsValue:on:indent:
		#asIf:var:put:				#generateAsIfVarPut:on:indent:
		#field:						#generateField:on:indent:
		#field:put:					#generateFieldPut:on:indent:
		
		#class						#generateClass:on:indent:

		#stSize						#generateStSize:on:indent:
		#stAt:						#generateStAt:on:indent:
		#stAt:put:					#generateStAtPut:on:indent:

		#asCharPtr					#generateAsCharPtr:on:indent:
		#asIntPtr					#generateAsIntPtr:on:indent:
		#cPtrAsOop					#generateCPtrAsOop:on:indent:
		#next						#generateNext:on:indent:

		#asOop:						#generateAsOop:on:indent:
		#asValue:					#generateAsValue:on:indent:

		#isFloat						#generateIsFloat:on:indent:
		#isIndexable					#generateIsIndexable:on:indent:
		#isIntegerOop				#generateIsIntegerOop:on:indent:
		#isIntegerValue				#generateIsIntegerValue:on:indent:
		#FloatOop					#generateIsFloatValue:on:indent:
		#isWords					#generateIsWords:on:indent:
		#isWordsOrBytes				#generateIsWordsOrBytes:on:indent:
		#isPointers					#generateIsPointers:on:indent:
		#isNil						#generateIsNil:on:indent:
		#isMemberOf:				#generateIsMemberOf:on:indent:
		#isKindOf:					#generateIsKindOf:on:indent:

		#fromStack:					#generateFromStack:on:indent:
		#clone						#generateClone:on:indent
		#new						#generateNew:on:indent
		#new:						#generateNewSize:on:indent
		#superclass					#generateSuperclass:on:indent:
		#remapOop:in:				#generateRemapOopIn:on:indent:
		#debugCode:					#generateDebugCode:on:indent:
	).

	1 to: pairs size by: 2 do: [:i |
		translationDict at: (pairs at: i) put: (pairs at: i + 1)].
! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'initialize' stamp: 'tpr 6/9/2003 16:40'!
translationMethodClass
	"return the class used to produce C translation methods from MethodNodes"
	^SmartSyntaxPluginTMethod! !
!SmartSyntaxPluginCodeGenerator methodsFor: 'transforming' stamp: 'ar 3/10/2000 17:59'!
var: varName as: aClass
	"Record the given C declaration for a global variable"

	variableDeclarations at: varName asString put: (aClass ccgDeclareCForVar: varName)! !
!VMPluginCodeGenerator methodsFor: 'inlining' stamp: 'tpr 2/24/2004 20:30'!
doInlining: inlineFlag
"do inlining for a plugin"
	^self doBasicInlining: inlineFlag! !
!VMPluginCodeGenerator methodsFor: 'C code generator' stamp: 'tpr 4/10/2002 18:28'!
emitCHeaderForPrimitivesOn: aStream
	"Write a C file header for compiled primitives onto the given stream."

	self emitCHeaderOn: aStream.
	aStream nextPutAll: '
/*** Proxy Functions ***/
#define stackValue(i) (interpreterProxy->stackValue(i))
#define stackIntegerValue(i) (interpreterProxy->stackIntegerValue(i))
#define successFlag (!!interpreterProxy->failed())
#define success(bool) (interpreterProxy->success(bool))
#define arrayValueOf(oop) (interpreterProxy->arrayValueOf(oop))
#define checkedIntegerValueOf(oop) (interpreterProxy->checkedIntegerValueOf(oop))
#define fetchArrayofObject(idx,oop) (interpreterProxy->fetchArrayofObject(idx,oop))
#define fetchFloatofObject(idx,oop) (interpreterProxy->fetchFloatofObject(idx,oop))
#define fetchIntegerofObject(idx,oop) (interpreterProxy->fetchIntegerofObject(idx,oop))
#define floatValueOf(oop) (interpreterProxy->floatValueOf(oop))
#define pop(n) (interpreterProxy->pop(n))
#define pushInteger(n) (interpreterProxy->pushInteger(n))
#define sizeOfSTArrayFromCPrimitive(cPtr) (interpreterProxy->sizeOfSTArrayFromCPrimitive(cPtr))
#define storeIntegerofObjectwithValue(idx,oop,value) (interpreterProxy->storeIntegerofObjectwithValue(idx,oop,value))
#define primitiveFail() interpreterProxy->primitiveFail()
/* allows accessing Strings in both C and Smalltalk */
#define asciiValue(c) c

'.
	aStream cr.! !
!VMPluginCodeGenerator methodsFor: 'C code generator' stamp: 'tpr 4/3/2006 13:19'!
emitCHeaderOn: aStream
	"Write a C file header onto the given stream."

	aStream nextPutAll: '/* '.
	aStream nextPutAll: VMMaker headerNotice.
	aStream nextPutAll: ' */';cr.

	aStream nextPutAll:'
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

/* Default EXPORT macro that does nothing (see comment in sq.h): */
#define EXPORT(returnType) returnType

/* Do not include the entire sq.h file but just those parts needed. */
/*  The virtual machine proxy definition */
#include "sqVirtualMachine.h"
/* Configuration options */
#include "sqConfig.h"
/* Platform specific definitions */
#include "sqPlatformSpecific.h"

#define true 1
#define false 0
#define null 0  /* using ''null'' because nil is predefined in Think C */
#ifdef SQUEAK_BUILTIN_PLUGIN
#undef EXPORT
// was #undef EXPORT(returnType) but screws NorCroft cc
#define EXPORT(returnType) static returnType
#endif
'.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].


	aStream nextPutAll: '
#include "sqMemoryAccess.h"

'.
	aStream cr.! !
!VMPluginCodeGenerator methodsFor: 'C code generator' stamp: 'tpr 1/10/2003 16:09'!
emitExportsOn: aStream
	"Store all the exported primitives in a form to be used by internal plugins"
	| prefix |
	aStream nextPutAll:'

#ifdef SQUEAK_BUILTIN_PLUGIN';cr.

	aStream nextPutAll:'

void* ', pluginName,'_exports[][3] = {'.
	prefix := '"', pluginName,'"'.
	self exportedPrimitiveNames do:[:primName|
		aStream cr;
			nextPutAll:'	{'; 
			nextPutAll: prefix; 
			nextPutAll:', "'; 
			nextPutAll: primName; 
			nextPutAll:'", (void*)'; 
			nextPutAll: primName;
			nextPutAll:'},'.
	].
	aStream nextPutAll:'
	{NULL, NULL, NULL}
};
'.
	aStream nextPutAll:'

#endif /* ifdef SQ_BUILTIN_PLUGIN */

'.! !
!VMPluginCodeGenerator methodsFor: 'public' stamp: 'ar 7/8/2003 10:53'!
generateCodeStringForPrimitives
"TPR - moved down from CCodeGenerator"
	| s methodList |
	s := ReadWriteStream on: (String new: 1000).
	methodList := methods asSortedCollection: [:m1 :m2 | m1 selector < m2 selector].
	self emitCHeaderForPrimitivesOn: s.
	self emitCConstantsOn: s.
	self emitCVariablesOn: s.
	self emitCFunctionPrototypes: methodList on: s.
	methodList do: [:m | m emitCCodeOn: s generator: self].
	self emitExportsOn: s.
	^ s contents
! !
!VMPluginCodeGenerator methodsFor: 'testing' stamp: 'ar 10/7/1998 17:54'!
isGeneratingPluginCode
	^true! !
!VMPluginCodeGenerator methodsFor: 'C code generator' stamp: 'eem 11/7/2009 10:03'!
isTypePointerToStruct: type "<String>"
	^pluginClass notNil
	  and: [[pluginClass isTypePointerToStruct: type]
			on: MessageNotUnderstood
			do: [:ex| ex message selector == #isTypePointerToStruct: ifTrue: [^false].
					ex pass]]! !
!VMPluginCodeGenerator methodsFor: 'public' stamp: 'tpr 1/10/2003 16:20'!
localizeGlobalVariables
"TPR - we don't do this for plugins"! !
!VMPluginCodeGenerator methodsFor: 'public' stamp: 'tpr 1/10/2003 16:18'!
pluginName: aString
"TPR - moved from CCodeGenerator"
	"Set the plugin name when generating plugins."
	pluginName := aString.! !
!VMPluginCodeGenerator methodsFor: 'private' stamp: 'ar 4/4/2006 21:15'!
storeVirtualMachineProxyHeader: categoryList on: fileName
	"Store the interpreter definitions on the given file"
	| stream |
	stream := FileStream newFileNamed: fileName.
	stream nextPutAll:
'#ifndef _SqueakVM_H
#define _SqueakVM_H

/* Increment the following number if you change the order of
   functions listed or if you remove functions */
#define VM_PROXY_MAJOR 1

/* Increment the following number if you add functions at the end */
#define VM_PROXY_MINOR 0

typedef struct VirtualMachine {
	int (*minorVersion) (void);
	int (*majorVersion) (void);
'.

	categoryList do:[:assoc|
		stream cr; crtab; nextPutAll:'/* InterpreterProxy methodsFor: ''',assoc key, ''' */'; cr; crtab.
		assoc value asSortedCollection do:[:sel|
			(methods at: sel) emitProxyFunctionPrototype: stream generator: self.
			stream nextPutAll: ';'; crtab]].

	stream nextPutAll:'
} VirtualMachine;

#endif /* _SqueakVM_H */
'.
	stream close.! !
!VMPluginCodeGenerator methodsFor: 'private' stamp: 'tpr 4/12/2006 12:29'!
storeVirtualMachineProxyImplementation: categoryList on: fileName
	"Store the interpreter definitions on the given file"
	| stream |
	stream := FileStream newFileNamed: fileName.
	stream nextPutAll:'
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include "sqVirtualMachine.h"'; cr;cr.
	stream nextPutAll:'/*** Function prototypes ***/'.

	categoryList do:[:assoc|
		stream cr; cr; nextPutAll:'/* InterpreterProxy methodsFor: ''',assoc key, ''' */'; cr.
		assoc value asSortedCollection do:[:sel|
			(methods at: sel) emitCFunctionPrototype: stream generator: self.
			stream nextPutAll: ';'; cr]].

	stream cr; nextPutAll:'struct VirtualMachine *VM = NULL;'; cr.
	stream cr; nextPutAll:
'static int majorVersion(void) {
	return VM_PROXY_MAJOR;
}

static int minorVersion(void) {
	return VM_PROXY_MINOR;
}

struct VirtualMachine* sqGetInterpreterProxy(void)
{
	if(VM) return VM;
	VM = (struct VirtualMachine *) calloc(1, sizeof(VirtualMachine));
	/* Initialize Function pointers */
	VM->majorVersion = majorVersion;
	VM->minorVersion = minorVersion;
'.
	categoryList do:[:assoc|
		stream cr; crtab; nextPutAll:'/* InterpreterProxy methodsFor: ''',assoc key, ''' */'; crtab.
		assoc value asSortedCollection do:[:sel|
		stream nextPutAll:'VM->';
			nextPutAll: (self cFunctionNameFor: sel);
			nextPutAll:' = ';
			nextPutAll: (self cFunctionNameFor: sel);
			nextPutAll:';';
			crtab]].

	stream cr; crtab; nextPutAll:'return VM;'; cr; nextPutAll:'}'; cr.
	stream close.! !

Object subclass: #CObjectAccessor
	instanceVariableNames: 'object offset'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!CObjectAccessor commentStamp: '<historical>' prior: 0!
I am used to simulate the indexed access to any object during plugin simulation.!

CObjectAccessor subclass: #CArrayAccessor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!CArrayAccessor commentStamp: '<historical>' prior: 0!
I am used to simulate the indexed access to arrays during plugin simulation.!
!CArrayAccessor methodsFor: 'comparing' stamp: 'yo 2/9/2001 11:23'!
< other

	^ (object == other object) and: [offset < other offset].! !
!CArrayAccessor methodsFor: 'comparing' stamp: 'yo 2/9/2001 11:24'!
<= other

	^ (object == other object) and: [offset <= other offset].! !
!CArrayAccessor methodsFor: 'comparing' stamp: 'yo 2/9/2001 11:24'!
> other

	^ (object == other object) and: [offset > other offset].! !
!CArrayAccessor methodsFor: 'comparing' stamp: 'yo 2/9/2001 11:24'!
>= other

	^ (object == other object) and: [offset >= other offset].! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index
	^object at: index + offset + 1! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index put: value
	^object at: index + offset + 1 put: value! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 12/31/2001 01:36'!
byteAt: index
	^object byteAt: index + offset + 1! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'acg 9/19/1999 01:50'!
cPtrAsOop

	offset = 0 ifFalse: [self error: 'offset must be zero'].
	^object! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 8/2/2007 18:00'!
long32At: index
	| idx |
	idx := (offset + index) // 4 + 1.
	"Note: This is a special hack for BitBlt."
	(idx = (object basicSize + 1)) ifTrue:[^0].
	^object basicAt: idx! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 8/2/2007 18:01'!
long32At: index put: value
	^object basicAt: (offset + index) // 4 + 1 put: value! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/10/1998 16:26'!
longAt: index
	| idx |
	idx := (offset + index) // 4 + 1.
	"Note: This is a special hack for BitBlt."
	(idx = (object basicSize + 1)) ifTrue:[^0].
	^object basicAt: idx! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/10/1998 16:26'!
longAt: index put: value
	^object basicAt: (offset + index) // 4 + 1 put: value! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'acg 9/19/1999 01:48'!
next

	|val|
	val := self at: 0.
	offset := offset + 1.
	^val! !
!CArrayAccessor methodsFor: 'accessing' stamp: 'acg 9/19/1999 01:46'!
size

	^object size! !

CArrayAccessor subclass: #CPluggableAccessor
	instanceVariableNames: 'readBlock writeBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!CPluggableAccessor commentStamp: 'tpr 5/5/2003 11:49' prior: 0!
This class adds generalized block parameter access to C objects for vm simulation!
!CPluggableAccessor methodsFor: 'accessing' stamp: 'ar 11/24/1998 20:45'!
at: index
	^readBlock value: object value: index + offset + 1! !
!CPluggableAccessor methodsFor: 'accessing' stamp: 'ar 11/24/1998 20:45'!
at: index put: value
	^writeBlock value: object value: index + offset + 1 value: value! !
!CPluggableAccessor methodsFor: 'initialize' stamp: 'di 7/14/2004 11:55'!
atBlock: rBlock atPutBlock: wBlock
	readBlock := rBlock.
	writeBlock := wBlock! !
!CPluggableAccessor methodsFor: 'initialize' stamp: 'ar 11/24/1998 20:51'!
readBlock: rBlock writeBlock: wBlock
	readBlock := rBlock.
	writeBlock := wBlock! !
!CObjectAccessor class methodsFor: 'instance creation' stamp: 'ar 9/16/1998 21:36'!
on: anObject
	^self new setObject: anObject! !
!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:57'!
+ increment
	^self clone += increment! !
!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:57'!
+= increment
	offset := offset + increment! !
!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:58'!
- decrement
	^self clone -= decrement! !
!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:58'!
-= decrement
	offset := offset - decrement! !
!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 17:36'!
asFloatAccessor

	^ self asPluggableAccessor
		atBlock: [:obj :index | obj floatAt: index]
		atPutBlock: [:obj :index :value | obj floatAt: index put: value]! !
!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 17:36'!
asIntAccessor

	^ self asPluggableAccessor
		atBlock: [:obj :index | obj intAt: index]
		atPutBlock: [:obj :index :value | obj intAt: index put: value]! !
!CObjectAccessor methodsFor: 'converting' stamp: 'acg 9/20/1999 11:08'!
asOop: aClass

	(aClass ccgCanConvertFrom: object)
		ifFalse: [^self error: 'incompatible object for autocoercion'].
	^object! !
!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 11:55'!
asPluggableAccessor
	^ (CPluggableAccessor on: object) += offset! !
!CObjectAccessor methodsFor: 'converting' stamp: 'ar 11/24/1998 20:51'!
asPluggableAccessor: accessorArray
	^((CPluggableAccessor on: object) += offset)
		readBlock: accessorArray first
		writeBlock: accessorArray last! !
!CObjectAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index
	^object instVarAt: index + offset + 1! !
!CObjectAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index put: value
	^object instVarAt: index + offset + 1 put: value! !
!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 17:38'!
coerceTo: cTypeString sim: interpreterSimulator

	cTypeString = 'float *' ifTrue: [^ self asFloatAccessor].
	cTypeString = 'int *' ifTrue: [^ self asIntAccessor].
	^ self! !
!CObjectAccessor methodsFor: 'private' stamp: 'ar 11/3/1998 22:37'!
getObject
	^object! !
!CObjectAccessor methodsFor: 'accessing' stamp: 'di 7/14/2004 12:13'!
isCObjectAccessor

	^ true! !
!CObjectAccessor methodsFor: 'accessing' stamp: 'yo 2/9/2001 11:23'!
object

	^ object! !
!CObjectAccessor methodsFor: 'accessing' stamp: 'yo 2/9/2001 11:23'!
offset

	^ offset
! !
!CObjectAccessor methodsFor: 'printing' stamp: 'ar 9/16/1998 21:38'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll:' on: ';
		print: object.! !
!CObjectAccessor methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:01'!
printOnStream: aStream
	super printOnStream: aStream.
	aStream
		print:' on: ';
		write: object.! !
!CObjectAccessor methodsFor: 'private' stamp: 'ar 10/9/1998 21:56'!
setObject: anObject
	object := anObject.
	offset := 0.! !

Object subclass: #InterpreterPlugin
	instanceVariableNames: 'interpreterProxy moduleName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!

InterpreterPlugin class
	instanceVariableNames: 'timeStamp'!
!InterpreterPlugin commentStamp: 'tpr 5/5/2003 11:43' prior: 0!
This class provides the basic framework for creating VM plugins. Most of the useful methods are on the class side; particularly take note of the messages like #shouldBeTranslated and #requiresPlatformFiles.!

InterpreterPlugin class
	instanceVariableNames: 'timeStamp'!

InterpreterPlugin subclass: #ADPCMCodecPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!ADPCMCodecPlugin commentStamp: 'tpr 3/24/2004 14:48' prior: 0!
This is a kludgy interface to the translated primitive code in ADPCMCodec. The translate.... method gathers the code and writes it to a file. No methods in this class actually implement the codec.!
!ADPCMCodecPlugin class methodsFor: 'translation' stamp: 'tpr 4/9/2002 16:14'!
translateInDirectory: directory doInlining: inlineFlag
"handle a special case code string rather than generated code"
"Not currently hooked into the timeStamp mechanism for VMMaker since this would mean replicating code from InterpreterPlugin; waiting for a more elegant solution to appear. In the meantime this means that this plugin will always get regenerated even if the file is uptodate"
	| cg |
	self initialize.

	cg := self buildCodeGeneratorUpTo: InterpreterPlugin.

	cg addMethodsForPrimitives: ADPCMCodec translatedPrimitives.
	inlineFlag ifTrue:[
		"now remove a few which will be inlined but not pruned"
		cg pruneMethods: #(indexForDeltaFrom:to: nextBits: nextBits:put:)].
	self storeString: cg generateCodeStringForPrimitives onFileNamed: (directory fullNameFor: self moduleName, '.c').
	^cg exportedPrimitiveNames asArray
! !

InterpreterPlugin subclass: #B3DAcceleratorPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!B3DAcceleratorPlugin commentStamp: '<historical>' prior: 0!
B3DAcceleratorPlugin translate!
!B3DAcceleratorPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:08'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!B3DAcceleratorPlugin class methodsFor: 'translation' stamp: 'ar 4/19/2001 02:21'!
moduleName
	^'B3DAcceleratorPlugin'! !
!B3DAcceleratorPlugin class methodsFor: 'translation' stamp: 'tpr 7/4/2001 15:12'!
requiresCrossPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^true! !
!B3DAcceleratorPlugin class methodsFor: 'translation' stamp: 'tpr 3/20/2001 12:16'!
requiresPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^true! !
!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas dtl 2010-09-27) 9/6/2000 22:14'!
fetchLightSource: index ofObject: anArray
	"Fetch the primitive light source from the given array.
	Note: No checks are done within here - that happened in stackLightArrayValue:"
	| lightOop |
	<inline: true>
	<returnTypeC: 'void*'>
	lightOop := interpreterProxy fetchPointer: index ofObject: anArray.
	^interpreterProxy firstIndexableField: lightOop! !
!B3DAcceleratorPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/26/2000 17:23'!
initialiseModule
	<export: true>
	^self b3dxInitialize! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:50'!
primitiveAllocateTexture
	| h w d result renderer |
	<export: true>
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	h := interpreterProxy stackIntegerValue: 0.
	w := interpreterProxy stackIntegerValue: 1.
	d := interpreterProxy stackIntegerValue: 2.
	renderer := interpreterProxy stackIntegerValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxAllocateTexture(renderer, w, h, d)' inSmalltalk:[-1].
	result = -1 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 5. "args+rcvr"
	^interpreterProxy pushInteger: result.! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:51'!
primitiveClearDepthBuffer
	| result handle |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxClearDepthBuffer(handle)'.
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 1. "pop args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:51'!
primitiveClearViewport
	| result handle pv rgba |
	<export: true>
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	pv := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	rgba := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	handle := interpreterProxy stackIntegerValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxClearViewport(handle, rgba, pv)'.
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 3. "pop args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas 12/08) 9/9/2000 16:08'!
primitiveCompositeTexture
	| result translucent y x w h texHandle rendererHandle |
	<export: true>
	interpreterProxy methodArgumentCount = 7
		ifFalse:[^interpreterProxy primitiveFail].
	translucent := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	h := interpreterProxy stackIntegerValue: 1.
	w := interpreterProxy stackIntegerValue: 2.
	y := interpreterProxy stackIntegerValue: 3.
	x := interpreterProxy stackIntegerValue: 4.
	texHandle := interpreterProxy stackIntegerValue: 5.
	rendererHandle := interpreterProxy stackIntegerValue: 6.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxCompositeTexture(rendererHandle, texHandle, x, y, w, h, translucent)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 7. "args"
! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/5/2002 16:53'!
primitiveCreateRenderer
	"NOTE: This primitive is obsolete but should be supported for older images"
	| h w y x result allowHardware allowSoftware |
	<export: true>
	interpreterProxy methodArgumentCount = 6
		ifFalse:[^interpreterProxy primitiveFail].
	h := interpreterProxy stackIntegerValue: 0.
	w := interpreterProxy stackIntegerValue: 1.
	y := interpreterProxy stackIntegerValue: 2.
	x := interpreterProxy stackIntegerValue: 3.
	allowHardware := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 4).
	allowSoftware := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 5).
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxCreateRenderer(allowSoftware, allowHardware, x, y, w, h)'.
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 7.
	^interpreterProxy pushInteger: result.! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/5/2002 16:52'!
primitiveCreateRendererFlags
	| flags h w y x result  |
	<export: true>
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	h := interpreterProxy stackIntegerValue: 0.
	w := interpreterProxy stackIntegerValue: 1.
	y := interpreterProxy stackIntegerValue: 2.
	x := interpreterProxy stackIntegerValue: 3.
	flags := interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxCreateRendererFlags(x, y, w, h, flags)'.
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 6.
	^interpreterProxy pushInteger: result.! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 5/14/2001 20:59'!
primitiveDestroyRenderer
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxDestroyRenderer(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 1. "pop arg; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:50'!
primitiveDestroyTexture
	| handle result renderer |
	<export: true>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	renderer := interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxDestroyTexture(renderer, handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 2. "pop arg; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:52'!
primitiveFinishRenderer
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxFinishRenderer(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 1. "pop arg; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:52'!
primitiveFlushRenderer
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxFlushRenderer(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 1. "pop arg; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/10/2000 00:04'!
primitiveGetIntProperty
	| handle prop result |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	prop := interpreterProxy stackIntegerValue: 0.
	handle := interpreterProxy stackIntegerValue: 1.
	result := self cCode:'b3dxGetIntProperty(handle, prop)'.
	interpreterProxy pop: 3. "args+rcvr"
	^interpreterProxy pushInteger: result! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/16/2001 17:46'!
primitiveGetRendererColorMasks
	| handle result masks array arrayOop |
	<export: true>
	<var: #masks declareC: 'int masks[4]'>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	array := interpreterProxy stackObjectValue: 0.
	handle := interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: array) = 4
		ifFalse:[^interpreterProxy primitiveFail].
	result := self cCode:'b3dxGetRendererColorMasks(handle, masks)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	arrayOop := array.
	0 to: 3 do:[:i|
		interpreterProxy pushRemappableOop: arrayOop.
		result := interpreterProxy positive32BitIntegerFor: (masks at: i).
		arrayOop := interpreterProxy popRemappableOop.
		interpreterProxy storePointer: i ofObject: arrayOop withValue: result].
	^interpreterProxy pop: 2. "pop args return receiver"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 5/14/2001 21:41'!
primitiveGetRendererSurfaceDepth
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxGetRendererSurfaceDepth(handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2. "args+rcvr"
	^interpreterProxy pushInteger: result! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 5/14/2001 21:09'!
primitiveGetRendererSurfaceHandle
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxGetRendererSurfaceHandle(handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2. "args+rcvr"
	^interpreterProxy pushInteger: result! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 5/14/2001 21:41'!
primitiveGetRendererSurfaceHeight
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxGetRendererSurfaceHeight(handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2. "args+rcvr"
	^interpreterProxy pushInteger: result! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 5/14/2001 21:41'!
primitiveGetRendererSurfaceWidth
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxGetRendererSurfaceWidth(handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2. "args+rcvr"
	^interpreterProxy pushInteger: result! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 5/14/2001 21:00'!
primitiveIsOverlayRenderer
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxIsOverlayRenderer(handle)' inSmalltalk:[false].
	interpreterProxy pop: 2. "args+rcvr"
	^interpreterProxy pushBool: result.! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 3/26/2006 22:39'!
primitiveRenderVertexBuffer
	| idxCount vtxCount vtxArray idxArray texHandle primType result flags handle |
	<export: true>
	<var: #idxArray type: 'int *'>
	<var: #vtxArray type: 'float *'>

	interpreterProxy methodArgumentCount = 8
		ifFalse:[^interpreterProxy primitiveFail].
	idxCount := interpreterProxy stackIntegerValue: 0.
	vtxCount := interpreterProxy stackIntegerValue: 2.
	texHandle := interpreterProxy stackIntegerValue: 4.
	flags := interpreterProxy stackIntegerValue: 5.
	primType := interpreterProxy stackIntegerValue: 6.
	handle := interpreterProxy stackIntegerValue: 7.

	interpreterProxy failed ifTrue:[^nil].
	vtxArray := self stackPrimitiveVertexArray: 3 ofSize: vtxCount.
	idxArray := self stackPrimitiveIndexArray: 1 ofSize: idxCount validate: true forVertexSize: vtxCount.

	(vtxArray == nil or:[idxArray == nil 
		or:[primType < 1 or:[primType > 6 
			or:[interpreterProxy failed]]]])
				ifTrue:[^interpreterProxy primitiveFail].

	result := self cCode:'b3dxRenderVertexBuffer(handle, primType, flags, texHandle, vtxArray, vtxCount, idxArray, idxCount)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 8. "pop args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:52'!
primitiveRendererVersion
	<export: true>
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	^interpreterProxy pushInteger: 1.! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 4/19/2001 02:19'!
primitiveSetBufferRect
	"Primitive. Set the buffer rectangle (e.g., the pixel area on screen) to use for this renderer.
	The viewport is positioned within the buffer rectangle."
	| h w y x result handle |
	<export: true>
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	h := interpreterProxy stackIntegerValue: 0.
	w := interpreterProxy stackIntegerValue: 1.
	y := interpreterProxy stackIntegerValue: 2.
	x := interpreterProxy stackIntegerValue: 3.
	handle := interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxSetBufferRect(handle, x, y, w, h)'.
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 5. "pop args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/15/2001 16:11'!
primitiveSetFog
	| result handle rgba density fogType stop start |
	<export: true>
	<var: #density type: 'double'>
	<var: #start type: 'double'>
	<var: #stop type: 'double'>
	interpreterProxy methodArgumentCount = 6
		ifFalse:[^interpreterProxy primitiveFail].
	rgba := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	stop := interpreterProxy floatValueOf: (interpreterProxy stackValue: 1).
	start := interpreterProxy floatValueOf: (interpreterProxy stackValue: 2).
	density := interpreterProxy floatValueOf: (interpreterProxy stackValue: 3).
	fogType := interpreterProxy stackIntegerValue: 4.
	handle := interpreterProxy stackIntegerValue: 5.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxSetFog(handle, fogType, density, start, stop, rgba)'.
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 6. "pop args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/10/2000 00:05'!
primitiveSetIntProperty
	| handle prop result value |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	value := interpreterProxy stackIntegerValue: 0.
	prop := interpreterProxy stackIntegerValue: 1.
	handle := interpreterProxy stackIntegerValue: 2.
	result := self cCode:'b3dxSetIntProperty(handle, prop, value)'.
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 3. "args; return rcvr"
! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:52'!
primitiveSetLights
	| lightArray lightCount light handle |
	<export: true>
	<inline: false>
	<var: #light type: 'void*'>

	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].

	lightArray := self stackLightArrayValue: 0.
	handle := interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self b3dxDisableLights: handle)
		ifFalse:[^interpreterProxy primitiveFail].
	lightArray == nil ifTrue:[^nil].
	lightCount := interpreterProxy slotSizeOf: lightArray.
	"For each enabled light source"
	0 to: lightCount-1 do:[:i|
		light := self fetchLightSource: i ofObject: lightArray.
		(self cCode:'b3dxLoadLight(handle, i, light)' inSmalltalk:[false])
			ifFalse:[^interpreterProxy primitiveFail].
	].
	^interpreterProxy pop: 2. "args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:52'!
primitiveSetMaterial
	| material handle |
	<export: true>
	<inline: false>
	<var: #material type: 'void*'>

	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	material := self stackMaterialValue: 0.
	handle := interpreterProxy stackIntegerValue: 1.
	(self cCode:'b3dxLoadMaterial(handle, material)' inSmalltalk:[false])
		ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 2. "args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas dtl 2010-09-27) 9/9/2000 15:52'!
primitiveSetTransform
	"Transform an entire vertex buffer using the supplied modelview and projection matrix."
	| projectionMatrix modelViewMatrix handle |
	<export: true>
	<inline: false>
	<var: #projectionMatrix declareC: 'float *projectionMatrix'>
	<var: #modelViewMatrix declareC: 'float *modelViewMatrix'>

	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].

	projectionMatrix := self stackMatrix: 0.
	modelViewMatrix := self stackMatrix: 1.
	handle := interpreterProxy stackIntegerValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	self cCode: 'b3dxSetTransform(handle, modelViewMatrix, projectionMatrix)'.
	^interpreterProxy pop: 3. "Leave rcvr on stack"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 4/20/2001 01:47'!
primitiveSetVerboseLevel
	| result level |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	level := interpreterProxy stackIntegerValue: 0.
	result := self cCode:'b3dxSetVerboseLevel(level)'.
	interpreterProxy pop: 2. "args+rcvr"
	^interpreterProxy pushInteger: result! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:53'!
primitiveSetViewport
	| h w y x result handle |
	<export: true>
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	h := interpreterProxy stackIntegerValue: 0.
	w := interpreterProxy stackIntegerValue: 1.
	y := interpreterProxy stackIntegerValue: 2.
	x := interpreterProxy stackIntegerValue: 3.
	handle := interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxSetViewport(handle, x, y, w, h)'.
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 5. "pop args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-renderer' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:53'!
primitiveSwapRendererBuffers
	| handle result |
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxSwapRendererBuffers(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 1. "pop arg; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:50'!
primitiveTextureByteSex
	| handle result renderer |
	<export: true>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	renderer := interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxTextureByteSex(renderer, handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 3.
	^interpreterProxy pushBool: result.! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:50'!
primitiveTextureDepth
	| handle result renderer |
	<export: true>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	renderer := interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxActualTextureDepth(renderer, handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 3.
	^interpreterProxy pushInteger: result.! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/16/2001 17:46'!
primitiveTextureGetColorMasks
	| handle result masks array renderer arrayOop |
	<export: true>
	<var: #masks declareC: 'int masks[4]'>
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	array := interpreterProxy stackObjectValue: 0.
	handle := interpreterProxy stackIntegerValue: 1.
	renderer := interpreterProxy stackIntegerValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: array) = 4
		ifFalse:[^interpreterProxy primitiveFail].
	result := self cCode:'b3dxTextureColorMasks(renderer, handle, masks)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	arrayOop := array.
	0 to: 3 do:[:i|
		interpreterProxy pushRemappableOop: arrayOop.
		result := interpreterProxy positive32BitIntegerFor: (masks at: i).
		arrayOop := interpreterProxy popRemappableOop.
		interpreterProxy storePointer: i ofObject: arrayOop withValue: result].
	^interpreterProxy pop: 3. "pop args return receiver"! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas 12/08) 5/14/2001 20:01'!
primitiveTextureSurfaceHandle
	| handle result renderer |
	<export: true>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	handle := interpreterProxy stackIntegerValue: 0.
	renderer := interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxTextureSurfaceHandle(renderer, handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 3.
	^interpreterProxy pushInteger: result! !
!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar (auto pragmas 12/08) 9/9/2000 15:50'!
primitiveTextureUpload
	| h w d result form bits ppw bitsPtr handle renderer |
	<export: true>
	<var: #bitsPtr type: 'void*'>
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	form := interpreterProxy stackValue: 0.
	((interpreterProxy isPointers: form) and:[(interpreterProxy slotSizeOf: form) >= 4])
		ifFalse:[^interpreterProxy primitiveFail].
	bits := interpreterProxy fetchPointer: 0 ofObject: form.
	w := interpreterProxy fetchInteger: 1 ofObject: form.
	h := interpreterProxy fetchInteger: 2 ofObject: form.
	d := interpreterProxy fetchInteger: 3 ofObject: form.
	ppw := 32 // d.
	(interpreterProxy isWords: bits)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: bits) = (w + ppw - 1 // ppw * h)
		ifFalse:[^interpreterProxy primitiveFail].
	bitsPtr := interpreterProxy firstIndexableField: bits.
	handle := interpreterProxy stackIntegerValue: 1.
	renderer := interpreterProxy stackIntegerValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	result := self cCode:'b3dxUploadTexture(renderer, handle, w, h, d, bitsPtr)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	^interpreterProxy pop: 3. "args; return rcvr"! !
!B3DAcceleratorPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/26/2000 17:23'!
shutdownModule
	<export: true>
	^self b3dxShutdown! !
!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas 12/08) 3/26/2006 22:39'!
stackLightArrayValue: stackIndex
	"Load an Array of B3DPrimitiveLights from the given stack index"
	| oop array arraySize |
	<inline: false>
	array := interpreterProxy stackObjectValue: stackIndex.
	array = nil ifTrue:[^nil].
	array = interpreterProxy nilObject ifTrue:[^nil].
	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	arraySize := interpreterProxy slotSizeOf: array.
	0 to: arraySize-1 do:[:i|
		oop := interpreterProxy fetchPointer: i ofObject: array.
		(interpreterProxy isIntegerObject: oop)
			ifTrue:[^interpreterProxy primitiveFail].
		((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = 32])
			ifFalse:[^interpreterProxy primitiveFail].
	].
	^array! !
!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:38'!
stackMaterialValue: stackIndex
	"Load a B3DMaterial from the given stack index"
	| oop |
	<inline: false>
	<returnTypeC: 'void *'>
	oop := interpreterProxy stackObjectValue: stackIndex.
	oop = nil ifTrue:[^nil].
	oop = interpreterProxy nilObject ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) =  17])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !
!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas dtl 2010-09-27) 9/6/2000 22:14'!
stackMatrix: index
	"Load a 4x4 transformation matrix from the interpreter stack.
	Return a pointer to the matrix data if successful, nil otherwise."
	| oop |
	<inline: false>
	<returnTypeC: 'void*'>
	oop := interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	oop = interpreterProxy nilObject ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = 16])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !
!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/26/2000 12:37'!
stackPrimitiveIndexArray: stackIndex ofSize: nItems validate: aBool forVertexSize: maxIndex
	"Load a primitive index array from the interpreter stack.
	If aBool is true then check that all the indexes are in the range (1,maxIndex).
	Return a pointer to the index data if successful, nil otherwise."
	| oop oopSize idxPtr index |
	<inline: false>
	<returnTypeC: 'void*'>
	<var: #idxPtr declareC: 'int *idxPtr'>

	oop := interpreterProxy stackObjectValue: stackIndex.
	oop = nil ifTrue:[^nil].
	(interpreterProxy isWords: oop) ifFalse:[^nil].
 	oopSize := interpreterProxy slotSizeOf: oop.
	oopSize < nItems ifTrue:[^nil].
	idxPtr := self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int *'.
	aBool ifTrue:[
		0 to: nItems-1 do:[:i|
			index := idxPtr at: i.
			(index < 0 or:[index > maxIndex]) ifTrue:[^nil]]].
	^idxPtr! !
!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:40'!
stackPrimitiveVertex: index
	"Load a primitive vertex from the interpreter stack.
	Return a pointer to the vertex data if successful, nil otherwise."
	| oop |
	<inline: false>
	<returnTypeC: 'void*'>
	oop := interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = 16])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !
!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:40'!
stackPrimitiveVertexArray: index ofSize: nItems
	"Load a primitive vertex array from the interpreter stack.
	Return a pointer to the vertex data if successful, nil otherwise."
	| oop oopSize |
	<inline: false>
	<returnTypeC: 'void*'>
	oop := interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	(interpreterProxy isWords: oop) ifTrue:[
 		oopSize := interpreterProxy slotSizeOf: oop.
		(oopSize >= nItems * 16 and:[oopSize \\ 16 = 0])
			ifTrue:[^interpreterProxy firstIndexableField: oop]].
	^nil! !

InterpreterPlugin subclass: #BMPReadWriterPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!BMPReadWriterPlugin commentStamp: 'tpr 5/5/2003 16:45' prior: 0!
A plugin to provide fast read and write of .bmp files!
!BMPReadWriterPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 8/1/2006 09:54'!
primitiveRead24BmpLine
	| width formBitsIndex formBitsOop pixelLineOop formBitsSize formBits pixelLineSize pixelLine |
	<export: true>
	<inline: false>
	<var: #formBits type: 'unsigned int *'>
	<var: #pixelLine type: 'unsigned char *'>
	interpreterProxy methodArgumentCount = 4 
		ifFalse:[^interpreterProxy primitiveFail].
	width := interpreterProxy stackIntegerValue: 0.
	width <= 0 ifTrue:[^interpreterProxy primitiveFail].
	formBitsIndex := interpreterProxy stackIntegerValue: 1.
	formBitsOop := interpreterProxy stackObjectValue: 2.
	pixelLineOop := interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: formBitsOop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: pixelLineOop)
		ifFalse:[^interpreterProxy primitiveFail].
	formBitsSize := interpreterProxy slotSizeOf: formBitsOop.
	formBits := interpreterProxy firstIndexableField: formBitsOop.
	pixelLineSize := interpreterProxy slotSizeOf: pixelLineOop.
	pixelLine := interpreterProxy firstIndexableField: pixelLineOop.
	(formBitsIndex + width <= formBitsSize and:[width*3 <= pixelLineSize])
		ifFalse:[^interpreterProxy primitiveFail].

	"do the actual work"
	self cCode:'
	formBits += formBitsIndex-1;
	while(width--) {
		unsigned int rgb;
		rgb = (*pixelLine++);
		rgb += (*pixelLine++) << 8;
		rgb += (*pixelLine++) << 16;
		if(rgb) rgb |= 0xFF000000; else rgb |= 0xFF000001;
		*formBits++ = rgb;
	}
	' inSmalltalk:[formBits. pixelLine. ^interpreterProxy primitiveFail].
	interpreterProxy pop: 4. "args"
! !
!BMPReadWriterPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 8/1/2006 09:53'!
primitiveWrite24BmpLine

	| width formBitsIndex formBitsOop pixelLineOop formBitsSize formBits pixelLineSize pixelLine |
	<export: true>
	<inline: false>
	<var: #formBits type: 'unsigned int *'>
	<var: #pixelLine type: 'unsigned char *'>
	interpreterProxy methodArgumentCount = 4 
		ifFalse:[^interpreterProxy primitiveFail].
	width := interpreterProxy stackIntegerValue: 0.
	width <= 0 ifTrue:[^interpreterProxy primitiveFail].
	formBitsIndex := interpreterProxy stackIntegerValue: 1.
	formBitsOop := interpreterProxy stackObjectValue: 2.
	pixelLineOop := interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: formBitsOop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: pixelLineOop)
		ifFalse:[^interpreterProxy primitiveFail].
	formBitsSize := interpreterProxy slotSizeOf: formBitsOop.
	formBits := interpreterProxy firstIndexableField: formBitsOop.
	pixelLineSize := interpreterProxy slotSizeOf: pixelLineOop.
	pixelLine := interpreterProxy firstIndexableField: pixelLineOop.

	(formBitsIndex + width <= formBitsSize and:[width*3 <= pixelLineSize])
		ifFalse:[^interpreterProxy primitiveFail].

	"do the actual work. Read 32 bit at a time from formBits, and store the low order 24 bits 
	or each word into pixelLine in little endian order."

	self cCode:'
	formBits += formBitsIndex-1;

	while(width--) {
		unsigned int rgb;
		rgb = *formBits++;
		(*pixelLine++) = (rgb      ) & 0xFF;
		(*pixelLine++) = (rgb >> 8 ) & 0xFF;
		(*pixelLine++) = (rgb >> 16) & 0xFF;
	}

	' inSmalltalk:[formBits. pixelLine. ^interpreterProxy primitiveFail].
	interpreterProxy pop: 4. "args"
! !

InterpreterPlugin subclass: #BalloonEngineBase
	instanceVariableNames: 'workBuffer objBuffer getBuffer aetBuffer spanBuffer engine formArray engineStopped geProfileTime dispatchedValue dispatchReturnValue objUsed doProfileStats copyBitsFn loadBBFn bbPluginName'
	classVariableNames: 'EdgeInitTable EdgeStepTable FillTable WideLineFillTable WideLineWidthTable'
	poolDictionaries: 'BalloonEngineConstants'
	category: 'VMMaker-Plugins'!
!BalloonEngineBase commentStamp: 'tpr 5/5/2003 11:45' prior: 0!
This is the main class for the Balloon graphics Engine.

BalloonEnginePlugin should be translated but its superclass should not since it is incorporated within that class's translation process. Nor should the simulation subclass be translated!
!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:33'!
a1EngineOutline
	"The following is a brief outline on how the engine works.

	In general, we're using a pretty straight-forward active edge approach, e.g., 
	we classify all edges into three different states:
		a) Waiting for processing
		b) Active (e.g., being processed)
		c) Finished
	Before the engine starts all edges are sorted by their y-value in a so-called
	'global edge table' (furthermore referred to as GET) and processed in top 
	to bottom order (the edges are also sorted by x-value but this is only for 
	simplifying the insertion when adding edges).

	Then, we start at the first visible scan line and execute the following steps:

	1) Move all edges starting at the current scan line from state a) to state b)

	This step requires the GET to be sorted so that we only need to check
	the first edges of the GET. After the initial state of the edge (e.g., it's current
	pixel value and data required for incremental updates) the edges are then 
	inserted in the 'active edge table' (called AET). The sort order in the AET is 
	defined by the pixel position of each edge at the current scan line and thus 
	edges are kept in increasing x-order.

	This step does occur for every edge only once and is therefore not the most
	time-critical part of the approach.

	2) Draw the current scan line

	This step includes two sub-parts. In the first part, the scan line is assembled.
	This involves walking through the AET and drawing the pixels between
	each two neighbour edges. Since each edge can have two associated fills
	(a 'left' and a 'right' fill) we need to make sure that edges falling on the
	same pixel position do not affect the painted image. This issue is discussed
	in the aetScanningProblems documentation.

	Wide edges (e.g., edges having an associated width) are also handled during
	this step. Wide edges are always preferred over interior fills - this ensures
	that the outline of an object cannot be overdrawn by any interior fill of
	a shape that ends very close to the edge (for more information see wideEdges 
	documentation).

	After the scan is assembled it is blitted to the screen. This only happens all
	'aaLevel' scan lines (for further information see the antiAliasing documentation).

	This second step is done at each scan line in the image, and is usually the most
	time-critical part.

	3) Update all currently active edges

	Updating the active edges basically means either to remove the edge from the AET
	(if it is at the end y value) or incrementally computing the pixel value for the
	next scan line. Based on the information gathered in the first step, this part
	should be executed as fast as possible - it happens for each edge in the AET
	at each scan line and may be the bottleneck if many edges are involved in
	the drawing operations (see the TODO list; part of it probably deals with the
	issue).

"
	^self error:'Comment only'! !
!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:55'!
a2AntiAliasing
	"The engine currently used a very simple, but efficient anti-aliasing scheme. It is based on a square unweighted filter of size 1, 2, or 4 resulting in three levels of anti-aliasing:

	* No anti-aliasing (filter size 1)
	This simply draws each pixel 'as is' on the screen

	* Slight anti-aliasing (filter size 2)
	Doubles the rasterization size in each direction and assembles the pixel value as the medium of the four sub-pixels falling into the full pixel

	* Full anti-aliasing (filter size 4)
	Quadruples the rasterization in each direction and assembles the pixel value as the medium of the sixteen sub-pixels falling into the full pixel


The reason for using these three AA levels is simply efficiency of computing. Since the above filters (1x1, 2x2, 4x4) have all power of two elements (1, 4, and 16) we can compute the weighted sum of the final pixel by computing

	destColor := destColor + (srcColor // subPixels)

And, since we're only working on 32bit destination buffer we do not need to compute the components of each color separately but can neatly put the entire color into a single formula:

	destPixel32 := destPixel32 + ((srcPixel32 bitAnd: aaMask) >> aaShift).

with aaMask = 16rFFFFFFFF for aaLevel = 1, aaMask = 16rFCFCFCFC for aaLevel = 2, aaMask = 16rF0F0F0F0 for aaLevel = 4 and aaShift = 0, 2, or 4 for the different levels. However, while the above is efficient to compute, it also drops accuracy. So, for the 4x4 anti-aliasing we're effectively only using the high 4 bits of each color component. While is generally not a problem (we add 16 sub-pixels into this value) there is a simple arithmetic difficulty because the above cannot fill the entire range of values, e.g.,

	16 * (255 // 16) = 16 * 15 = 240

and not 255 as expected. We solve this problem by replicating the top n (n=0, 2, 4) bits of each component as the low bits in an adjustment step before blitting to scan line to the screen. This has the nice effect that a zero pixel value (e.g., transparent) will remain zero, a white pixel (as computed above) will result in a value of 255 for each component (defining opaque white) and each color inbetween linearly mapped between 0 and 255. 

"
	^self error:'Comment only'! !
!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:35'!
a3RasterizationRules


	^self error:'Comment only'! !
!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:35'!
a4WideEdges! !
!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:36'!
a5AETScanningProblems
	"Due to having two fill entries (one left and one right) there can be problems while scanning the active edge table. In general, the AET should look like the following (ri - regions, ei - edges, fi - fills):

			|				\				|
	r1		|		r2		 \		r3		|		r4
			|				  \				|
			e1				 e2				e3		

	with:
		f(r1) = fLeft(e1) = 0				(empty fill, denoted -)
		f(r2) = fRight(e1) = fLeft(e2)		(denoted x)
		f(r3) = fRight(e2) = fLeft(e3)	(denoted o)
		f(r4) = fRight(e3) = 0

	However, due to integer arithmetic used during computations the AET may look like the following:
			X
			\|						|
			 | \						|
			 |   \					|
	r1		 | r2 \			r3		|		r4
			 |	   \					|
			e1		e2				e3		

	In this case, the starting point of e1 and e2 have the same x value at the first scan line but e2 has been sorted before e1 (Note: This can happen in *many* cases - the above is just a very simple example). Given the above outlined fill relations we have a problem. So, for instance, using the left/right fills as defined by the edges would lead to the effect that in the first scan line region r3 is actually filled with the right fill of e1 while it should actually be filled with the right fill of e2. This leads to noticable artifacts in the image and increasing resolution does not help.

	What we do here is defining an arbitrary sort order between fills (you can think of it as a depth value but the only thing that matters is that you can order the fills by this number and that the empty fill is always sorted at the end), and toggle the fills between an 'active' and an 'inactive' state at each edge. This is done as follows:
	For each edge ei in the AET do:
		* if fLeft(ei) isActive then removeActive(fLeft(ei)) else addActive(fLeft(ei))
		* if fRight(ei) isActive then removeActive(fRight(ei)) else addActive(fRight(ei))
		* draw the span from ei to ei+1 with currentActive
	where addActive adds the fill to the list of currently active fills, removeActive() removes the fill from the active list and currentActive returns the fill AS DEFINED BY THE SORT ORDER from the list of active fills. Note that this does not change anything in the first example above because the list will only contain one entry (besides the empty fill). In the second case however, it will lead to the following sequence:

	* toggle fLeft(e2) = f(r2) = 'x'
		- makes fLeft(e2) active
		- activeList = 'x'
	* toggle fRight(e2) = f(r3) = 'o'
		- makes fRight(e2) active
		- activeList = 'xo'
	* draw span from e2 to e1
		Depending on the sort order between 'x' and 'o' the region will be drawn with either one of the fills. It is significant to note here that the occurence of such a problem is generally only *very* few pixels large (in the above example zero pixels) and will therefore not be visually noticable. In any case, there is a unique decision for the fill to use here and that is what we need if the problem did not happen accidentally (e.g., someone has manually changed one fill of an edge but not the fill of the opposite edge).

	* toggle fLeft(e1) = f(r1) = '-'
		- makes fLeft(r1) visible
		- activeList = 'xo-'
		[Note: empty fills are a special case. 
		They can be ignored since they sort last
		and the activeList can return the empty
		fill if it is itself empty].
	* toggle fRight(e1) = f(r2) = 'x'
		- makes fRight(e1) invisible
		- activeList = 'o-'
	* draw span from e2 to e3
		Since the active list contains (besides the empty fill) only one fill value this will be used. Fortunately, this is the correct fill because it is the fill we had initially defined for the region r2.

An interesting side effect of the above is that there is no such notion as a 'left' or 'right' fill anymore. Another (not-so-nice) side effect is that the entire AET has to be scanned from the beginning even if only the last few edges actually affect the visible region.

PS. I need to find a way of clipping the edges for this. More on it later...
"
	^self error:'Comment only'! !
!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/8/1998 00:06'!
a6StuffTODO
	"This is an unordered list of things to do:

BalloonEnginePlugin>>stepToFirstBezierIn:at:
	1)	Check if reducing maxSteps from 2*deltaY to deltaY 
		brings a *significant* performance improvement.
		In theory this should make for double step performance
		but will cost in quality. Might be that the AA stuff will
		compensate for this - but I'm not really sure.

BalloonEngineBase>>dispatchOn:in:
	1)	Check what dispatches cost most and must be inlined
		by an #inlinedDispatchOn:in: Probably this will be
		stepping and eventually wide line stuff but we'll see.

BalloonEngineBase
	1)	Check which variables should become inst vars, if any.
		This will remove an indirection during memory access
		and might allow a couple of optimizations by the C compiler.

Anti-Aliasing:
	1)	Check if we can use a weighted 3x3 filter function of the form
				1	2	1
				2	4	2
				1	2	1
		Which should be *extremely* nice for fonts (it's sharpening
		edges). The good thing about the above is that it sums up to
		16 (as in the 4x4 case) but I don't know how to keep a history
		without needing two extra scan lines.

	2)	Check if we can - somehow - integrate more general filters.

	3) Unroll the loops during AA so we can copy and mask aaLevel pixels
	   in each step between start and end. This should speed up filling
	   by a factor of 2-4 (in particular for difficult stuff like radial gradients).

Clipping
	1)	Find a way of clipping edges left of the clip rectangle
		or at least ignoring most of them after the first scan line.
		The AET scanning problems discuss the issue but it should be
		possible to keep the color list between spans (if not empty)
		and speed up drawing at the very right (such as in the
		Winnie Pooh example where a lot of stuff is between the
		left border and the clipping rect.

	2)	Check if we can determine empty states of the color list and
		an edge that is longer than anything left of it. This should
		work in theory but might be relatively expensive to compute.

"
	^self error:'Comment only'! !
!BalloonEngineBase class methodsFor: 'translation' stamp: 'ikp 6/14/2004 15:19'!
declareCVarsIn: cg

	"Buffers"
	cg var: #workBuffer type: #'int*'.
	cg var: #objBuffer type: #'int*'.
	cg var: #getBuffer type: #'int*'.
	cg var: #aetBuffer type: #'int*'.
	cg var: #spanBuffer type: #'unsigned int*'.
	cg var: #edgeTransform declareC: 'float edgeTransform[6]'.
	cg var: #doProfileStats declareC: 'int doProfileStats = 0'.
	cg var: 'bbPluginName' declareC:'char bbPluginName[256] = "BitBltPlugin"'.
	"Functions"
	cg var: 'copyBitsFn'	type: 'void *'.
	cg var: 'loadBBFn'	type: 'void *'.! !
!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/7/1998 22:26'!
initialize
	"BalloonEngineBase initialize"
	"BalloonEnginePlugin translateDoInlining: true."
	EdgeInitTable := self initializeEdgeInitTable.
	EdgeStepTable := self initializeEdgeStepTable.
	WideLineWidthTable := self initializeWideLineWidthTable.
	WideLineFillTable := self initializeWideLineFillTable.
	FillTable := self initializeFillTable.! !
!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 21:52'!
initializeEdgeInitTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex

		stepToFirstLine
		stepToFirstWideLine
		stepToFirstBezier
		stepToFirstWideBezier
	)! !
!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 21:52'!
initializeEdgeStepTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex

		stepToNextLine
		stepToNextWideLine
		stepToNextBezier
		stepToNextWideBezier
	)! !
!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/25/1998 19:46'!
initializeFillTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex "Type zero - undefined"
		errorWrongIndex "Type one - external fill"

		fillLinearGradient "Linear gradient fill"
		fillRadialGradient "Radial gradient fill"

		fillBitmapSpan	"Clipped bitmap fill"
		fillBitmapSpan	"Repeated bitmap fill"
	)! !
!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 23:03'!
initializeWideLineFillTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		returnWideLineFill
		returnWideBezierFill
	)! !
!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 23:03'!
initializeWideLineWidthTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		returnWideLineWidth
		returnWideBezierWidth
	)! !
!BalloonEngineBase class methodsFor: 'accessing' stamp: 'ar 5/11/2000 23:48'!
moduleName
	^'B2DPlugin'! !
!BalloonEngineBase class methodsFor: 'translation' stamp: 'tpr 5/14/2001 12:14'!
shouldBeTranslated
"BalloonEnginePlugin should be translated but its superclasse should not since it is incorporated within this class's translation process. Nor should the simulation subclass be translated"
	^self == BalloonEnginePlugin! !
!BalloonEngineBase class methodsFor: 'accessing' stamp: 'ar 11/11/1998 21:56'!
simulatorClass
	^BalloonEngineSimulation! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorMaskGet
	^workBuffer at: GWAAColorMask! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorMaskPut: value
	^workBuffer at: GWAAColorMask put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorShiftGet
	^workBuffer at: GWAAColorShift! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorShiftPut: value
	^workBuffer at: GWAAColorShift put: value! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/9/1998 00:53'!
aaFirstPixelFrom: leftX to: rightX
	"Common function to compute the first full pixel for AA drawing"
	| firstPixel |
	<inline: true>
	firstPixel := (leftX + self aaLevelGet - 1) bitAnd: (self aaLevelGet - 1) bitInvert32.
	firstPixel > rightX 
		ifTrue:[^rightX]
		ifFalse:[^firstPixel]! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaHalfPixelGet
	^workBuffer at: GWAAHalfPixel! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaHalfPixelPut: value
	^workBuffer at: GWAAHalfPixel put: value! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/9/1998 00:53'!
aaLastPixelFrom: leftX to: rightX
	"Common function to compute the last full pixel for AA drawing"
	<inline: true>
	^(rightX - 1) bitAnd: (self aaLevelGet - 1) bitInvert32.! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaLevelGet
	^workBuffer at: GWAALevel! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaLevelPut: value
	^workBuffer at: GWAALevel put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaScanMaskGet
	^workBuffer at: GWAAScanMask! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaScanMaskPut: value
	^workBuffer at: GWAAScanMask put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaShiftGet
	^workBuffer at: GWAAShift! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:36'!
aaShiftPut: value
	^workBuffer at: GWAAShift put: value! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/9/1998 02:06'!
accurateLengthOf: deltaX with: deltaY
	"Return the accurate length of the vector described by deltaX and deltaY"
	| length2 |
	deltaX = 0 ifTrue:[deltaY < 0 ifTrue:[^0-deltaY] ifFalse:[^deltaY]].
	deltaY = 0 ifTrue:[deltaX < 0 ifTrue:[^0-deltaX] ifFalse:[^deltaX]].
	length2 := (deltaX * deltaX) + (deltaY * deltaY).
	^self computeSqrt: length2! !
!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar (auto pragmas 12/08) 11/1/1998 01:07'!
addEdgeToGET: edge
	<inline: false>
	(self allocateGETEntry: 1) ifFalse:[^0].
	"Install edge in the GET"
	getBuffer at: self getUsedGet put: edge.
	self getUsedPut: self getUsedGet + 1.! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/9/1998 00:50'!
adjustAALevel

		"NOTE: 	This method is (hopefully) obsolete due to unrolling 
				the fill loops to deal with full pixels."

	"Adjust the span buffers values by the appropriate color offset for anti-aliasing.
	We do this by replicating the top bits of each color in the lower bits. The idea is that we can scale each color value uniquely from 0 to 255 and thus fill the entire range of colors."
	| adjustShift adjustMask x0 x1 pixelValue |
	<inline: false>
	adjustShift := 8 - self aaColorShiftGet.
	adjustMask := self aaColorMaskGet bitInvert32.
	x0 := self spanStartGet >> self aaShiftGet.
	x1 := self spanEndGet >> self aaShiftGet.
	[x0 < x1] whileTrue:[
		pixelValue := spanBuffer at: x0.
		spanBuffer at: x0 put: (pixelValue bitOr: (pixelValue >> adjustShift bitAnd: adjustMask)).
		x0 := x0 + 1].! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
aetStartGet
	^workBuffer at: GWAETStart! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:29'!
aetStartPut: value
	^workBuffer at: GWAETStart put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
aetUsedGet
	^workBuffer at: GWAETUsed! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:29'!
aetUsedPut: value
	^workBuffer at: GWAETUsed put: value! !
!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/29/1998 18:37'!
allocateAETEntry: nSlots
	"Allocate n slots in the active edge table"
	^self needAvailableSpace: nSlots! !
!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar (auto pragmas 12/08) 10/28/1998 21:06'!
allocateGETEntry: nSlots
	"Allocate n slots in the global edge table"
	| srcIndex dstIndex |
	<inline: false>
	"First allocate nSlots in the AET"
	(self allocateAETEntry: nSlots) ifFalse:[^false].
	self aetUsedGet = 0 ifFalse:["Then move the AET upwards"
		srcIndex := self aetUsedGet.
		dstIndex := self aetUsedGet + nSlots.
		1 to: self aetUsedGet do:[:i|
			aetBuffer at: (dstIndex := dstIndex - 1) put: (aetBuffer at: (srcIndex := srcIndex - 1))].
	].
	aetBuffer := aetBuffer + nSlots.
	^true! !
!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar (auto pragmas 12/08) 10/28/1998 21:16'!
allocateObjEntry: nSlots
	"Allocate n slots in the object buffer"
	| srcIndex dstIndex |
	<inline: false>
	"First allocate nSlots in the GET"
	(self allocateGETEntry: nSlots) ifFalse:[^false].
	self getUsedGet = 0 ifFalse:["Then move the GET upwards"
		srcIndex := self getUsedGet.
		dstIndex := self getUsedGet + nSlots.
		1 to: self getUsedGet do:[:i|
			getBuffer at: (dstIndex := dstIndex - 1) put: (getBuffer at: (srcIndex := srcIndex - 1))].
	].
	getBuffer := getBuffer + nSlots.
	^true! !
!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/29/1998 18:37'!
allocateStackEntry: nSlots
	"AET and Stack allocation are symmetric"
	^self needAvailableSpace: nSlots! !
!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/30/1998 19:24'!
allocateStackFillEntry
	^self wbStackPush: self stackFillEntryLength! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/9/1998 15:34'!
areEdgeFillsValid: edge

	^((self objectHeaderOf: edge) bitAnd: GEEdgeFillsInvalid) = 0! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/14/1998 19:31'!
clearSpanBuffer
	"Clear the current span buffer.
	The span buffer is only cleared in the area that has been used by the previous scan line."
	| x0 x1 |
	<inline: false>
	x0 := self spanStartGet >> self aaShiftGet.
	x1 := self spanEndGet >> self aaShiftGet + 1.
	x0 < 0 ifTrue:[x0 := 0].
	x1 > self spanSizeGet ifTrue:[x1 := self spanSizeGet].
	[x0 < x1] whileTrue:[
		spanBuffer at: x0 put: 0.
		x0 := x0 + 1].
	self spanStartPut: self spanSizeGet.
	self spanEndPut: 0.! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 00:43'!
clearSpanBufferGet
	^workBuffer at: GWClearSpanBuffer! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 00:44'!
clearSpanBufferPut: value
	^workBuffer at: GWClearSpanBuffer put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxXGet
	^workBuffer at: GWClipMaxX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxXPut: value
	^workBuffer at: GWClipMaxX put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxYGet
	^workBuffer at: GWClipMaxY! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxYPut: value
	^workBuffer at: GWClipMaxY put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMinXGet
	^workBuffer at: GWClipMinX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:47'!
clipMinXPut: value
	^workBuffer at: GWClipMinX put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:47'!
clipMinYGet
	^workBuffer at: GWClipMinY! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:47'!
clipMinYPut: value
	^workBuffer at: GWClipMinY put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/24/1998 21:36'!
colorTransform
	<returnTypeC: 'float *'>
	^self cCoerce: workBuffer + GWColorTransform to:'float *'! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/7/1998 14:26'!
computeSqrt: length2
	length2 < 32 
		ifTrue:[^self smallSqrtTable at: length2]
		ifFalse:[^(length2 asFloat sqrt + 0.5) asInteger]! !
!BalloonEngineBase methodsFor: 'private' stamp: 'ikp 6/14/2004 15:14'!
copyBitsFrom: x0 to: x1 at: yValue

	copyBitsFn = 0 ifTrue: [
		"We need copyBits here so try to load it implicitly"
		self initialiseModule ifFalse: [^false].
	].
	^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))copyBitsFn)(x0, x1, yValue)'! !
!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar (auto pragmas 12/08) 11/25/1998 00:41'!
createGlobalEdgeTable
	"Create the global edge table"
	| object end |
	<inline: false>
	object := 0.
	end := objUsed.
	[object < end] whileTrue:[
		"Note: addEdgeToGET: may fail on insufficient space but that's not a problem here"
		(self isEdge: object) ifTrue:[
			"Check if the edge starts below fillMaxY."
			(self edgeYValueOf: object) >= self fillMaxYGet ifFalse:[
				self checkedAddEdgeToGET: object.
			].
		].
		object := object + (self objectLengthOf: object).
	].! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
currentYGet
	^workBuffer at: GWCurrentY! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 21:27'!
currentYPut: value
	^workBuffer at: GWCurrentY put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 20:28'!
currentZGet
	^workBuffer at: GWCurrentZ! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 20:29'!
currentZPut: value
	^workBuffer at: GWCurrentZ put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:23'!
destOffsetXGet
	^workBuffer at: GWDestOffsetX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:24'!
destOffsetXPut: value
	^workBuffer at: GWDestOffsetX put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:23'!
destOffsetYGet
	^workBuffer at: GWDestOffsetY! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:24'!
destOffsetYPut: value
	^workBuffer at: GWDestOffsetY put: value! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:42'!
displaySpanBufferAt: y
	"Display the span buffer at the current scan line."
	| targetX0 targetX1 targetY |
	<inline: false>
	"self aaLevelGet > 1 ifTrue:[self adjustAALevel]."
	targetX0 := self spanStartGet >> self aaShiftGet.
	targetX0 < self clipMinXGet ifTrue:[targetX0 := self clipMinXGet].
	targetX1 := (self spanEndGet + self aaLevelGet - 1) >> self aaShiftGet.
	targetX1 > self clipMaxXGet ifTrue:[targetX1 := self clipMaxXGet].
	targetY := y >> self aaShiftGet.
	(targetY < self clipMinYGet or:[targetY >= self clipMaxYGet or:[
		targetX1 < self clipMinXGet or:[targetX0 >= self clipMaxXGet]]]) ifTrue:[^0].
	self copyBitsFrom: targetX0 to: targetX1 at: targetY.! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/25/1998 02:34'!
drawWideEdge: edge from: leftX
	"Draw the given edge starting from leftX with the edge's fill.
	Return the end value of the drawing operation."
	| rightX fill type lineWidth |
	<inline: false> "Not for the moment"
	type := self edgeTypeOf: edge.
	dispatchedValue := edge.
	self dispatchOn: type in: WideLineWidthTable.
	lineWidth := dispatchReturnValue.
	self dispatchOn: type in: WideLineFillTable.
	fill := self makeUnsignedFrom: dispatchReturnValue.
	fill = 0 ifTrue:[^leftX].
	"Check if this line is only partially visible"
	"self assert:(self isFillColor: fill)."
	rightX := leftX + lineWidth.
	self fillSpan: fill from: leftX to: rightX.
	^rightX! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/9/1998 15:35'!
edgeFillsInvalidate: edge

	^self objectTypeOf: edge put: 
		((self objectTypeOf: edge) bitOr: GEEdgeFillsInvalid)! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/9/1998 15:35'!
edgeFillsValidate: edge

	^self objectTypeOf: edge put: 
		((self objectTypeOf: edge) bitAnd: GEEdgeFillsInvalid bitInvert32)! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeLeftFillOf: edge

	^self obj: edge at: GEFillIndexLeft! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeLeftFillOf: edge put: value

	^self obj: edge at: GEFillIndexLeft put: value! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeNumLinesOf: edge

	^self obj: edge at: GENumLines! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeNumLinesOf: edge put: value

	^self obj: edge at: GENumLines put: value! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeRightFillOf: edge

	^self obj: edge at: GEFillIndexRight! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeRightFillOf: edge put: value

	^self obj: edge at: GEFillIndexRight put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/24/1998 21:36'!
edgeTransform
	<returnTypeC: 'float *'>
	^self cCoerce: workBuffer + GWEdgeTransform to:'float *'! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/9/1998 15:35'!
edgeTypeOf: edge
	"Return the edge type (e.g., witout the wide edge flag)"

	^(self objectTypeOf: edge) >> 1! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeXValueOf: edge

	^self obj: edge at: GEXValue! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeXValueOf: edge put: value

	^self obj: edge at: GEXValue put: value! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeYValueOf: edge

	^self obj: edge at: GEYValue! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:06'!
edgeYValueOf: edge put: value

	^self obj: edge at: GEYValue put: value! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:06'!
edgeZValueOf: edge

	^self obj: edge at: GEZValue! !
!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:06'!
edgeZValueOf: edge put: value

	^self obj: edge at: GEZValue put: value! !
!BalloonEngineBase methodsFor: 'private' stamp: 'ar 5/13/2000 14:55'!
errorWrongIndex
	"Ignore dispatch errors when translating to C
	(since we have no entry point for #error in the VM proxy)"
	self cCode:'' inSmalltalk:[self error:'BalloonEngine: Fatal dispatch error']! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/8/1998 14:33'!
estimatedLengthOf: deltaX with: deltaY
	"Estimate the length of the vector described by deltaX and deltaY.
	This method may be extremely inaccurate - use it only
	if you know exactly that this doesn't matter. Otherwise
	use #accurateLengthOf:width:"
	| absDx absDy |
	deltaX >= 0 ifTrue:[absDx := deltaX] ifFalse:[absDx := 0 - deltaX].
	deltaY >= 0 ifTrue:[absDy := deltaY] ifFalse:[absDy := 0 - deltaY].
	absDx > absDy 
		ifTrue:[^absDx + (absDy // 2)]
		ifFalse:[^absDy + (absDx // 2)]

! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/25/1998 15:12'!
fillAllFrom: leftX to: rightX
	"Fill the span buffer from leftX to rightX with the given fill."
	| fill startX stopX |
	<inline: true>
	fill := self topFill.
	startX := leftX.
	stopX := self topRightX.
	[stopX < rightX] whileTrue:[
		fill := self makeUnsignedFrom: self topFill.
		fill = 0 ifFalse:[
			(self fillSpan: fill from: startX to: stopX) ifTrue:[^true]].
		self quickRemoveInvalidFillsAt: stopX.
		startX := stopX.
		stopX := self topRightX].
	fill := self makeUnsignedFrom: self topFill.
	fill = 0 ifFalse:[^self fillSpan: fill from: startX to: rightX].
	^false! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:20'!
fillBitmapSpan: bits from: leftX to: rightX
	"Fill the span buffer between leftEdge and rightEdge using the given bits.
	Note: We always start from zero - this avoids using huge bitmap buffers if the bitmap is to be displayed at the very far right hand side and also gives us a chance of using certain bitmaps (e.g., those with depth 32) directly."
	| x0 x1 x bitX colorMask colorShift baseShift fillValue |
	<inline: false>
	<var: #bits type: 'int *'>

	x0 := leftX.
	x1 := rightX.
	bitX := -1. "Hack for pre-increment"
	self aaLevelGet = 1 ifTrue:["Speedy version for no anti-aliasing"
		[x0 < x1] whileTrue:[
			fillValue := (self cCoerce: bits to: 'int *') at: (bitX := bitX + 1).
			spanBuffer at: x0 put: fillValue.
			x0 := x0 + 1.
		].
	] ifFalse:["Generic version with anti-aliasing"
		colorMask := self aaColorMaskGet.
		colorShift := self aaColorShiftGet.
		baseShift := self aaShiftGet.
		[x0 < x1] whileTrue:[
			x := x0 >> baseShift.
			fillValue := (self cCoerce: bits to: 'int *') at: (bitX := bitX + 1).
			fillValue := (fillValue bitAnd: colorMask) >> colorShift.
			spanBuffer at: x put: (spanBuffer at: x) + fillValue.
			x0 := x0 + 1.
		].
	].
	x1 > self spanEndGet ifTrue:[self spanEndPut: x1].
	x1 > self spanEndAAGet ifTrue:[self spanEndAAPut: x1].! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/8/1998 03:30'!
fillColorSpan: pixelValue32 from: leftX to: rightX
	"Fill the span buffer between leftEdge and rightEdge with the given pixel value."
	| x0 x1 |
	<inline: true>
	"Use a unrolled version for anti-aliased fills..."
	self aaLevelGet = 1
		ifFalse:[^self fillColorSpanAA: pixelValue32 x0: leftX x1: rightX].
	x0 := leftX.
	x1 := rightX.
	"Unroll the inner loop four times, since we're only storing data."
	[x0 + 4 < x1] whileTrue:[
		spanBuffer at: x0 put: pixelValue32.
		spanBuffer at: x0+1 put: pixelValue32.
		spanBuffer at: x0+2 put: pixelValue32.
		spanBuffer at: x0+3 put: pixelValue32.
		x0 := x0+4.
	].
	[x0 < x1] whileTrue:[
		spanBuffer at: x0 put: pixelValue32.
		x0 := x0 + 1.
	].! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/9/1998 00:52'!
fillColorSpanAA: pixelValue32 x0: leftX x1: rightX
	"This is the inner loop for solid color fills with anti-aliasing.
	This loop has been unrolled for speed and quality into three parts:
		a) copy all pixels that fall into the first full pixel.
		b) copy aaLevel pixels between the first and the last full pixel
		c) copy all pixels that fall in the last full pixel"
	| colorMask baseShift x idx firstPixel lastPixel aaLevel pv32 |
	<inline: false> "Not now -- maybe later"
	"Compute the pixel boundaries."
	firstPixel := self aaFirstPixelFrom: leftX to: rightX.
	lastPixel := self aaLastPixelFrom: leftX to: rightX.
	aaLevel := self aaLevelGet.
	baseShift := self aaShiftGet.
	x := leftX.

	"Part a: Deal with the first n sub-pixels"
	x < firstPixel ifTrue:[
		pv32 := (pixelValue32 bitAnd: self aaColorMaskGet) >> self aaColorShiftGet.
		[x < firstPixel] whileTrue:[
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + pv32.
			x := x + 1.
		].
	].

	"Part b: Deal with the full pixels"
	x < lastPixel ifTrue:[
		colorMask := (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
		pv32 := (pixelValue32 bitAnd: colorMask) >> self aaShiftGet.
		[x < lastPixel] whileTrue:[
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + pv32.
			x := x + aaLevel.
		].
	].

	"Part c: Deal with the last n sub-pixels"
	x < rightX ifTrue:[
		pv32 := (pixelValue32 bitAnd: self aaColorMaskGet) >> self aaColorShiftGet.
		[x < rightX] whileTrue:[
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + pv32.
			x := x + 1.
		].
	].! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMaxXGet
	^workBuffer at: GWFillMaxX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:29'!
fillMaxXPut: value
	^workBuffer at: GWFillMaxX put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMaxYGet
	^workBuffer at: GWFillMaxY! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillMaxYPut: value
	^workBuffer at: GWFillMaxY put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMinXGet
	^workBuffer at: GWFillMinX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillMinXPut: value
	^workBuffer at: GWFillMinX put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMinYGet
	^workBuffer at: GWFillMinY! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillMinYPut: value
	^workBuffer at: GWFillMinY put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillOffsetXGet
	^workBuffer at: GWFillOffsetX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillOffsetXPut: value
	^workBuffer at: GWFillOffsetX put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillOffsetYGet
	^workBuffer at: GWFillOffsetY! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillOffsetYPut: value
	^workBuffer at: GWFillOffsetY put: value! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar (auto pragmas 12/08) 11/24/1998 22:42'!
fillSorts: fillEntry1 before: fillEntry2
	"Return true if fillEntry1 should be drawn before fillEntry2"
	| diff |
	<inline: false>
	"First check the depth value"
	diff := (self stackFillDepth: fillEntry1) - (self stackFillDepth: fillEntry2).
	diff = 0 ifFalse:[^diff > 0].
	"See the class comment for aetScanningProblems"
	^(self cCoerce: (self makeUnsignedFrom: (self stackFillValue: fillEntry1)) to:'unsigned') <
		(self cCoerce: (self makeUnsignedFrom: (self stackFillValue: fillEntry2)) to: 'unsigned')! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ikp (auto pragmas 12/08) 8/9/2004 18:22'!
fillSpan: fill from: leftX to: rightX
	"Fill the span buffer from leftX to rightX with the given fill.
	Clip before performing any operations. Return true if the fill must
	be handled by some Smalltalk code."
	| x0 x1 type |
	<var: #fill type: 'unsigned int'>
	<inline: false>
	fill = 0 ifTrue:[^false]. "Nothing to do"
	"Start from spEnd - we must not paint pixels twice at a scan line"
	leftX < self spanEndAAGet 
		ifTrue:[x0 := self spanEndAAGet]
		ifFalse:[x0 := leftX].
	rightX > (self spanSizeGet << self aaShiftGet) 
		ifTrue:[x1 := (self spanSizeGet << self aaShiftGet)]
		ifFalse:[x1 := rightX].

	"Clip left and right values"
	x0 < self fillMinXGet ifTrue:[x0 := self fillMinXGet].
	x1 > self fillMaxXGet ifTrue:[x1 := self fillMaxXGet].

	"Adjust start and end values of span"
	x0 < self spanStartGet ifTrue:[self spanStartPut: x0].
	x1 > self spanEndGet ifTrue:[self spanEndPut: x1].
	x1 > self spanEndAAGet ifTrue:[self spanEndAAPut: x1].

	x0 >= x1 ifTrue:[^false]. "Nothing to do"

	(self isFillColor: fill) ifTrue:[
		self fillColorSpan: fill from: x0 to: x1.
	] ifFalse:[
		"Store the values for the dispatch"
		self lastExportedFillPut: fill.
		self lastExportedLeftXPut: x0.
		self lastExportedRightXPut: x1.
		type := self fillTypeOf: fill.
		type <= 1 ifTrue:[^true].
		self dispatchOn: type in: FillTable.
	].
	^false! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/7/1998 22:25'!
fillTypeOf: fill
	^((self objectTypeOf: fill) bitAnd: GEPrimitiveFillMask) >> 8! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 11/24/1998 22:47'!
findNextAETEdgeFrom: leftEdge
	| depth rightEdge |
	depth := self edgeZValueOf: leftEdge.
	[self aetStartGet < self aetUsedGet] whileTrue:[
		rightEdge := aetBuffer at: self aetStartGet.
		(self edgeZValueOf: rightEdge) >= depth ifTrue:[^rightEdge].
		self aetStartPut: self aetStartGet + 1.
	].
	^nil! !
!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 11/9/1998 15:36'!
findNextExternalEntryFromGET
	"Check the global edge table for any entries that cannot be handled by the engine itself.
	If there are any, return true. Otherwise, initialize the the edge and add it to the AET"
	| yValue edge type |
	yValue := self currentYGet.
	"As long as we have entries in the GET"
	[self getStartGet < self getUsedGet] whileTrue:[
		edge := getBuffer at: self getStartGet.
		(self edgeYValueOf: edge) > yValue ifTrue:[^false]. "No more edges to add"
		type := self objectTypeOf: edge.
		(type bitAnd: GEPrimitiveWideMask) = GEPrimitiveEdge 
			ifTrue:[^true]. "This is an external edge"
		"Note: We must make sure not to do anything with the edge if there is not
		enough room in the AET"
		(self needAvailableSpace: 1) ifFalse:[^false]. "No more room"
		"Process the edge in the engine itself"
		self dispatchOn: type in: EdgeInitTable.
		"Insert the edge into the AET"
		self insertEdgeIntoAET: edge.
		self getStartPut: self getStartGet + 1.
	].
	"No entries in GET"
	^false! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 11/25/1998 23:21'!
findNextExternalFillFromAET
	"Scan the active edge table. If there is any fill that cannot be handled by the engine itself,  return true. Otherwise handle the fills and return false."
	| leftEdge rightEdge leftX rightX |
"self currentYGet >= 680 ifTrue:[
self printAET.
self halt.
]."

	<inline: false>
	leftX := rightX := self fillMaxXGet.
	[self aetStartGet < self aetUsedGet] whileTrue:[
		leftEdge := rightEdge := aetBuffer at: self aetStartGet.
		"TODO: We should check if leftX from last operation 
			is  greater than leftX from next edge.
			Currently, we rely here on spanEndAA
			from the span buffer fill."
		leftX := rightX := self edgeXValueOf: leftEdge.
		leftX >= self fillMaxXGet ifTrue:[^false]. "Nothing more visible"
		self quickRemoveInvalidFillsAt: leftX.
		"Check if we need to draw the edge"
		(self isWide: leftEdge) ifTrue:[
			self toggleWideFillOf: leftEdge.
			"leftX := rightX := self drawWideEdge: leftEdge from: leftX."
		].
		(self areEdgeFillsValid: leftEdge) ifTrue:[
			self toggleFillsOf: leftEdge. "Adjust the fills"
			engineStopped ifTrue:[^false].
		].
		self aetStartPut: self aetStartGet + 1.
		self aetStartGet < self aetUsedGet ifTrue:[
			rightEdge := aetBuffer at: self aetStartGet.
			rightX := self edgeXValueOf: rightEdge.
			rightX >= self fillMinXGet ifTrue:["This is the visible portion"
				self fillAllFrom: leftX to: rightX.
				"Fetch the currently active fill"
				"fill := self makeUnsignedFrom: self topFill.
				fill = 0 ifFalse:[self fillSpan: fill from: leftX to: rightX max: self topRightX]"
			].
		].
	].
	"Note: Due to pre-clipping we may have to draw remaining stuff with the last fill"
	rightX < self fillMaxXGet ifTrue:[
		self fillAllFrom: rightX to: self fillMaxXGet.
		"fill := self makeUnsignedFrom: self topFill.
		fill = 0 ifFalse:[self fillSpan: fill from: rightX to: self fillMaxXGet max: self topRightX]."
	].
	^false! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:36'!
findNextExternalUpdateFromAET
	"Check the active edge table for any entries that cannot be handled by the engine itself.
	If there are any, return true. Otherwise, step the the edge to the next y value."
	| edge count type |
	<inline: false>
	[self aetStartGet < self aetUsedGet] whileTrue:[
		edge := aetBuffer at: self aetStartGet.
		count := (self edgeNumLinesOf: edge) - 1.
		count = 0 ifTrue:[
			"Edge at end -- remove it"
			self removeFirstAETEntry
		] ifFalse:[
			"Store remaining lines back"
			self edgeNumLinesOf: edge put: count.
			type := self objectTypeOf: edge.
			(type bitAnd: GEPrimitiveWideMask) = GEPrimitiveEdge 
				ifTrue:[^true]. "This is an external edge"
			self dispatchOn: type in: EdgeStepTable.
			self resortFirstAETEntry.
			self aetStartPut: self aetStartGet+1.
		].
	].
	^false! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 15:47'!
findStackFill: fillIndex depth: depth
	| index |
	index := 0.
	[index < self stackFillSize and:[
		(self stackFillValue: index) ~= fillIndex or:[
			(self stackFillDepth: index) ~= depth]]]
				whileTrue:[index := index + self stackFillEntryLength].
	index >= self stackFillSize 
		ifTrue:[^-1]
		ifFalse:[^index].
! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/31/1998 17:06'!
finishedProcessing
	"Return true if processing is finished"
	^self stateGet = GEStateCompleted! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 17:08'!
firstPointListGet
	^workBuffer at: GWPointListFirst! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 17:08'!
firstPointListPut: value
	^workBuffer at: GWPointListFirst put: value! !
!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/30/1998 19:24'!
freeStackFillEntry
	self wbStackPop: self stackFillEntryLength.! !
!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar (auto pragmas 12/08) 10/28/1998 21:07'!
getSorts: edge1 before: edge2
	"Return true if the edge at index i should sort before the edge at index j."
	| diff |
	<inline: false>
	edge1 = edge2 ifTrue:[^true].
	"First, sort by Y"
	diff := (self edgeYValueOf: edge1) - (self edgeYValueOf: edge2).
	diff = 0 ifFalse:[^diff < 0].
	"Then, by X"
	diff := (self edgeXValueOf: edge1) - (self edgeXValueOf: edge2).
	^diff < 0! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
getStartGet
	^workBuffer at: GWGETStart! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
getStartPut: value
	^workBuffer at: GWGETStart put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
getUsedGet
	^workBuffer at: GWGETUsed! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
getUsedPut: value
	^workBuffer at: GWGETUsed put: value! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/24/1998 19:39'!
hasColorTransform
	^self hasColorTransformGet ~= 0! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
hasColorTransformGet
	^workBuffer at: GWHasColorTransform! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
hasColorTransformPut: value
	^workBuffer at: GWHasColorTransform put: value! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/24/1998 19:38'!
hasEdgeTransform
	^self hasEdgeTransformGet ~= 0! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
hasEdgeTransformGet
	^workBuffer at: GWHasEdgeTransform! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:35'!
hasEdgeTransformPut: value
	^workBuffer at: GWHasEdgeTransform put: value! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar (auto pragmas 12/08) 11/25/1998 15:48'!
hideFill: fillIndex depth: depth
	"Make the fill style with the given index invisible"
	| index newTopIndex newTop newDepth newRightX |
	<inline: false>
	index := self findStackFill: fillIndex depth: depth.
	index = -1 ifTrue:[^false].

	index = 0 ifTrue:[
		self freeStackFillEntry.
		^true].

	"Fill is visible - replace it with the last entry on the stack"
	self stackFillValue: index put: (self stackFillValue: 0).
	self stackFillDepth: index put: (self stackFillDepth: 0).
	self stackFillRightX: index put: (self stackFillRightX: 0).
	self freeStackFillEntry.
	(self stackFillSize <= self stackFillEntryLength) ifTrue:[^true]. "Done"

	"Find the new top fill"
	newTopIndex := 0.
	index := self stackFillEntryLength.
	[index < self stackFillSize] whileTrue:[
		(self fillSorts: index before: newTopIndex)
			ifTrue:[newTopIndex := index].
		index := index + self stackFillEntryLength.
	].
	(newTopIndex + self stackFillEntryLength = self stackFillSize) 
		ifTrue:[^true]. "Top fill not changed"
	newTop := self stackFillValue: newTopIndex.
	self stackFillValue: newTopIndex put: self topFillValue.
	self topFillValuePut: newTop.
	newDepth := self stackFillDepth: newTopIndex.
	self stackFillDepth: newTopIndex put: self topFillDepth.
	self topFillDepthPut: newDepth.
	newRightX := self stackFillRightX: newTopIndex.
	self stackFillRightX: newTopIndex put: self topFillRightX.
	self topFillRightXPut: newRightX.
	^true! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:20'!
incrementPoint: point by: delta
	<var: #point type: 'int *'>
	point at: 0 put: (point at: 0) + delta.
	point at: 1 put: (point at: 1) + delta.! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/9/1998 15:36'!
incrementStat: statIndex by: value

	^workBuffer at: statIndex put: (workBuffer at: statIndex) + value! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 10/28/1998 21:07'!
indexForInsertingIntoAET: edge
	"Find insertion point for the given edge in the AET"
	| initialX index |
	<inline: false>
	initialX := self edgeXValueOf: edge.
	index := 0.
	[index < self aetUsedGet and:[
		(self edgeXValueOf: (aetBuffer at: index)) < initialX]]
			whileTrue:[index := index + 1].
	[index < self aetUsedGet and:[
		(self edgeXValueOf: (aetBuffer at: index)) = initialX and:[
			(self getSorts: (aetBuffer at: index) before: edge)]]]
				whileTrue:[index := index + 1].
	^index! !
!BalloonEngineBase methodsFor: 'other' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:20'!
initColorTransform
	| transform |
	<inline: false>
	<var: #transform type: 'float *'>
	transform := self colorTransform.
	transform at: 0 put: (self cCoerce: 1.0 to: 'float').
	transform at: 1 put: (self cCoerce: 0.0 to: 'float').
	transform at: 2 put: (self cCoerce: 1.0 to: 'float').
	transform at: 3 put: (self cCoerce: 0.0 to: 'float').
	transform at: 4 put: (self cCoerce: 1.0 to: 'float').
	transform at: 5 put: (self cCoerce: 0.0 to: 'float').
	transform at: 6 put: (self cCoerce: 1.0 to: 'float').
	transform at: 7 put: (self cCoerce: 0.0 to: 'float').
	self hasColorTransformPut: 0.! !
!BalloonEngineBase methodsFor: 'other' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:20'!
initEdgeTransform
	| transform |
	<inline: false>
	<var: #transform type: 'float *'>
	transform := self edgeTransform.
	transform at: 0 put: (self cCoerce: 1.0 to: 'float').
	transform at: 1 put: (self cCoerce: 0.0 to: 'float').
	transform at: 2 put: (self cCoerce: 0.0 to: 'float').
	transform at: 3 put: (self cCoerce: 0.0 to: 'float').
	transform at: 4 put: (self cCoerce: 1.0 to: 'float').
	transform at: 5 put: (self cCoerce: 0.0 to: 'float').
	self hasEdgeTransformPut: 0.! !
!BalloonEngineBase methodsFor: 'initialize-release' stamp: 'tpr (auto pragmas 12/08) 4/7/2004 21:10'!
initialiseModule
	<export: true>

	loadBBFn := interpreterProxy ioLoadFunction: 'loadBitBltFrom' From: bbPluginName.
	copyBitsFn := interpreterProxy ioLoadFunction: 'copyBitsFromtoat' From: bbPluginName.
	^(loadBBFn ~= 0 and:[copyBitsFn ~= 0])! !
!BalloonEngineBase methodsFor: 'GET processing' stamp: 'di (auto pragmas 12/08) 7/14/2004 13:09'!
initializeGETProcessing
	"Initialization stuff that needs to be done before any processing can take place."
	<inline: false>

	"Make sure aaLevel is initialized"
	self setAALevel: self aaLevelGet.

	self clipMinXGet < 0 ifTrue:[self clipMinXPut: 0].
	self clipMaxXGet > self spanSizeGet ifTrue:[self clipMaxXPut: self spanSizeGet].
	"Convert clipRect to aaLevel"
	self fillMinXPut: self clipMinXGet << self aaShiftGet.
	self fillMinYPut: self clipMinYGet << self aaShiftGet.
	self fillMaxXPut: self clipMaxXGet << self aaShiftGet.
	self fillMaxYPut: self clipMaxYGet << self aaShiftGet.

	"Reset GET and AET"
	self getUsedPut: 0.
	self aetUsedPut: 0.
	getBuffer := objBuffer + objUsed.
	aetBuffer := objBuffer + objUsed.

	"Create the global edge table"
	self createGlobalEdgeTable.
	engineStopped ifTrue:[^nil].

	self getUsedGet = 0 ifTrue:[
		"Nothing to do"
		self currentYPut: self fillMaxYGet.
		^0].

	"Sort entries in the GET"
	self sortGlobalEdgeTable.

	"Find the first y value to be processed"
	self currentYPut: (self edgeYValueOf: (getBuffer at: 0)).
	self currentYGet < self fillMinYGet ifTrue:[self currentYPut: self fillMinYGet].

	"Load and clear the span buffer"
	self spanStartPut: 0.
	self spanEndPut: (self spanSizeGet << self aaShiftGet) - 1.
	self clearSpanBuffer. "@@: Is this really necessary?!!"! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 10/28/1998 19:52'!
insertEdgeIntoAET: edge
	"Insert the edge with the given index from the global edge table into the active edge table.
	The edge has already been stepped to the initial yValue -- thus remainingLines and rasterX
	are both set."
	| index |
	<inline: false>

	"Check for the number of lines remaining"
	(self edgeNumLinesOf: edge) <= 0 ifTrue:[^nil]. "Nothing to do"

	"Find insertion point"
	index := self indexForInsertingIntoAET: edge.

	"And insert edge"
	self insertToAET: edge beforeIndex: index.! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 10/28/1998 21:07'!
insertToAET: edge beforeIndex: index
	"Insert the given edge into the AET."
	| i |
	<inline: false>
	"Make sure we have space in the AET"
	(self allocateAETEntry: 1) ifFalse:[^nil]. "Insufficient space in AET"

	i := self aetUsedGet-1.
	[i < index] whileFalse:[
		aetBuffer at: i+1 put: (aetBuffer at: i).
		i := i - 1.
	].
	aetBuffer at: index put: edge.
	self aetUsedPut: self aetUsedGet + 1.! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/29/1998 19:36'!
isEdge: edge
	| type |
	type := self objectTypeOf: edge.
	type > GEPrimitiveEdgeMask ifTrue:[^false].
	^((self objectTypeOf: edge) bitAnd: GEPrimitiveEdgeMask) ~= 0! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/7/1998 21:28'!
isFill: fill
	^(self isFillColor: fill) or:[self isRealFill: fill]! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/29/1998 19:31'!
isFillColor: fill
	^((self makeUnsignedFrom: fill) bitAnd: 16rFF000000) ~= 0! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/25/1998 00:43'!
isObject: obj
	^obj >= 0 and:[obj < objUsed]! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/7/1998 21:28'!
isRealFill: fill
	^((self objectTypeOf: fill) bitAnd: GEPrimitiveFillMask) ~= 0! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/31/1998 23:12'!
isStackEntry: entry
	^entry >= self wbTopGet and:[entry < self wbSizeGet]! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/30/1998 17:38'!
isStackIndex: index
	^index >= 0 and:[index < self wbStackSize]! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/9/1998 15:36'!
isWide: object

	^((self objectTypeOf: object) bitAnd: GEPrimitiveWide) ~= 0! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
lastExportedEdgeGet
	^workBuffer at: GWLastExportedEdge! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 20:11'!
lastExportedEdgePut: value
	^workBuffer at: GWLastExportedEdge put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 14:24'!
lastExportedFillGet
	^workBuffer at: GWLastExportedFill! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 14:24'!
lastExportedFillPut: value
	^workBuffer at: GWLastExportedFill put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedLeftXGet
	^workBuffer at: GWLastExportedLeftX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedLeftXPut: value
	^workBuffer at: GWLastExportedLeftX put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedRightXGet
	^workBuffer at: GWLastExportedRightX! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedRightXPut: value
	^workBuffer at: GWLastExportedRightX put: value! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:20'!
loadArrayTransformFrom: transformOop into: destPtr length: n
	"Load a transformation from the given array."
	| value |
	<inline: false>
	<var: #destPtr type: 'float *'>
	0 to: n-1 do:[:i|
		value := interpreterProxy fetchPointer: i ofObject: transformOop.
		((interpreterProxy isIntegerObject: value) or:[interpreterProxy isFloatObject: value])
			ifFalse:[^interpreterProxy primitiveFail].
		(interpreterProxy isIntegerObject: value)
			ifTrue:[destPtr at: i put: 
				(self cCoerce: (interpreterProxy integerValueOf: value) asFloat to:'float')]
			ifFalse:[destPtr at: i put: 
				(self cCoerce: (interpreterProxy floatValueOf: value) to: 'float')].
	].! !
!BalloonEngineBase methodsFor: 'private' stamp: 'ikp 6/14/2004 15:14'!
loadBitBltFrom: bbObj

	loadBBFn = 0 ifTrue: [
		"We need copyBits here so try to load it implicitly"
		self initialiseModule ifFalse:[^false].
	].
	^self cCode: '((sqInt (*)(sqInt))loadBBFn)(bbObj)'! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:20'!
loadColorTransformFrom: transformOop
	"Load a 2x3 transformation matrix from the given oop.
	Return true if the matrix is not nil, false otherwise"
	| okay transform |
	<var: #transform type: 'float *'>
	transform := self colorTransform.
	self hasColorTransformPut: 0.
	okay := self loadTransformFrom: transformOop into: transform length: 8.
	okay ifFalse:[^false].
	self hasColorTransformPut: 1.
	"Scale transform to be in 0-256 range"
	transform at: 1 put: (transform at: 1) * (self cCoerce: 256.0 to:'float').
	transform at: 3 put: (transform at: 3) * (self cCoerce: 256.0 to:'float').
	transform at: 5 put: (transform at: 5) * (self cCoerce: 256.0 to:'float').
	transform at: 7 put: (transform at: 7) * (self cCoerce: 256.0 to:'float').
	^okay! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/11/1998 22:21'!
loadEdgeStateFrom: edgeOop
	| edge |
	<inline: false>
	edge := self lastExportedEdgeGet.
	(interpreterProxy slotSizeOf: edgeOop) < ETBalloonEdgeDataSize 
		ifTrue:[^interpreterProxy primitiveFail].
	self edgeXValueOf: edge 
		put: (interpreterProxy fetchInteger: ETXValueIndex ofObject: edgeOop).
	self edgeYValueOf: edge 
		put: (interpreterProxy fetchInteger: ETYValueIndex ofObject: edgeOop).
	self edgeZValueOf: edge 
		put: (interpreterProxy fetchInteger: ETZValueIndex ofObject: edgeOop).
	self edgeNumLinesOf: edge 
		put: (interpreterProxy fetchInteger: ETLinesIndex ofObject: edgeOop).
	^edge! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:21'!
loadEdgeTransformFrom: transformOop
	"Load a 2x3 transformation matrix from the given oop.
	Return true if the matrix is not nil, false otherwise"
	| transform okay |
	<inline: false>
	<var: #transform type: 'float *'>
	self hasEdgeTransformPut: 0.
	transform := self edgeTransform.
	okay := self loadTransformFrom: transformOop into: transform length: 6.
	interpreterProxy failed ifTrue:[^nil].
	okay ifFalse:[^false].
	self hasEdgeTransformPut: 1.
	"Add the fill offset to the matrix"
	transform at: 2 put: 
		(self cCoerce: (transform at: 2) + self destOffsetXGet asFloat to:'float').
	transform at: 5 put: 
		(self cCoerce: (transform at: 5) + self destOffsetYGet asFloat to:'float').
	^true! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 12/5/2003 20:07'!
loadFormsFrom: arrayOop
	"Check all the forms from arrayOop."
	| formOop bmBits bmBitsSize bmWidth bmHeight bmDepth ppw bmRaster |
	(interpreterProxy isArray: arrayOop) ifFalse:[^false].
	formArray := arrayOop.
	0 to: (interpreterProxy slotSizeOf: formArray) - 1 do:[:i|
		formOop := interpreterProxy fetchPointer: i ofObject: formArray.
		(interpreterProxy isIntegerObject: formOop) ifTrue:[^false].
		(interpreterProxy isPointers: formOop) ifFalse:[^false].
		(interpreterProxy slotSizeOf: formOop) < 5 ifTrue:[^false].
		bmBits := interpreterProxy fetchPointer: 0 ofObject: formOop.
		(interpreterProxy fetchClassOf: bmBits) == interpreterProxy classBitmap
			ifFalse:[^false].
		bmBitsSize := interpreterProxy slotSizeOf: bmBits.
		bmWidth := interpreterProxy fetchInteger: 1 ofObject: formOop.
		bmHeight := interpreterProxy fetchInteger: 2 ofObject: formOop.
		bmDepth := interpreterProxy fetchInteger: 3 ofObject: formOop.
		interpreterProxy failed ifTrue:[^false].
		(bmWidth >= 0 and:[bmHeight >= 0]) ifFalse:[^false].
		ppw := 32 // bmDepth.
		bmRaster := bmWidth + (ppw-1) // ppw.
		bmBitsSize = (bmRaster * bmHeight)
			ifFalse:[^false].
	].
	^true! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:21'!
loadPoint: pointArray from: pointOop
	"Load the contents of pointOop into pointArray"
	| value |
	<inline: false>
	<var: #pointArray type: 'int *'>
	(interpreterProxy fetchClassOf: pointOop) = interpreterProxy classPoint 
		ifFalse:[^interpreterProxy primitiveFail].
	value := interpreterProxy fetchPointer: 0 ofObject: pointOop.
	((interpreterProxy isIntegerObject: value) or:[interpreterProxy isFloatObject: value])
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isIntegerObject: value)
		ifTrue:[pointArray at: 0 put: (interpreterProxy integerValueOf: value)]
		ifFalse:[pointArray at: 0 put: (interpreterProxy floatValueOf: value) asInteger].
	value := interpreterProxy fetchPointer: 1 ofObject: pointOop.
	((interpreterProxy isIntegerObject: value) or:[interpreterProxy isFloatObject: value])
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isIntegerObject: value)
		ifTrue:[pointArray at: 1 put: (interpreterProxy integerValueOf: value)]
		ifFalse:[pointArray at: 1 put: (interpreterProxy floatValueOf: value) asInteger].
! !
!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/12/2000 16:40'!
loadRenderingState
	"Load the entire state from the interpreter for the rendering primitives"
	| edgeOop fillOop state |
	<inline: false>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	fillOop := interpreterProxy stackObjectValue: 0.
	edgeOop := interpreterProxy stackObjectValue: 1.
	engine := interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^false].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^false].

	"Load span buffer and bitBlt"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^false].
	(self loadBitBltFrom: 
		(interpreterProxy fetchPointer: BEBitBltIndex ofObject: engine))
			ifFalse:[^false].
	(self loadFormsFrom:
		(interpreterProxy fetchPointer: BEFormsIndex ofObject: engine))
			ifFalse:[^false].
	"Check edgeOop and fillOop"
	(interpreterProxy slotSizeOf: edgeOop) < ETBalloonEdgeDataSize 
		ifTrue:[^false].
	(interpreterProxy slotSizeOf: fillOop) < FTBalloonFillDataSize 
		ifTrue:[^false].

	"Note: Rendering can only take place if we're not in one of the intermediate
	(e.g., external) states."
	state := self stateGet.
	(state = GEStateWaitingForEdge or:[
		state = GEStateWaitingForFill or:[
			state = GEStateWaitingChange]]) ifTrue:[^false].

	^true! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar (auto pragmas dtl 2010-09-27) 10/28/1998 00:46'!
loadSpanBufferFrom: spanOop
	"Load the span buffer from the given oop."
	<inline: false>
	(interpreterProxy fetchClassOf: spanOop) = (interpreterProxy classBitmap) ifFalse:[^false].
	spanBuffer := interpreterProxy firstIndexableField: spanOop.
	"Leave last entry unused to avoid complications"
	self spanSizePut: (interpreterProxy slotSizeOf: spanOop) - 1.
	^true! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:21'!
loadTransformFrom: transformOop into: destPtr length: n
	"Load a transformation from transformOop into the float array
	defined by destPtr. The transformation is assumed to be either
	an array or a FloatArray of length n."
	<inline: false>
	<var: #destPtr type: 'float *'>
	transformOop = interpreterProxy nilObject ifTrue:[^false].
	(interpreterProxy isIntegerObject: transformOop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: transformOop) = n 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isWords: transformOop) 
		ifTrue:[self loadWordTransformFrom: transformOop into: destPtr length: n]
		ifFalse:[self loadArrayTransformFrom: transformOop into: destPtr length: n].
	^true! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 14:21'!
loadWordTransformFrom: transformOop into: destPtr length: n
	"Load a float array transformation from the given oop"
	| srcPtr |
	<inline: false>
	<var: #srcPtr type: 'float *'>
	<var: #destPtr type: 'float *'>
	srcPtr := self cCoerce: (interpreterProxy firstIndexableField: transformOop) to: 'float *'.
	0 to: n-1 do:[:i| destPtr at: i put: (srcPtr at: i)].! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar (auto pragmas dtl 2010-09-27) 7/11/2004 13:42'!
loadWorkBufferFrom: wbOop
	"Load the working buffer from the given oop"
	<inline: false>
	(interpreterProxy isIntegerObject: wbOop) ifTrue:[^false].
	(interpreterProxy isWords: wbOop) ifFalse:[^false].
	(interpreterProxy slotSizeOf: wbOop) < GWMinimalSize ifTrue:[^false].
	self workBufferPut: wbOop.
	self magicNumberGet = GWMagicNumber ifFalse:[^false].
	"Sanity checks"
	(self wbSizeGet = (interpreterProxy slotSizeOf: wbOop)) ifFalse:[^false].
	self objStartGet = GWHeaderSize ifFalse:[^false].

	"Load buffers"
	objBuffer := workBuffer + self objStartGet.
	getBuffer := objBuffer + self objUsedGet.
	aetBuffer := getBuffer + self getUsedGet.

	"Make sure we don't exceed the work buffer"
	GWHeaderSize + self objUsedGet + self getUsedGet + self aetUsedGet > self wbSizeGet ifTrue:[^false].

	^true! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
magicNumberGet
	^workBuffer at: GWMagicIndex! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:39'!
magicNumberPut: value
	^workBuffer at: GWMagicIndex put: value! !
!BalloonEngineBase methodsFor: 'private' stamp: 'ar 10/28/1998 20:58'!
makeUnsignedFrom: someIntegerValue
	^someIntegerValue! !
!BalloonEngineBase methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/16/2000 19:57'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	<export: true>
	<var: #aModuleName type: 'char *'>
	(aModuleName strcmp: bbPluginName) = 0 ifTrue:[
		"BitBlt just shut down. How nasty."
		loadBBFn := 0.
		copyBitsFn := 0.
	].! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 10/28/1998 01:39'!
moveAETEntryFrom: index edge: edge x: xValue
	"The entry at index is not in the right position of the AET. 
	Move it to the left until the position is okay."
	| newIndex |
	<inline: false>
	newIndex := index.
	[newIndex > 0 and:[(self edgeXValueOf: (aetBuffer at: newIndex-1)) > xValue]]
		whileTrue:[	aetBuffer at: newIndex put: (aetBuffer at: newIndex-1).
					newIndex := newIndex - 1].
	aetBuffer at: newIndex put: edge.! !
!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 11/25/1998 02:19'!
needAvailableSpace: nSlots
	"Check if we have n slots available"
	GWHeaderSize + objUsed + self getUsedGet + self aetUsedGet + nSlots > self wbTopGet ifTrue:[
		self stopBecauseOf: GErrorNoMoreSpace.
		^false
	].
	^true! !
!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/25/1998 00:21'!
needsFlush
	^self needsFlushGet ~= 0! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/25/1998 00:20'!
needsFlushGet
	^workBuffer at: GWNeedsFlush! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/25/1998 00:20'!
needsFlushPut: value
	^workBuffer at: GWNeedsFlush put: value! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:22'!
obj: object at: index
	^objBuffer at: object + index! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:22'!
obj: object at: index put: value
	^objBuffer at: object + index put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
objStartGet
	^workBuffer at: GWObjStart! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:32'!
objStartPut: value
	^workBuffer at: GWObjStart put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
objUsedGet
	^workBuffer at: GWObjUsed! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:32'!
objUsedPut: value
	^workBuffer at: GWObjUsed put: value! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:02'!
objectHeaderOf: obj

	^self makeUnsignedFrom:(self obj: obj at: GEObjectType)! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectIndexOf: obj

	^self obj: obj at: GEObjectIndex! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectIndexOf: obj put: value

	^self obj: obj at: GEObjectIndex put: value! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectLengthOf: obj

	^self obj: obj at: GEObjectLength! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectLengthOf: obj put: value

	^self obj: obj at: GEObjectLength put: value! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectTypeOf: obj

	^(self makeUnsignedFrom:(self obj: obj at: GEObjectType)) bitAnd: GEPrimitiveTypeMask! !
!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectTypeOf: obj put: value

	^self obj: obj at: GEObjectType put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar (auto pragmas dtl 2010-09-27) 10/28/1998 16:33'!
point1Get
	<returnTypeC: 'int *'>
	^self cCoerce: workBuffer + GWPoint1 to:'int *'! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar (auto pragmas dtl 2010-09-27) 10/28/1998 16:34'!
point2Get
	<returnTypeC: 'int *'>
	^self cCoerce: workBuffer + GWPoint2 to:'int *'! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar (auto pragmas dtl 2010-09-27) 10/28/1998 16:34'!
point3Get
	<returnTypeC: 'int *'>
	^self cCoerce: workBuffer + GWPoint3 to:'int *'! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/1/1998 03:13'!
point4Get
	<returnTypeC: 'int *'>
	^self cCoerce: workBuffer + GWPoint4 to:'int *'! !
!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:13'!
postDisplayAction
	"We have just blitted a scan line to the screen.
	Do whatever seems to be a good idea here."
	"Note: In the future we may check the time needed for this scan line and interrupt processing to give the Smalltalk code a chance to run at a certain time."

	<inline: false>

	"Check if there is any more work to do."
	(self getStartGet >= self getUsedGet and:[self aetUsedGet = 0]) ifTrue:[
		"No more entries to process"
		self statePut: GEStateCompleted.
	].
	(self currentYGet >= self fillMaxYGet) ifTrue:[
		"Out of clipping range"
		self statePut: GEStateCompleted.
	].! !
!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:06'!
primitiveAbortProcessing
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	self statePut: GEStateCompleted.
	self storeEngineStateInto: engine.! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:58'!
primitiveAddActiveEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop edge |
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateWaitingForEdge)
		ifFalse:[^interpreterProxy primitiveFail].

	edge := self loadEdgeStateFrom: edgeOop.
	interpreterProxy failed ifTrue:[^nil].

	(self needAvailableSpace: 1) 
		ifFalse:[^interpreterProxy primitiveFail].

	(self edgeNumLinesOf: edge) > 0 ifTrue:[
		self insertEdgeIntoAET: edge.
	].

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	self statePut: GEStateAddingFromGET. "Back to adding edges from GET"
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leave rcvr on stack"
	doProfileStats ifTrue:[
		self incrementStat: GWCountAddAETEntry by: 1.
		self incrementStat: GWTimeAddAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:59'!
primitiveChangedActiveEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop edge |
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateWaitingChange)
		ifFalse:[^interpreterProxy primitiveFail].

	edge := self loadEdgeStateFrom: edgeOop.
	interpreterProxy failed ifTrue:[^nil].

	(self edgeNumLinesOf: edge) = 0 
		ifTrue:[	self removeFirstAETEntry]
		ifFalse:[	self resortFirstAETEntry.
				self aetStartPut: self aetStartGet + 1].

	self statePut: GEStateUpdateEdges. "Back to updating edges"
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leave rcvr on stack"
	doProfileStats ifTrue:[
		self incrementStat: GWCountChangeAETEntry by: 1.
		self incrementStat: GWTimeChangeAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:37'!
primitiveCopyBuffer
	| buf1 buf2 diff src dst |
	<export: true>
	<inline: false>
	<var: #src type: 'int * '>
	<var: #dst type: 'int * '>

	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].

	buf2 := interpreterProxy stackObjectValue: 0.
	buf1 := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	"Make sure the old buffer is properly initialized"
	(self loadWorkBufferFrom: buf1) 
		ifFalse:[^interpreterProxy primitiveFail].
	"Make sure the buffers are of the same type"
	(interpreterProxy fetchClassOf: buf1) = (interpreterProxy fetchClassOf: buf2)
		ifFalse:[^interpreterProxy primitiveFail].
	"Make sure buf2 is at least of the size of buf1"
	diff := (interpreterProxy slotSizeOf: buf2) - (interpreterProxy slotSizeOf: buf1).
	diff < 0 ifTrue:[^interpreterProxy primitiveFail].

	"Okay - ready for copying. First of all just copy the contents up to wbTop"
	src := workBuffer.
	dst := interpreterProxy firstIndexableField: buf2.
	0 to: self wbTopGet-1 do:[:i|
		dst at: i put: (src at: i).
	].
	"Adjust wbSize and wbTop in the new buffer"
	dst at: GWBufferTop put: self wbTopGet + diff.
	dst at: GWSize put: self wbSizeGet + diff.
	"Now copy the entries from wbTop to wbSize"
	src := src + self wbTopGet.
	dst := dst + self wbTopGet + diff.
	0 to: (self wbSizeGet - self wbTopGet - 1) do:[:i|
		dst at: i put: (src at: i).
	].
	"Okay, done. Check the new buffer by loading the state from it"
	(self loadWorkBufferFrom: buf2) 
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2. "Leave rcvr on stack"
! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:59'!
primitiveDisplaySpanBuffer
	"Note: Must load bitBlt and spanBuffer"
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateBlitBuffer)
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer and bitBlt"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	(self loadBitBltFrom: 
		(interpreterProxy fetchPointer: BEBitBltIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	(self currentYGet bitAnd: self aaScanMaskGet) = self aaScanMaskGet ifTrue:[
		self displaySpanBufferAt: self currentYGet.
		self postDisplayAction.
	].
	self finishedProcessing ifFalse:[
		self aetStartPut: 0.
		self currentYPut: self currentYGet + 1.
		self statePut: GEStateUpdateEdges].
	self storeEngineStateInto: engine.
	doProfileStats ifTrue:[
		self incrementStat: GWCountDisplaySpan by: 1.
		self incrementStat: GWTimeDisplaySpan by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar (auto pragmas 12/08) 5/11/2000 23:05'!
primitiveDoProfileStats
	"Turn on/off profiling. Return the old value of the flag."
	| oldValue newValue |
	<inline: false>
	<export: true>
	oldValue := doProfileStats.
	newValue := interpreterProxy stackObjectValue: 0.
	newValue := interpreterProxy booleanValueOf: newValue.
	interpreterProxy failed ifFalse:[
		doProfileStats := newValue.
		interpreterProxy pop: 2. "Pop rcvr, arg"
		interpreterProxy pushBool: oldValue.
	].! !
!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:59'!
primitiveFinishedProcessing
	| finished |
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	finished := self finishedProcessing.
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1.
	interpreterProxy pushBool: finished.
	doProfileStats ifTrue:[
		self incrementStat: GWCountFinishTest by: 1.
		self incrementStat: GWTimeFinishTest by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:08'!
primitiveGetAALevel
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: self aaLevelGet.! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:10'!
primitiveGetClipRect
	| rectOop pointOop |
	<export: true>
	<inline: false>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	rectOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isPointers: rectOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: rectOop) < 2
		ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy pushRemappableOop: rectOop.
	pointOop := interpreterProxy makePointwithxValue: self clipMinXGet yValue: self clipMinYGet.
	rectOop := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: rectOop withValue: pointOop.
	interpreterProxy pushRemappableOop: rectOop.
	pointOop := interpreterProxy makePointwithxValue: self clipMaxXGet yValue: self clipMaxYGet.
	rectOop := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: rectOop withValue: pointOop.

	interpreterProxy pop: 2.
	interpreterProxy push: rectOop.! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:37'!
primitiveGetCounts
	| statOop stats |
	<export: true>
	<inline: false>
	<var: #stats type: 'int *'>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	statOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: statOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: statOop) < 9
		ifTrue:[^interpreterProxy primitiveFail].
	stats := interpreterProxy firstIndexableField: statOop.
	stats at: 0 put: (stats at: 0) + (workBuffer at: GWCountInitializing).
	stats at: 1 put: (stats at: 1) + (workBuffer at: GWCountFinishTest).
	stats at: 2 put: (stats at: 2) + (workBuffer at: GWCountNextGETEntry).
	stats at: 3 put: (stats at: 3) + (workBuffer at: GWCountAddAETEntry).
	stats at: 4 put: (stats at: 4) + (workBuffer at: GWCountNextFillEntry).
	stats at: 5 put: (stats at: 5) + (workBuffer at: GWCountMergeFill).
	stats at: 6 put: (stats at: 6) + (workBuffer at: GWCountDisplaySpan).
	stats at: 7 put: (stats at: 7) + (workBuffer at: GWCountNextAETEntry).
	stats at: 8 put: (stats at: 8) + (workBuffer at: GWCountChangeAETEntry).

	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:14'!
primitiveGetDepth
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: self currentZGet.! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:10'!
primitiveGetFailureReason
	"Return the reason why the last operation failed."
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	"Note -- don't call loadEngineFrom here because this will override the stopReason with Zero"
	(interpreterProxy isIntegerObject: engine) ifTrue:[^false].
	(interpreterProxy isPointers: engine) ifFalse:[^false].
	(interpreterProxy slotSizeOf: engine) < BEBalloonEngineSize ifTrue:[^false].
	(self loadWorkBufferFrom: 
		(interpreterProxy fetchPointer: BEWorkBufferIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: self stopReasonGet.! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:11'!
primitiveGetOffset
	| pointOop |
	<export: true>
	<inline: false>

	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].

	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	pointOop := interpreterProxy makePointwithxValue: self destOffsetXGet yValue: self destOffsetYGet.
	interpreterProxy pop: 1.
	interpreterProxy push: pointOop.! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:37'!
primitiveGetTimes
	| statOop stats |
	<export: true>
	<inline: false>
	<var: #stats type: 'int *'>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	statOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: statOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: statOop) < 9
		ifTrue:[^interpreterProxy primitiveFail].
	stats := interpreterProxy firstIndexableField: statOop.
	stats at: 0 put: (stats at: 0) + (workBuffer at: GWTimeInitializing).
	stats at: 1 put: (stats at: 1) + (workBuffer at: GWTimeFinishTest).
	stats at: 2 put: (stats at: 2) + (workBuffer at: GWTimeNextGETEntry).
	stats at: 3 put: (stats at: 3) + (workBuffer at: GWTimeAddAETEntry).
	stats at: 4 put: (stats at: 4) + (workBuffer at: GWTimeNextFillEntry).
	stats at: 5 put: (stats at: 5) + (workBuffer at: GWTimeMergeFill).
	stats at: 6 put: (stats at: 6) + (workBuffer at: GWTimeDisplaySpan).
	stats at: 7 put: (stats at: 7) + (workBuffer at: GWTimeNextAETEntry).
	stats at: 8 put: (stats at: 8) + (workBuffer at: GWTimeChangeAETEntry).

	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar (auto pragmas 12/08) 7/11/2004 13:42'!
primitiveInitializeBuffer
	| wbOop size |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	wbOop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: wbOop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(size := interpreterProxy slotSizeOf: wbOop) < GWMinimalSize
		ifTrue:[^interpreterProxy primitiveFail].
	self workBufferPut: wbOop.
	objBuffer := workBuffer + GWHeaderSize.
	self magicNumberPut: GWMagicNumber.
	self wbSizePut: size.
	self wbTopPut: size.
	self statePut: GEStateUnlocked.
	self objStartPut: GWHeaderSize.
	self objUsedPut: 4.	"Dummy fill object"
	self objectTypeOf: 0 put: GEPrimitiveFill.
	self objectLengthOf: 0 put: 4.
	self objectIndexOf: 0 put: 0.
	self getStartPut: 0.
	self getUsedPut: 0.
	self aetStartPut: 0.
	self aetUsedPut: 0.
	self stopReasonPut: 0.
	self needsFlushPut: 0.
	self clipMinXPut: 0.
	self clipMaxXPut: 0.
	self clipMinYPut: 0.
	self clipMaxYPut: 0.
	self currentZPut: 0.
	self resetGraphicsEngineStats.
	self initEdgeTransform.
	self initColorTransform.
	interpreterProxy pop: 2.
	interpreterProxy push: wbOop.! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:59'!
primitiveInitializeProcessing
	"Note: No need to load bitBlt but must load spanBuffer"
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked) 
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer for clear operation"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	self initializeGETProcessing.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].
	self statePut: GEStateAddingFromGET. "Initialized"
	interpreterProxy failed ifFalse:[self storeEngineStateInto: engine].
	doProfileStats ifTrue:[
		self incrementStat: GWCountInitializing by: 1.
		self incrementStat: GWTimeInitializing by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:59'!
primitiveMergeFillFrom
	"Note: No need to load bitBlt but must load spanBuffer"
	| fillOop bitsOop value |
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	fillOop := interpreterProxy stackObjectValue: 0.
	bitsOop := interpreterProxy stackObjectValue: 1.
	engine := interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateWaitingForFill)
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer for merging the fill"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	"Check bitmap"
	(interpreterProxy fetchClassOf: bitsOop) = interpreterProxy classBitmap
		ifFalse:[^interpreterProxy primitiveFail].
	"Check fillOop"
	(interpreterProxy slotSizeOf: fillOop) < FTBalloonFillDataSize
		ifTrue:[^interpreterProxy primitiveFail].
	"Check if this was the fill we have exported"
	value := interpreterProxy fetchInteger: FTIndexIndex ofObject: fillOop.
	(self objectIndexOf: self lastExportedFillGet) = value
		ifFalse:[^interpreterProxy primitiveFail].
	value := interpreterProxy fetchInteger: FTMinXIndex ofObject: fillOop.
	self lastExportedLeftXGet = value
		ifFalse:[^interpreterProxy primitiveFail].
	value := interpreterProxy fetchInteger: FTMaxXIndex ofObject: fillOop.
	self lastExportedRightXGet = value
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy slotSizeOf: bitsOop) < (self lastExportedRightXGet - self lastExportedLeftXGet)
		ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifTrue:[^nil].

	self fillBitmapSpan: (interpreterProxy firstIndexableField: bitsOop)
		from: self lastExportedLeftXGet
		to: self lastExportedRightXGet.

	self statePut: GEStateScanningAET. "Back to scanning AET"
	self storeEngineStateInto: engine.
	interpreterProxy pop: 2. "Leave rcvr on stack"
	doProfileStats ifTrue:[
		self incrementStat: GWCountMergeFill by: 1.
		self incrementStat: GWTimeMergeFill by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:12'!
primitiveNeedsFlush
	| needFlush |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	needFlush := self needsFlush.
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1.
	interpreterProxy pushBool: needFlush.

! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:14'!
primitiveNeedsFlushPut
	| needFlush |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	needFlush := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	needFlush := interpreterProxy booleanValueOf: needFlush.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	needFlush == true 
		ifTrue:[self needsFlushPut: 1]
		ifFalse:[self needsFlushPut: 0].
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leave rcvr on stack"
! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:59'!
primitiveNextActiveEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop hasEdge edge |
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUpdateEdges or: GEStateCompleted)
		ifFalse:[^interpreterProxy primitiveFail].

	hasEdge := false.
	self stateGet = GEStateCompleted ifFalse:[
		hasEdge := self findNextExternalUpdateFromAET.
		hasEdge ifTrue:[
			edge := aetBuffer at: self aetStartGet.
			self storeEdgeStateFrom: edge into: edgeOop.
			"Do not advance to the next aet entry yet"
			"self aetStartPut: self aetStartGet + 1."
			self statePut: GEStateWaitingChange. "Wait for changed edge"
		] ifFalse:[self statePut: GEStateAddingFromGET]. "Start over"
	].
	interpreterProxy failed ifTrue:[^nil].

	self storeEngineStateInto: engine.

	interpreterProxy pop: 2.
	interpreterProxy pushBool: hasEdge not.
	doProfileStats ifTrue:[
		self incrementStat: GWCountNextAETEntry by: 1.
		self incrementStat: GWTimeNextAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 14:59'!
primitiveNextFillEntry
	"Note: No need to load bitBlt but must load spanBuffer"
	| fillOop hasFill |
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	fillOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateScanningAET)
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer for internal handling of fills"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	(self loadFormsFrom:
		(interpreterProxy fetchPointer: BEFormsIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].

	"Check if we have to clear the span buffer before proceeding"
	(self clearSpanBufferGet = 0) ifFalse:[
		(self currentYGet bitAnd: self aaScanMaskGet) = 0
			ifTrue:[self clearSpanBuffer].
		self clearSpanBufferPut: 0].

	hasFill := self findNextExternalFillFromAET.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].
	hasFill ifTrue:[self storeFillStateInto: fillOop].
	interpreterProxy failed ifFalse:[
		hasFill
			ifTrue:[	self statePut: GEStateWaitingForFill]
			ifFalse:[	self wbStackClear.
					self spanEndAAPut: 0.
					self statePut: GEStateBlitBuffer].
		self storeEngineStateInto: engine.
		interpreterProxy pop: 2.
		interpreterProxy pushBool: hasFill not.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextFillEntry by: 1.
			self incrementStat: GWTimeNextFillEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
	].! !
!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/13/2000 15:00'!
primitiveNextGlobalEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop hasEdge edge |
	<export: true>
	<inline: false>
	doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateAddingFromGET)
		ifFalse:[^interpreterProxy primitiveFail].

	hasEdge := self findNextExternalEntryFromGET.
	hasEdge ifTrue:[
		edge := getBuffer at: self getStartGet.
		self storeEdgeStateFrom: edge into: edgeOop.
		self getStartPut: self getStartGet + 1].

	interpreterProxy failed ifTrue:[^nil].

	hasEdge
		ifTrue:[	self statePut: GEStateWaitingForEdge] "Wait for adding edges"
		ifFalse:[ "Start scanning the AET"
				self statePut: GEStateScanningAET.
				self clearSpanBufferPut: 1. "Clear span buffer at next entry"
				self aetStartPut: 0.
				self wbStackClear].
	self storeEngineStateInto: engine.

	interpreterProxy pop: 2.
	interpreterProxy pushBool: hasEdge not.
	doProfileStats ifTrue:[
		self incrementStat: GWCountNextGETEntry by: 1.
		self incrementStat: GWTimeNextGETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !
!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:08'!
primitiveRegisterExternalEdge
	| rightFillIndex leftFillIndex initialZ initialY initialX index  edge |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 6 
		ifFalse:[^interpreterProxy primitiveFail].
	rightFillIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	leftFillIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	initialZ := interpreterProxy stackIntegerValue: 2.
	initialY := interpreterProxy stackIntegerValue: 3.
	initialX := interpreterProxy stackIntegerValue: 4.
	index := interpreterProxy stackIntegerValue: 5.
	engine := interpreterProxy stackObjectValue: 6.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	(self allocateObjEntry: GEBaseEdgeSize) 
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	(self isFillOkay: leftFillIndex)
		ifFalse:[^interpreterProxy primitiveFail].
	(self isFillOkay: rightFillIndex)
		ifFalse:[^interpreterProxy primitiveFail].

	edge := objUsed.
	objUsed := edge + GEBaseEdgeSize.
	"Install type and length"
	self objectTypeOf: edge put: GEPrimitiveEdge.
	self objectLengthOf: edge put: GEBaseEdgeSize.
	self objectIndexOf: edge put: index.
	"Install remaining stuff"
	self edgeXValueOf: edge put: initialX.
	self edgeYValueOf: edge put: initialY.
	self edgeZValueOf: edge put: initialZ.
	self edgeLeftFillOf: edge put: (self transformColor: leftFillIndex).
	self edgeRightFillOf: edge put: (self transformColor: rightFillIndex).
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 6. "Leave rcvr on stack"
	].! !
!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:14'!
primitiveRegisterExternalFill
	| index  fill |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 1 
		ifFalse:[^interpreterProxy primitiveFail].
	index := interpreterProxy stackIntegerValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Note: We *must* not allocate any fill with index 0"
	fill := 0.
	[fill = 0] whileTrue:[
		(self allocateObjEntry: GEBaseEdgeSize) 
			ifFalse:[^interpreterProxy primitiveFail].
		fill := objUsed.
		objUsed := fill + GEBaseFillSize.
		"Install type and length"
		self objectTypeOf: fill put: GEPrimitiveFill.
		self objectLengthOf: fill put: GEBaseFillSize.
		self objectIndexOf: fill put: index.
	].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 2.
		interpreterProxy pushInteger: fill.
	].! !
!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:08'!
primitiveRenderImage
	"Start/Proceed rendering the entire image"
	<export: true>
	<inline: false>

	self loadRenderingState ifFalse:[^interpreterProxy primitiveFail].

	self proceedRenderingScanline. "Finish this scan line"
	engineStopped ifTrue:[^self storeRenderingState].
	self proceedRenderingImage. "And go on as usual"

	self storeRenderingState.! !
!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:07'!
primitiveRenderScanline
	"Start rendering the entire image"
	<export: true>
	<inline: false>

	self loadRenderingState ifFalse:[^interpreterProxy primitiveFail].

	self proceedRenderingScanline. "Finish the current scan line"

	self storeRenderingState.! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:12'!
primitiveSetAALevel
	| level |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	level := interpreterProxy stackIntegerValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].
	self setAALevel: level.
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leace rcvr on stack"! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:38'!
primitiveSetBitBltPlugin
	"Primitive. Set the BitBlt plugin to use."
	| pluginName length ptr needReload |
	<export: true>
	<var: #ptr type: 'char *'>
	pluginName := interpreterProxy stackValue: 0.
	"Must be string to work"
	(interpreterProxy isBytes: pluginName) 
		ifFalse:[^interpreterProxy primitiveFail].
	length := interpreterProxy byteSizeOf: pluginName.
	length >= 256 
		ifTrue:[^interpreterProxy primitiveFail].
	ptr := interpreterProxy firstIndexableField: pluginName.
	needReload := false.
	0 to: length-1 do:[:i|
		"Compare and store the plugin to be used"
		(bbPluginName at: i) = (ptr at: i) ifFalse:[
			bbPluginName at: i put: (ptr at: i).
			needReload := true]].
	(bbPluginName at: length) = 0 ifFalse:[
		bbPluginName at: length put: 0.
		needReload := true].
	needReload ifTrue:[
		self initialiseModule 
			ifFalse:[^interpreterProxy primitiveFail]].
	interpreterProxy pop: 1. "Return receiver"! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:05'!
primitiveSetClipRect
	| rectOop |
	<export: true>
	<inline: false>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	rectOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isPointers: rectOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: rectOop) < 2
		ifTrue:[^interpreterProxy primitiveFail].
	self loadPoint: self point1Get from: (interpreterProxy fetchPointer: 0 ofObject: rectOop).
	self loadPoint: self point2Get from: (interpreterProxy fetchPointer: 1 ofObject: rectOop).
	interpreterProxy failed ifFalse:[
		self clipMinXPut: (self point1Get at: 0).
		self clipMinYPut: (self point1Get at: 1).
		self clipMaxXPut: (self point2Get at: 0).
		self clipMaxYPut: (self point2Get at: 1).
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:11'!
primitiveSetColorTransform
	| transformOop |
	<export: true>
	<inline: false>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	transformOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadColorTransformFrom: transformOop.
	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:06'!
primitiveSetDepth
	| depth |
	<export: true>
	<inline: false>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	depth := interpreterProxy stackIntegerValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self currentZPut: depth.

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:14'!
primitiveSetEdgeTransform
	| transformOop |
	<export: true>
	<inline: false>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	transformOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadEdgeTransformFrom: transformOop.
	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !
!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:13'!
primitiveSetOffset
	| pointOop |
	<export: true>
	<inline: false>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	pointOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy fetchClassOf: pointOop) = interpreterProxy classPoint
		ifFalse:[^interpreterProxy primitiveFail].
	self loadPoint: self point1Get from: pointOop.
	interpreterProxy failed ifFalse:[
		self destOffsetXPut: (self point1Get at: 0).
		self destOffsetYPut: (self point1Get at: 1).
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !
!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar (auto pragmas 12/08) 5/13/2000 15:00'!
proceedRenderingImage
	"This is the main rendering entry"
	| external |
	<inline: false>
	[self finishedProcessing] whileFalse:[
		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		external := self findNextExternalEntryFromGET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextGETEntry by: 1.
			self incrementStat: GWTimeNextGETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateAddingFromGET].
		external ifTrue:[
			self statePut: GEStateWaitingForEdge.
			^self stopBecauseOf: GErrorGETEntry.
		]. 
		self aetStartPut: 0.
		self wbStackClear.
		self clearSpanBufferPut: 1.

		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		(self clearSpanBufferGet ~= 0 and:[(self currentYGet bitAnd: self aaScanMaskGet) = 0])
			ifTrue:[self clearSpanBuffer].
		self clearSpanBufferPut: 0.
		external := self findNextExternalFillFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextFillEntry by: 1.
			self incrementStat: GWTimeNextFillEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateScanningAET].
		external ifTrue:[
			self statePut: GEStateWaitingForFill.
			^self stopBecauseOf: GErrorFillEntry.
		].
		self wbStackClear.
		self spanEndAAPut: 0.

		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		(self currentYGet bitAnd: self aaScanMaskGet) = self aaScanMaskGet ifTrue:[
			self displaySpanBufferAt: self currentYGet.
			self postDisplayAction.
		].
		doProfileStats ifTrue:[
			self incrementStat: GWCountDisplaySpan by: 1.
			self incrementStat: GWTimeDisplaySpan by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateBlitBuffer].
		self finishedProcessing ifTrue:[^0].
		self aetStartPut: 0.
		self currentYPut: self currentYGet + 1.

		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		external := self findNextExternalUpdateFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextAETEntry by: 1.
			self incrementStat: GWTimeNextAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateUpdateEdges].
		external ifTrue:[
			self statePut: GEStateWaitingChange.
			^self stopBecauseOf: GErrorAETEntry.
		].
	].! !
!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar (auto pragmas 12/08) 5/13/2000 15:00'!
proceedRenderingScanline
	"Proceed rendering the current scan line.
	This method may be called after some Smalltalk code has been executed inbetween."
	"This is the main rendering entry"
	| external state |
	<inline: false>
	state := self stateGet.

	state = GEStateUnlocked ifTrue:[
		self initializeGETProcessing.
		engineStopped ifTrue:[^0].
		state := GEStateAddingFromGET.
	]. 

	state = GEStateAddingFromGET ifTrue:[
		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		external := self findNextExternalEntryFromGET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextGETEntry by: 1.
			self incrementStat: GWTimeNextGETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateAddingFromGET].
		external ifTrue:[
			self statePut: GEStateWaitingForEdge.
			^self stopBecauseOf: GErrorGETEntry.
		]. 
		self aetStartPut: 0.
		self wbStackClear.
		self clearSpanBufferPut: 1.
		state := GEStateScanningAET.
	].

	state = GEStateScanningAET ifTrue:[
		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		(self clearSpanBufferGet ~= 0 and:[(self currentYGet bitAnd: self aaScanMaskGet) = 0])
			ifTrue:[self clearSpanBuffer].
		self clearSpanBufferPut: 0.
		external := self findNextExternalFillFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextFillEntry by: 1.
			self incrementStat: GWTimeNextFillEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateScanningAET].
		external ifTrue:[
			self statePut: GEStateWaitingForFill.
			^self stopBecauseOf: GErrorFillEntry.
		].
		state := GEStateBlitBuffer.
		self wbStackClear.
		self spanEndAAPut: 0.
	].

	state = GEStateBlitBuffer ifTrue:[
		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		(self currentYGet bitAnd: self aaScanMaskGet) = self aaScanMaskGet ifTrue:[
			self displaySpanBufferAt: self currentYGet.
			self postDisplayAction.
		].
		doProfileStats ifTrue:[
			self incrementStat: GWCountDisplaySpan by: 1.
			self incrementStat: GWTimeDisplaySpan by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateBlitBuffer].
		self finishedProcessing ifTrue:[^0].
		state := GEStateUpdateEdges.
		self aetStartPut: 0.
		self currentYPut: self currentYGet + 1.
	].

	state = GEStateUpdateEdges ifTrue:[
		doProfileStats ifTrue:[geProfileTime := interpreterProxy ioMicroMSecs].
		external := self findNextExternalUpdateFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextAETEntry by: 1.
			self incrementStat: GWTimeNextAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateUpdateEdges].
		external ifTrue:[
			self statePut: GEStateWaitingChange.
			^self stopBecauseOf: GErrorAETEntry.
		].
		self statePut: GEStateAddingFromGET.
	].! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/25/1998 00:36'!
quickLoadEngineFrom: engineOop
	"Load the minimal required state from the engineOop, e.g., just the work buffer."
	<inline: false>
	interpreterProxy failed ifTrue:[^false].
	(interpreterProxy isIntegerObject: engineOop) ifTrue:[^false].
	(interpreterProxy isPointers: engineOop) ifFalse:[^false].
	(interpreterProxy slotSizeOf: engineOop) < BEBalloonEngineSize ifTrue:[^false].
	engine := engineOop.
	(self loadWorkBufferFrom: 
		(interpreterProxy fetchPointer: BEWorkBufferIndex ofObject: engineOop))
			ifFalse:[^false].
	self stopReasonPut: 0.
	objUsed := self objUsedGet.
	engineStopped := false.
	^true! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar (auto pragmas dtl 2010-09-27) 10/28/1998 21:06'!
quickLoadEngineFrom: oop requiredState: requiredState
	<inline: false>
	(self quickLoadEngineFrom: oop) ifFalse:[^false].
	self stateGet = requiredState ifTrue:[^true].
	self stopReasonPut: GErrorBadState.
	^false! !
!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar (auto pragmas dtl 2010-09-27) 10/31/1998 17:23'!
quickLoadEngineFrom: oop requiredState: requiredState or: alternativeState
	<inline: false>
	(self quickLoadEngineFrom: oop) ifFalse:[^false].
	self stateGet = requiredState ifTrue:[^true].
	self stateGet = alternativeState ifTrue:[^true].
	self stopReasonPut: GErrorBadState.
	^false! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 15:16'!
quickRemoveInvalidFillsAt: leftX
	"Remove any top fills if they have become invalid."
	self stackFillSize = 0 ifTrue:[^nil].
	[self topRightX <= leftX] whileTrue:[
		self hideFill: self topFill depth: self topDepth.
		self stackFillSize = 0 ifTrue:[^nil].
	].! !
!BalloonEngineBase methodsFor: 'GET processing' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:38'!
quickSortGlobalEdgeTable: array from: i to: j 
	"Sort elements i through j of self to be nondescending according to
	sortBlock."
	"Note: The original loop has been heavily re-written for C translation"
	| di dij dj tt ij k l n tmp again before |
	<var: #array type: 'int *'>
	<inline: false>
	"The prefix d means the data at that index."
	(n := j + 1  - i) <= 1 ifTrue: [^0].	"Nothing to sort." 
	 "Sort di,dj."
	di := array at: i.
	dj := array at: j.
	before := self getSorts: di before: dj. "i.e., should di precede dj?"
	before ifFalse:[
		tmp := array at: i.
		array at: i put: (array at: j).
		array at: j put: tmp.
		tt := di.	di := dj.	dj := tt].
	n <= 2 ifTrue:[^0].

	"More than two elements."
	ij := (i + j) // 2.  "ij is the midpoint of i and j."
	dij := array at: ij.  "Sort di,dij,dj.  Make dij be their median."
	before := (self getSorts: di before: dij). "i.e. should di precede dij?"
	before ifTrue:[
		before := (self getSorts: dij before: dj). "i.e., should dij precede dj?"
		before ifFalse:["i.e., should dij precede dj?"
			tmp := array at: j.
			array at: j put: (array at: ij).
			array at: ij put: tmp.
			dij := dj]
	] ifFalse:[  "i.e. di should come after dij"
		tmp := array at: i.
		array at: i put: (array at: ij).
		array at: ij put: tmp.
		 dij := di].
	n <= 3 ifTrue:[^0].

	 "More than three elements."
	"Find k>i and l<j such that dk,dij,dl are in reverse order.
	Swap k and l.  Repeat this procedure until k and l pass each other."
	k := i.
	l := j.

	again := true.
	[again] whileTrue:[
		before := true.
		[before] whileTrue:[
			k <= (l := l - 1)
				ifTrue:[	tmp := array at: l.
						before := self getSorts: dij before: tmp]
				ifFalse:[before := false].
		].
		before := true.
		[before] whileTrue:[
			(k := k + 1) <= l
				ifTrue:[	tmp := array at: k.
						before := self getSorts: tmp before: dij]
				ifFalse:[before := false]].

		again := k <= l.
		again ifTrue:[
			tmp := array at: k.
			array at: k put: (array at: l).
			array at: l put: tmp]].

	"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments."
	self quickSortGlobalEdgeTable: array from: i to: l.
	self quickSortGlobalEdgeTable: array from: k to: j.! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 10/28/1998 21:07'!
removeFirstAETEntry
	| index |
	<inline: false>
	index := self aetStartGet.
	self aetUsedPut: self aetUsedGet - 1.
	[index < self aetUsedGet] whileTrue:[
		aetBuffer at: index put: (aetBuffer at: index + 1).
		index := index + 1.
	].! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar (auto pragmas 12/08) 11/7/1998 14:26'!
resetGraphicsEngineStats
	<inline: false>
	workBuffer at: GWTimeInitializing put: 0.
	workBuffer at: GWTimeFinishTest put: 0.
	workBuffer at: GWTimeNextGETEntry put: 0.
	workBuffer at: GWTimeAddAETEntry put: 0.
	workBuffer at: GWTimeNextFillEntry put: 0.
	workBuffer at: GWTimeMergeFill put: 0.
	workBuffer at: GWTimeDisplaySpan put: 0.
	workBuffer at: GWTimeNextAETEntry put: 0.
	workBuffer at: GWTimeChangeAETEntry put: 0.

	workBuffer at: GWCountInitializing put: 0.
	workBuffer at: GWCountFinishTest put: 0.
	workBuffer at: GWCountNextGETEntry put: 0.
	workBuffer at: GWCountAddAETEntry put: 0.
	workBuffer at: GWCountNextFillEntry put: 0.
	workBuffer at: GWCountMergeFill put: 0.
	workBuffer at: GWCountDisplaySpan put: 0.
	workBuffer at: GWCountNextAETEntry put: 0.
	workBuffer at: GWCountChangeAETEntry put: 0.

	workBuffer at: GWBezierMonotonSubdivisions put: 0.
	workBuffer at: GWBezierHeightSubdivisions put: 0.
	workBuffer at: GWBezierOverflowSubdivisions put: 0.
	workBuffer at: GWBezierLineConversions put: 0.
! !
!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar (auto pragmas 12/08) 10/28/1998 21:07'!
resortFirstAETEntry
	| edge xValue leftEdge |
	<inline: false>
	self aetStartGet = 0 ifTrue:[^nil]. "Nothing to resort"
	edge := aetBuffer at: self aetStartGet.
	xValue := self edgeXValueOf: edge.
	leftEdge := aetBuffer at: (self aetStartGet - 1).
	(self edgeXValueOf: leftEdge) <= xValue ifTrue:[^nil]. "Okay"
	self moveAETEntryFrom: self aetStartGet edge: edge x: xValue.! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar (auto pragmas 12/08) 11/7/1998 14:26'!
setAALevel: level
	"Set the anti-aliasing level. Three levels are supported:
		1 - No antialiasing
		2 - 2x2 unweighted anti-aliasing
		4 - 4x4 unweighted anti-aliasing.
	"
	| aaLevel |
	<inline: false>
	level >= 4 ifTrue:[aaLevel := 4].
	(level >= 2) & (level < 4) ifTrue:[aaLevel := 2].
	level < 2 ifTrue:[aaLevel := 1].
	self aaLevelPut: aaLevel.
	aaLevel = 1 ifTrue:[
		self aaShiftPut: 0.
		self aaColorMaskPut: 16rFFFFFFFF.
		self aaScanMaskPut: 0.
	].
	aaLevel = 2 ifTrue:[
		self aaShiftPut: 1.
		self aaColorMaskPut: 16rFCFCFCFC.
		self aaScanMaskPut: 1.
	].
	aaLevel = 4 ifTrue:[
		self aaShiftPut: 2.
		self aaColorMaskPut: 16rF0F0F0F0.
		self aaScanMaskPut: 3.
	].
	self aaColorShiftPut: self aaShiftGet * 2.
	self aaHalfPixelPut: self aaShiftGet.
! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar (auto pragmas 12/08) 11/25/1998 14:38'!
showFill: fillIndex depth: depth rightX: rightX
	<inline: false>
	(self allocateStackFillEntry) ifFalse:[^nil]. "Insufficient space"
	self stackFillValue: 0 put: fillIndex.
	self stackFillDepth: 0 put: depth.
	self stackFillRightX: 0 put: rightX.
	self stackFillSize = self stackFillEntryLength ifTrue:[^nil]. "No need to update"

	(self fillSorts: 0 before: self stackFillSize - self stackFillEntryLength) ifTrue:[
		"New top fill"
		self stackFillValue: 0 put: self topFillValue.
		self stackFillDepth: 0 put: self topFillDepth.
		self stackFillRightX: 0 put: self topFillRightX.
		self topFillValuePut: fillIndex.
		self topFillDepthPut: depth.
		self topFillRightXPut: rightX.
	].! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/8/1998 15:25'!
smallSqrtTable
	| theTable |
	<inline: false>
	<returnTypeC: 'int *'>
	<var: #theTable declareC: 'static int theTable[32] = 
	{0, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6}'>
	^theTable! !
!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 10/27/1998 23:34'!
sortGlobalEdgeTable
	"Sort the entire global edge table"
	self quickSortGlobalEdgeTable: getBuffer from: 0 to: self getUsedGet-1.! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanEndAAGet
	^workBuffer at: GWSpanEndAA! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanEndAAPut: value
	^workBuffer at: GWSpanEndAA put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanEndGet
	^workBuffer at: GWSpanEnd! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanEndPut: value
	^workBuffer at: GWSpanEnd put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanSizeGet
	^workBuffer at: GWSpanSize! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanSizePut: value
	^workBuffer at: GWSpanSize put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanStartGet
	^workBuffer at: GWSpanStart! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanStartPut: value
	^workBuffer at: GWSpanStart put: value! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/8/1998 20:57'!
squaredLengthOf: deltaX with: deltaY
	^(deltaX * deltaX) + (deltaY * deltaY)! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:08'!
stackFillDepth: index
	^self wbStackValue: index+1! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:08'!
stackFillDepth: index put: value
	^self wbStackValue: index+1 put: value! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:31'!
stackFillEntryLength
	^3! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:35'!
stackFillRightX: index
	^self wbStackValue: index+2! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:35'!
stackFillRightX: index put: value
	^self wbStackValue: index+2 put: value! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:10'!
stackFillSize
	^self wbStackSize! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:09'!
stackFillValue: index
	^self wbStackValue: index! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:09'!
stackFillValue: index put: value
	^self wbStackValue: index put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
stateGet
	^workBuffer at: GWState! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
statePut: value
	^workBuffer at: GWState put: value! !
!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/25/1998 02:22'!
stopBecauseOf: stopReason
	self stopReasonPut: stopReason.
	engineStopped := true.! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
stopReasonGet
	^workBuffer at: GWStopReason! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
stopReasonPut: value
	^workBuffer at: GWStopReason put: value! !
!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar (auto pragmas 12/08) 11/11/1998 22:21'!
storeEdgeStateFrom: edge into: edgeOop

	<inline: false>
	(interpreterProxy slotSizeOf: edgeOop) < ETBalloonEdgeDataSize 
		ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy storeInteger: ETIndexIndex ofObject: edgeOop withValue: 
		(self objectIndexOf: edge).
	interpreterProxy storeInteger: ETXValueIndex ofObject: edgeOop withValue: 
		(self edgeXValueOf: edge).
	interpreterProxy storeInteger: ETYValueIndex ofObject: edgeOop withValue: 
		(self currentYGet).
	interpreterProxy storeInteger: ETZValueIndex ofObject: edgeOop withValue: 
		(self edgeZValueOf: edge).
	interpreterProxy storeInteger: ETLinesIndex ofObject: edgeOop withValue: 
		(self edgeNumLinesOf: edge).
	self lastExportedEdgePut: edge.! !
!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar 11/25/1998 00:36'!
storeEngineStateInto: oop
	self objUsedPut: objUsed.! !
!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar (auto pragmas 12/08) 11/11/1998 22:24'!
storeFillStateInto: fillOop
	| fillIndex leftX rightX |
	<inline: false>
	fillIndex := self lastExportedFillGet.
	leftX := self lastExportedLeftXGet.
	rightX := self lastExportedRightXGet.

	(interpreterProxy slotSizeOf: fillOop) < FTBalloonFillDataSize 
		ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy storeInteger: FTIndexIndex ofObject: fillOop withValue: 
		(self objectIndexOf: fillIndex).
	interpreterProxy storeInteger: FTMinXIndex ofObject: fillOop withValue: leftX.
	interpreterProxy storeInteger: FTMaxXIndex ofObject: fillOop withValue: rightX.
	interpreterProxy storeInteger: FTYValueIndex ofObject: fillOop withValue: self currentYGet.! !
!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar (auto pragmas 12/08) 10/31/1998 23:54'!
storeRenderingState
	<inline: false>
	interpreterProxy failed ifTrue:[^nil].
	engineStopped ifTrue:[
		"Check the stop reason and store the required information"
		self storeStopStateIntoEdge: (interpreterProxy stackObjectValue: 1) 
			fill: (interpreterProxy stackObjectValue: 0).
	].
	self storeEngineStateInto: engine.
	interpreterProxy pop: 3.
	interpreterProxy pushInteger: self stopReasonGet.! !
!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar 11/9/1998 15:34'!
storeStopStateIntoEdge: edgeOop fill: fillOop
	| reason edge |
	reason := self stopReasonGet.

	reason = GErrorGETEntry ifTrue:[
		edge := getBuffer at: self getStartGet.
		self storeEdgeStateFrom: edge into: edgeOop.
		self getStartPut: self getStartGet + 1.
	].

	reason = GErrorFillEntry ifTrue:[
		self storeFillStateInto: fillOop.
	].

	reason = GErrorAETEntry ifTrue:[
		edge := aetBuffer at: self aetStartGet.
		self storeEdgeStateFrom: edge into: edgeOop.
		"Do not advance to the next aet entry yet"
		"self aetStartPut: self aetStartGet + 1."
	].! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar (auto pragmas 12/08) 11/25/1998 14:38'!
toggleFill: fillIndex depth: depth rightX: rightX
	"Make the fill style with the given index either visible or invisible"
	| hidden |
	<inline: false>

	self stackFillSize = 0 ifTrue:[
		(self allocateStackFillEntry) ifTrue:[
			self topFillValuePut: fillIndex.
			self topFillDepthPut: depth.
			self topFillRightXPut: rightX.
		].
	] ifFalse:[
		hidden := self hideFill: fillIndex depth: depth.
		hidden ifFalse:[self showFill: fillIndex depth: depth rightX: rightX].
	].! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar (auto pragmas 12/08) 11/25/1998 15:19'!
toggleFillsOf: edge
	| depth fillIndex |
	<inline: false>

	(self needAvailableSpace: self stackFillEntryLength * 2) 
		ifFalse:[^nil]. "Make sure we have enough space left"
	depth := (self edgeZValueOf: edge) << 1.
	fillIndex := self edgeLeftFillOf: edge.
	fillIndex = 0 ifFalse:[self toggleFill: fillIndex depth: depth rightX: 999999999].
	fillIndex := self edgeRightFillOf: edge.
	fillIndex = 0 ifFalse:[self toggleFill: fillIndex depth: depth rightX: 999999999].
	self quickRemoveInvalidFillsAt: (self edgeXValueOf: edge).! !
!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar (auto pragmas 12/08) 11/25/1998 15:50'!
toggleWideFillOf: edge
	| fill type lineWidth depth rightX index |
	<inline: false>
	type := self edgeTypeOf: edge.
	dispatchedValue := edge.
	self dispatchOn: type in: WideLineWidthTable.
	lineWidth := dispatchReturnValue.
	self dispatchOn: type in: WideLineFillTable.
	fill := dispatchReturnValue.
	fill = 0 ifTrue:[^nil].
	(self needAvailableSpace: self stackFillEntryLength) 
		ifFalse:[^nil]. "Make sure we have enough space left"
	depth := (self edgeZValueOf: edge) << 1 + 1. "So lines sort before interior fills"
	rightX := (self edgeXValueOf: edge) + lineWidth.
	index := self findStackFill: fill depth: depth.
	index = -1 ifTrue:[
		self showFill: fill 
			depth: depth
			rightX: rightX.
	] ifFalse:[
		(self stackFillRightX: index) < rightX
			ifTrue:[self stackFillRightX: index put: rightX].
	].
	self quickRemoveInvalidFillsAt: (self edgeXValueOf: edge).! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:49'!
topDepth
	self stackFillSize = 0
		ifTrue:[^-1]
		ifFalse:[^self topFillDepth].! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:28'!
topFill
	self stackFillSize = 0
		ifTrue:[^0]
		ifFalse:[^self topFillValue].! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillDepth
	^self stackFillDepth: self stackFillSize - self stackFillEntryLength! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillDepthPut: value
	^self stackFillDepth: self stackFillSize - self stackFillEntryLength put: value! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:36'!
topFillRightX
	^self stackFillRightX: self stackFillSize - self stackFillEntryLength! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:36'!
topFillRightXPut: value
	^self stackFillRightX: self stackFillSize - self stackFillEntryLength put: value! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillValue
	^self stackFillValue: self stackFillSize - self stackFillEntryLength! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillValuePut: value
	^self stackFillValue: self stackFillSize - self stackFillEntryLength put: value! !
!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 15:19'!
topRightX
	self stackFillSize = 0
		ifTrue:[^999999999]
		ifFalse:[^self topFillRightX].! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:42'!
transformColor: fillIndex
	| r g b a transform alphaScale |
	<var: #transform type: 'float *'>
	<var: #alphaScale type: 'double '>
	(fillIndex = 0 or:[self isFillColor: fillIndex]) ifFalse:[^fillIndex].
	b := fillIndex bitAnd: 255.
	g := (fillIndex >> 8) bitAnd: 255.
	r := (fillIndex >> 16) bitAnd: 255.
	a := (fillIndex >> 24) bitAnd: 255.
	(self hasColorTransform) ifTrue:[
		transform := self colorTransform.
		alphaScale := (a * (transform at: 6) + (transform at: 7)) / a.
		r := (r * (transform at: 0) + (transform at: 1) * alphaScale) asInteger.
		g := (g * (transform at: 2) + (transform at: 3) * alphaScale) asInteger.
		b := (b * (transform at: 4) + (transform at: 5) * alphaScale) asInteger.
		a := a * alphaScale.
		r := r max: 0. r := r min: 255.
		g := g max: 0. g := g min: 255.
		b := b max: 0. b := b min: 255.
		a := a max: 0. a := a min: 255.
	].
	a < 1 ifTrue:[^0]."ALWAYS return zero for transparent fills"
	"If alpha is not 255 (or close thereto) then we need to flush the engine before proceeding"
	(a < 255 and:[self needsFlush]) 
		ifTrue:[self stopBecauseOf: GErrorNeedFlush].
	^b + (g << 8) + (r << 16) + (a << 24)! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:43'!
transformPoint: point
	"Transform the given point. If haveMatrix is true then use the current transformation."
	<var: #point type: 'int *'>
	self hasEdgeTransform ifFalse:[
		"Multiply each component by aaLevel and add a half pixel"
		point at: 0 put: (point at: 0) + self destOffsetXGet * self aaLevelGet.
		point at: 1 put: (point at: 1) + self destOffsetYGet * self aaLevelGet.
	] ifTrue:[
		"Note: AA adjustment is done in #transformPoint: for higher accuracy"
		self transformPoint: point into: point.
	].! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar (auto pragmas 12/08) 11/1/1998 16:59'!
transformPoint: srcPoint into: dstPoint
	"Transform srcPoint into dstPoint by using the currently loaded matrix"
	"Note: This method has been rewritten so that inlining works (e.g., removing
	the declarations and adding argument coercions at the appropriate points)"
	<inline: true>
	self transformPointX: ((self cCoerce: srcPoint to: 'int *') at: 0) asFloat 
		y: ((self cCoerce: srcPoint to:'int *') at: 1) asFloat
		into: (self cCoerce: dstPoint to: 'int *')! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 17:23'!
transformPointX: xValue y: yValue into: dstPoint
	"Transform srcPoint into dstPoint by using the currently loaded matrix"
	"Note: This should be rewritten so that inlining works (e.g., removing
	the declarations and adding argument coercions at the appropriate points)"
	| x y transform |
	<inline: true>
	<var: #dstPoint type: 'int *'>
	<var: #xValue type: 'double '>
	<var: #yValue type: 'double '>
	<var: #transform type: 'float *'>
	transform := self edgeTransform.
	x := ((((transform at: 0) * xValue) +
		((transform at: 1) * yValue) +
		(transform at: 2)) * self aaLevelGet asFloat) asInteger.
	y := ((((transform at: 3) * xValue) +
		((transform at: 4) * yValue) +
		(transform at: 5)) * self aaLevelGet asFloat) asInteger.
	dstPoint at: 0 put: x.
	dstPoint at: 1 put: y.! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar (auto pragmas 12/08) 11/24/1998 19:48'!
transformPoints: n
	"Transform n (n=1,2,3) points.
	If haveMatrix is true then the matrix contains the actual transformation."
	<inline: true>
	n > 0 ifTrue:[self transformPoint: self point1Get].
	n > 1 ifTrue:[self transformPoint: self point2Get].
	n > 2 ifTrue:[self transformPoint: self point3Get].
	n > 3 ifTrue:[self transformPoint: self point4Get].! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:43'!
transformWidth: w
	"Transform the given width"
	| deltaX deltaY dstWidth dstWidth2 |
	<inline: false>
	<var: #deltaX type: 'double '>
	<var: #deltaY type: 'double '>
	w = 0 ifTrue:[^0].
	self point1Get at: 0 put: 0.
	self point1Get at: 1 put: 0.
	self point2Get at: 0 put: w * 256.
	self point2Get at: 1 put: 0.
	self point3Get at: 0 put: 0.
	self point3Get at: 1 put: w * 256.
	self transformPoints: 3.
	deltaX := ((self point2Get at: 0) - (self point1Get at: 0)) asFloat.
	deltaY := ((self point2Get at: 1) - (self point1Get at: 1)) asFloat.
	dstWidth := (((deltaX * deltaX) + (deltaY * deltaY)) sqrt asInteger + 128) // 256.
	deltaX := ((self point3Get at: 0) - (self point1Get at: 0)) asFloat.
	deltaY := ((self point3Get at: 1) - (self point1Get at: 1)) asFloat.
	dstWidth2 := (((deltaX * deltaX) + (deltaY * deltaY)) sqrt asInteger + 128) // 256.
	dstWidth2 < dstWidth ifTrue:[dstWidth := dstWidth2].
	dstWidth = 0
		ifTrue:[^1]
		ifFalse:[^dstWidth]! !
!BalloonEngineBase methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:43'!
uncheckedTransformColor: fillIndex
	| r g b a transform |
	<var: #transform type: 'float *'>
	(self hasColorTransform) ifFalse:[^fillIndex].
	b := fillIndex bitAnd: 255.
	g := (fillIndex >> 8) bitAnd: 255.
	r := (fillIndex >> 16) bitAnd: 255.
	a := (fillIndex >> 24) bitAnd: 255.
	transform := self colorTransform.
	r := (r * (transform at: 0) + (transform at: 1)) asInteger.
	g := (g * (transform at: 2) + (transform at: 3)) asInteger.
	b := (b * (transform at: 4) + (transform at: 5)) asInteger.
	a := (a * (transform at: 6) + (transform at: 7)) asInteger.
	r := r max: 0. r := r min: 255.
	g := g max: 0. g := g min: 255.
	b := b max: 0. b := b min: 255.
	a := a max: 0. a := a min: 255.
	a < 16 ifTrue:[^0]."ALWAYS return zero for transparent fills"
	^b + (g << 8) + (r << 16) + (a << 24)! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
wbSizeGet
	^workBuffer at: GWSize! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:37'!
wbSizePut: value
	^workBuffer at: GWSize put: value! !
!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 10/31/1998 00:43'!
wbStackClear
	self wbTopPut: self wbSizeGet.! !
!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 11/9/1998 15:34'!
wbStackPop: nItems

	self wbTopPut: self wbTopGet + nItems.! !
!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 10/30/1998 17:16'!
wbStackPush: nItems
	(self allocateStackEntry: nItems) ifFalse:[^false].
	self wbTopPut: self wbTopGet - nItems.
	^true! !
!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 10/30/1998 17:17'!
wbStackSize
	^self wbSizeGet - self wbTopGet! !
!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 11/9/1998 15:34'!
wbStackValue: index

	^workBuffer at: self wbTopGet + index! !
!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 11/9/1998 15:34'!
wbStackValue: index put: value

	^workBuffer at: self wbTopGet + index put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:29'!
wbTopGet
	^workBuffer at: GWBufferTop! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:32'!
wbTopPut: value
	^workBuffer at: GWBufferTop put: value! !
!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 7/11/2004 13:43'!
workBufferPut: wbOop
	workBuffer := interpreterProxy firstIndexableField: wbOop.! !

BalloonEngineBase subclass: #BalloonEnginePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!BalloonEnginePlugin commentStamp: 'tpr 5/5/2003 11:46' prior: 0!
This class adds the plugin functionality for the Balloon graphics engine.
BalloonEnginePlugin should be translated but its superclass should not since it is incorporated within this class's translation process. Nor should the simulation subclass be translated!
!BalloonEnginePlugin class methodsFor: 'class initialization' stamp: 'ar 11/11/1998 22:01'!
declareCVarsIn: cg
	"Nothing to declare"! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar (auto pragmas 12/08) 10/30/1998 20:02'!
absoluteSquared8Dot24: value
	"Compute the squared value of a 8.24 number with 0.0 <= value < 1.0,
	e.g., compute (value * value) bitShift: -24"
	| word1 word2 |
	<inline: true>
	word1 := value bitAnd: 16rFFFF.
	word2 := (value bitShift: -16) bitAnd: 255.
	^(( (self cCoerce: (word1 * word1) to:'unsigned') bitShift: -16) +
		((word1 * word2) * 2) +
			((word2 * word2) bitShift: 16)) bitShift: -8! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:18'!
adjustWideBezierLeft: bezier width: lineWidth offset: lineOffset endX: endX
	"Adjust the wide bezier curve (dx < 0) to start/end at the right point"
	| lastX lastY |
	<inline: false>
	(self bezierUpdateDataOf: bezier) at: GBUpdateX put: 
		(((self bezierUpdateDataOf: bezier) at: GBUpdateX) - (lineOffset * 256)).
	"Set the lastX/Y value of the second curve lineWidth pixels right/down"
	lastX := (self wideBezierUpdateDataOf: bezier) at: GBUpdateX.
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateX put: lastX + (lineWidth - lineOffset * 256).
	"Set lineWidth pixels down"
	lastY := (self wideBezierUpdateDataOf: bezier) at: GBUpdateY.
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateY put: lastY + (lineWidth * 256).
	"Record the last X value"
	self bezierFinalXOf: bezier put: endX - lineOffset.
! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:18'!
adjustWideBezierRight: bezier width: lineWidth offset: lineOffset endX: endX
	"Adjust the wide bezier curve (dx >= 0) to start/end at the right point"
	| lastX lastY |
	<inline: false>
	(self bezierUpdateDataOf: bezier) at: GBUpdateX put: 
		(((self bezierUpdateDataOf: bezier) at: GBUpdateX) + (lineOffset * 256)).
	"Set the lastX/Y value of the second curve lineWidth pixels right/down"
	"Set lineWidth-lineOffset pixels left"
	lastX := (self wideBezierUpdateDataOf: bezier) at: GBUpdateX.
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateX put: lastX - (lineWidth - lineOffset * 256).
	lastY := (self wideBezierUpdateDataOf: bezier) at: GBUpdateY.
	"Set lineWidth pixels down"
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateY put: lastY + (lineWidth * 256).
	"Record the last X value"
	self bezierFinalXOf: bezier put: endX - lineOffset + lineWidth.! !
!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:34'!
adjustWideLine: line afterSteppingFrom: lastX to: nextX
	"Adjust the wide line after it has been stepped from lastX to nextX.
	Special adjustments of line width and start position are made here
	to simulate a rectangular brush"
	|  yEntry yExit lineWidth lineOffset deltaX xDir baseWidth |
	<inline: false>	"Don't inline this"


	"Fetch the values the adjustment decisions are based on"
	yEntry := (self wideLineEntryOf: line).
	yExit := (self wideLineExitOf: line).
	baseWidth := self wideLineExtentOf: line.
	lineOffset := self offsetFromWidth: baseWidth.
	lineWidth := self wideLineWidthOf: line.
	xDir := self lineXDirectionOf: line.
	deltaX := nextX - lastX.

	"Adjust the start of the line to fill an entire rectangle"
	yEntry < baseWidth ifTrue:[
		xDir < 0
			ifTrue:[	lineWidth := lineWidth - deltaX] "effectively adding"
			ifFalse:[	lineWidth := lineWidth + deltaX.
					self edgeXValueOf: line put: lastX].
	].

	"Adjust the end of x-major lines"
	((yExit + lineOffset) = 0) ifTrue:[
		xDir > 0
			ifTrue:[lineWidth := lineWidth - (self lineXIncrementOf: line)]
			ifFalse:[lineWidth := lineWidth + (self lineXIncrementOf: line).	"effectively subtracting"
					self edgeXValueOf: line put: lastX].
	].

	"Adjust the end of the line to fill an entire rectangle"
	(yExit + lineOffset) > 0 ifTrue:[
		xDir < 0
			ifTrue:[	lineWidth := lineWidth + deltaX. "effectively subtracting"
					self edgeXValueOf: line put: lastX]
			ifFalse:[	lineWidth := lineWidth - deltaX]
	].

	"Store the manipulated line width back"
	self wideLineWidthOf: line put: lineWidth.! !
!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:38'!
allocateBezier
	| bezier |
	(self allocateObjEntry: GBBaseSize) ifFalse:[^0].
	bezier := objUsed.
	objUsed := bezier + GBBaseSize.
	self objectTypeOf: bezier put: GEPrimitiveBezier.
	self objectIndexOf: bezier put: 0.
	self objectLengthOf: bezier put: GBBaseSize.
	^bezier! !
!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 10/30/1998 20:52'!
allocateBezierStackEntry
	self wbStackPush: 6.
	^self wbStackSize! !
!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:44'!
allocateBitmapFill: cmSize colormap: cmBits
	| fill fillSize cm |
	<var: #cm type: 'int *'>
	<var: #cmBits type: 'int *'>
	fillSize := GBMBaseSize + cmSize.
	(self allocateObjEntry: fillSize) ifFalse:[^0].
	fill := objUsed.
	objUsed := fill + fillSize.
	self objectTypeOf: fill put: GEPrimitiveClippedBitmapFill.
	self objectIndexOf: fill put: 0.
	self objectLengthOf: fill put: fillSize.
	cm := self colormapOf: fill.
	self hasColorTransform ifTrue:[
		0 to: cmSize-1 do:[:i| cm at: i put: (self transformColor: (cmBits at: i))].
	] ifFalse:[
		0 to: cmSize-1 do:[:i| cm at: i put: (cmBits at: i)].
	].
	self bitmapCmSizeOf: fill put: cmSize.
	^fill! !
!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:44'!
allocateGradientFill: ramp rampWidth: rampWidth isRadial: isRadial
	| fill fillSize rampPtr |
	<var: #ramp type: 'int *'>
	<var: #rampPtr type: 'int *'>
	fillSize := GGBaseSize + rampWidth.
	(self allocateObjEntry: fillSize) ifFalse:[^0].
	fill := objUsed.
	objUsed := fill + fillSize.
	isRadial
		ifTrue:[self objectTypeOf: fill put: GEPrimitiveRadialGradientFill]
		ifFalse:[self objectTypeOf: fill put: GEPrimitiveLinearGradientFill].
	self objectIndexOf: fill put: 0.
	self objectLengthOf: fill put: fillSize.
	rampPtr := self gradientRampOf: fill.
	self hasColorTransform ifTrue:[
		0 to: rampWidth-1 do:[:i| rampPtr at: i put: (self transformColor: (ramp at: i))].
	] ifFalse:[
		0 to: rampWidth-1 do:[:i| rampPtr at: i put: (ramp at: i)].
	].
	self gradientRampLengthOf: fill put: rampWidth.
	^fill! !
!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:39'!
allocateLine
	| line |
	(self allocateObjEntry: GLBaseSize) ifFalse:[^0].
	line := objUsed.
	objUsed := line + GLBaseSize.
	self objectTypeOf: line put: GEPrimitiveLine.
	self objectIndexOf: line put: 0.
	self objectLengthOf: line put: GLBaseSize.
	^line! !
!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:39'!
allocateWideBezier
	| bezier |
	(self allocateObjEntry: GBWideSize) ifFalse:[^0].
	bezier := objUsed.
	objUsed := bezier + GBWideSize.
	self objectTypeOf: bezier put: GEPrimitiveWideBezier.
	self objectIndexOf: bezier put: 0.
	self objectLengthOf: bezier put: GBWideSize.
	^bezier! !
!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:39'!
allocateWideLine
	| line |
	(self allocateObjEntry: GLWideSize) ifFalse:[^0].
	line := objUsed.
	objUsed := line + GLWideSize.
	self objectTypeOf: line put: GEPrimitiveWideLine.
	self objectIndexOf: line put: 0.
	self objectLengthOf: line put: GLWideSize.
	^line! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/9/1998 01:56'!
assureValue: val1 between: val2 and: val3
	"Make sure that val1 is between val2 and val3."
	<inline: true>
	val2 > val3 ifTrue:[
		val1 > val2 ifTrue:[^val2].
		val1 < val3 ifTrue:[^val3].
	] ifFalse:[
		val1 < val2 ifTrue:[^val2].
		val1 > val3 ifTrue:[^val3].
	].
	^val1	! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
bezierEndXOf: bezier

	^self obj: bezier at: GBEndX! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierEndXOf: bezier put: value

	^self obj: bezier at: GBEndX put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierEndYOf: bezier

	^self obj: bezier at: GBEndY! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
bezierEndYOf: bezier put: value

	^self obj: bezier at: GBEndY put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:19'!
bezierFinalXOf: bezier

	^self obj: bezier at: GBFinalX! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
bezierFinalXOf: bezier put: value

	^self obj: bezier at: GBFinalX put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar (auto pragmas 12/08) 11/24/1998 22:24'!
bezierUpdateDataOf: bezier
	<returnTypeC: 'int *'>

	^objBuffer + bezier + GBUpdateData! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
bezierViaXOf: bezier

	^self obj: bezier at: GBViaX! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierViaXOf: bezier put: value

	^self obj: bezier at: GBViaX put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierViaYOf: bezier

	^self obj: bezier at: GBViaY! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
bezierViaYOf: bezier put: value

	^self obj: bezier at: GBViaY put: value! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:20'!
bitmapCmSizeOf: bmFill

	^self obj: bmFill at: GBColormapSize! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:19'!
bitmapCmSizeOf: bmFill put: value

	^self obj: bmFill at: GBColormapSize put: value! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapDepthOf: bmFill

	^self obj: bmFill at: GBBitmapDepth! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:20'!
bitmapDepthOf: bmFill put: value

	^self obj: bmFill at: GBBitmapDepth put: value! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapHeightOf: bmFill

	^self obj: bmFill at: GBBitmapHeight! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapHeightOf: bmFill put: value

	^self obj: bmFill at: GBBitmapHeight put: value! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapRasterOf: bmFill

	^self obj: bmFill at: GBBitmapRaster! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapRasterOf: bmFill put: value

	^self obj: bmFill at: GBBitmapRaster put: value! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:19'!
bitmapSizeOf: bmFill

	^self obj: bmFill at: GBBitmapSize! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapSizeOf: bmFill put: value

	^self obj: bmFill at: GBBitmapSize put: value! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/27/1998 14:20'!
bitmapTileFlagOf: bmFill

	^self obj: bmFill at: GBTileFlag! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/27/1998 14:20'!
bitmapTileFlagOf: bmFill put: value

	^self obj: bmFill at: GBTileFlag put: value! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ikp (auto pragmas 12/08) 6/14/2004 15:22'!
bitmapValue: bmFill bits: bits atX: xp y: yp

	| bmDepth bmRaster value rShift cMask r g b a |
	<inline: true>

	bmDepth := self bitmapDepthOf: bmFill.
	bmRaster := self bitmapRasterOf: bmFill.
	bmDepth = 32 ifTrue: [
		value := (self cCoerce: bits to:'int*') at: (bmRaster * yp) + xp.
		(value ~= 0 and: [(value bitAnd: 16rFF000000) = 0])
				ifTrue: [value := value bitOr: 16rFF000000].
		^self uncheckedTransformColor: value].
	"rShift - shift value to convert from pixel to word index"
	rShift := self rShiftTable at: bmDepth.
	value := self makeUnsignedFrom: 
		((self cCoerce: bits to:'int*') at: (bmRaster * yp) + (xp >> rShift)).
	"cMask - mask out the pixel from the word"
	cMask := (1 << bmDepth) - 1.
	"rShift - shift value to move the pixel in the word to the lowest bit position"
	rShift := 32 - bmDepth - ((xp bitAnd: (1 << rShift - 1)) * bmDepth).
	value := (value >> rShift) bitAnd: cMask.
	bmDepth = 16 ifTrue: [
		"Must convert by expanding bits"
		value = 0 ifFalse: [
			b := (value bitAnd: 31) << 3.		b := b + (b >> 5).
			g := (value >> 5 bitAnd: 31) << 3.	g := g + (g >> 5).
			r := (value >> 10 bitAnd: 31) << 3.	r := r + (r >> 5).
			a := 255.
			value := b + (g << 8) + (r << 16) + (a << 24)].
	] ifFalse: [
		"Must convert by using color map"
		(self bitmapCmSizeOf: bmFill) = 0
			ifTrue: [value := 0]
			ifFalse: [value := self makeUnsignedFrom: ((self colormapOf: bmFill) at: value)].
	].
	^self uncheckedTransformColor: value.! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapWidthOf: bmFill

	^self obj: bmFill at: GBBitmapWidth! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapWidthOf: bmFill put: value

	^self obj: bmFill at: GBBitmapWidth put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndX: index
	^self wbStackValue: self wbStackSize - index + 4! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndX: index put: value
	^self wbStackValue: self wbStackSize - index + 4 put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndY: index
	^self wbStackValue: self wbStackSize - index + 5! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndY: index put: value
	^self wbStackValue: self wbStackSize - index + 5 put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzStartX: index
	^self wbStackValue: self wbStackSize - index + 0! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzStartX: index put: value
	^self wbStackValue: self wbStackSize - index + 0 put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzStartY: index
	^self wbStackValue: self wbStackSize - index + 1! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzStartY: index put: value
	^self wbStackValue: self wbStackSize - index + 1 put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzViaX: index
	^self wbStackValue: self wbStackSize - index + 2! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzViaX: index put: value
	^self wbStackValue: self wbStackSize - index + 2 put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzViaY: index
	^self wbStackValue: self wbStackSize - index + 3! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzViaY: index put: value
	^self wbStackValue: self wbStackSize - index + 3 put: value! !
!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:45'!
checkCompressedFillIndexList: fillList max: maxIndex segments: nSegs
	"Check the fill indexes in the run-length encoded fillList"
	| length runLength runValue nFills fillPtr |
	<inline: false>
	<var: #fillPtr type: 'int *'>
	length := interpreterProxy slotSizeOf: fillList.
	fillPtr := interpreterProxy firstIndexableField: fillList.
	nFills := 0.
	0 to: length-1 do:[:i |
		runLength := self shortRunLengthAt: i from: fillPtr.
		runValue := self shortRunValueAt: i from: fillPtr.
		(runValue >= 0 and:[runValue <= maxIndex]) ifFalse:[^false].
		nFills := nFills + runLength.
	].
	^nFills = nSegs! !
!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:45'!
checkCompressedFills: indexList
	"Check if the indexList (containing fill handles) is okay."
	| fillPtr length fillIndex |
	<inline: false>
	<var: #fillPtr type: 'int *'>
	"First check if the oops have the right format"
	(interpreterProxy isWords: indexList) ifFalse:[^false].

	"Then check the fill entries"
	length := interpreterProxy slotSizeOf: indexList.
	fillPtr := interpreterProxy firstIndexableField: indexList.
	0 to: length-1 do:[:i |
		fillIndex := fillPtr at: i.
		"Make sure the fill is okay"
		(self isFillOkay: fillIndex) ifFalse:[^false]].

	^ true! !
!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:45'!
checkCompressedLineWidths: lineWidthList segments: nSegments
	"Check the run-length encoded lineWidthList matches nSegments"
	| length runLength nItems ptr |
	<inline: false>
	<var: #ptr type: 'int *'>
	length := interpreterProxy slotSizeOf: lineWidthList.
	ptr := interpreterProxy firstIndexableField: lineWidthList.
	nItems := 0.
	0 to: length-1 do:[:i|
		runLength := self shortRunLengthAt: i from: ptr.
		nItems := nItems + runLength.
	].
	^nItems = nSegments! !
!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:19'!
checkCompressedPoints: points segments: nSegments
	"Check if the given point array can be handled by the engine."
	| pSize |
	<inline: false>
	(interpreterProxy isWords: points) ifFalse:[^false].
	pSize := interpreterProxy slotSizeOf: points.
	"The points must be either in PointArray format or ShortPointArray format.
	Also, we currently handle only quadratic segments (e.g., 3 points each) and thus either
		pSize = nSegments * 3,		for ShortPointArrays or,
		pSize = nSegments * 6,		for PointArrays"
	(pSize = (nSegments * 3) or:[pSize = (nSegments * 6)]) 
		ifFalse:[^false]. "Can't handle this"
	^true! !
!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar (auto pragmas 12/08) 11/12/1998 21:22'!
checkCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
	"Check if the given shape can be handled by the engine. 
	Since there are a number of requirements this is an extra method."
	| maxFillIndex |
	<inline: false>
	(self checkCompressedPoints: points segments: nSegments) 
		ifFalse:[^false].
	(self checkCompressedFills: fillIndexList)
		ifFalse:[^false].
	maxFillIndex := interpreterProxy slotSizeOf: fillIndexList.
	(self checkCompressedFillIndexList: leftFills max: maxFillIndex segments: nSegments)
		ifFalse:[^false].
	(self checkCompressedFillIndexList: rightFills max: maxFillIndex segments: nSegments)
		ifFalse:[^false].
	(self checkCompressedFillIndexList: lineFills max: maxFillIndex segments: nSegments)
		ifFalse:[^false].
	(self checkCompressedLineWidths: lineWidths segments: nSegments)
		ifFalse:[^false].
	^true! !
!BalloonEnginePlugin methodsFor: 'GET processing' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:37'!
checkedAddBezierToGET: bezier
	"Add the bezier to the global edge table if it intersects the clipping region"
	| lineWidth |
	<inline: true>

	(self isWide: bezier) 
		ifTrue:[lineWidth := (self wideBezierExtentOf: bezier)]
		ifFalse:[lineWidth := 0].
	(self bezierEndYOf: bezier) + lineWidth < (self fillMinYGet) ifTrue:[^0].
	"Overlaps in Y but may still be entirely right of clip region"
	((self edgeXValueOf: bezier) - lineWidth >= self fillMaxXGet and:[
		(self bezierEndXOf: bezier) - lineWidth >= self fillMaxXGet]) ifTrue:[^0].
	self addEdgeToGET: bezier.
! !
!BalloonEnginePlugin methodsFor: 'GET processing' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:37'!
checkedAddEdgeToGET: edge
	"Add the edge to the global edge table.
	For known edge types, check if the edge intersects the visible region"
	<inline: true>

	(self isLine: edge) ifTrue:[^self checkedAddLineToGET: edge].
	(self isBezier: edge) ifTrue:[^self checkedAddBezierToGET: edge].
	self addEdgeToGET: edge.
! !
!BalloonEnginePlugin methodsFor: 'GET processing' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:37'!
checkedAddLineToGET: line
	"Add the line to the global edge table if it intersects the clipping region"
	| lineWidth |
	<inline: true>

	(self isWide: line) 
		ifTrue:[lineWidth := (self wideLineExtentOf: line)]
		ifFalse:[lineWidth := 0].
	(self lineEndYOf: line) + lineWidth < (self fillMinYGet) ifTrue:[^0].
	"Overlaps in Y but may still be entirely right of clip region"
	((self edgeXValueOf: line) - lineWidth >= self fillMaxXGet and:[
		(self lineEndXOf: line) - lineWidth >= self fillMaxXGet]) ifTrue:[^0].
	self addEdgeToGET: line.
! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/1/1998 17:06'!
circleCosTable
	| theTable |
	<returnTypeC: 'double *'>
	<inline: false>
	<var: #theTable declareC: 'static double theTable[33] =
		{1.0, 0.98078528040323, 0.923879532511287, 0.831469612302545,
		0.7071067811865475, 0.555570233019602, 0.38268343236509, 0.1950903220161286,
		0.0, -0.1950903220161283, -0.3826834323650896, -0.555570233019602,
		-0.707106781186547, -0.831469612302545, -0.9238795325112865, -0.98078528040323,
		-1.0, -0.98078528040323, -0.923879532511287, -0.831469612302545,
		-0.707106781186548, -0.555570233019602, -0.3826834323650903, -0.1950903220161287,
		0.0, 0.1950903220161282, 0.38268343236509, 0.555570233019602,
		0.707106781186547, 0.831469612302545, 0.9238795325112865, 0.98078528040323,
		1.0 }'>
	^theTable! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/1/1998 17:06'!
circleSinTable
	| theTable |
	<returnTypeC: 'double *'>
	<inline: false>
	<var: #theTable declareC: 'static double theTable[33] =
		{0.0, 0.1950903220161282, 0.3826834323650897, 0.555570233019602,
		0.707106781186547, 0.831469612302545, 0.923879532511287, 0.98078528040323,
		1.0, 0.98078528040323, 0.923879532511287, 0.831469612302545,
		0.7071067811865475, 0.555570233019602, 0.38268343236509, 0.1950903220161286,
		0.0, -0.1950903220161283, -0.3826834323650896, -0.555570233019602,
		-0.707106781186547, -0.831469612302545, -0.9238795325112865, -0.98078528040323,
		-1.0, -0.98078528040323, -0.923879532511287, -0.831469612302545,
		-0.707106781186548, -0.555570233019602, -0.3826834323650903, -0.1950903220161287,
		 0.0 }'>
	^theTable! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar (auto pragmas 12/08) 11/27/1998 14:19'!
clampValue: value max: maxValue

	<inline: true>
	value < 0 
		ifTrue:[^0]
		ifFalse:[value >= maxValue 
					ifTrue:[^maxValue-1]
					ifFalse:[^value]]! !
!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/25/1998 16:39'!
colormapOf: bmFill
	<returnTypeC: 'int *'>
	^objBuffer + bmFill + GBColormapOffset! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:46'!
computeBezier: index splitAt: param
	"Split the bezier curve at the given parametric value.
	Note: Since this method is only invoked to make non-monoton
		beziers monoton we must check for the resulting y values
		to be *really* between the start and end value."
	| startX startY viaX viaY endX endY newIndex 
	leftViaX  leftViaY rightViaX rightViaY sharedX sharedY |
	<inline: false>
	<var: #param type: 'double '>
	leftViaX := startX := self bzStartX: index.
	leftViaY := startY := self bzStartY: index.
	rightViaX := viaX := self bzViaX: index.
	rightViaY := viaY := self bzViaY: index.
	endX := self bzEndX: index.
	endY := self bzEndY: index.

	"Compute intermediate points"
	sharedX := leftViaX := leftViaX + ((viaX - startX) asFloat * param) asInteger.
	sharedY := leftViaY := leftViaY + ((viaY - startY) asFloat * param) asInteger.
	rightViaX := rightViaX + ((endX - viaX) asFloat * param) asInteger.
	rightViaY := rightViaY + ((endY - viaY) asFloat * param) asInteger.
	"Compute new shared point"
	sharedX := sharedX + ((rightViaX - leftViaX) asFloat * param) asInteger.
	sharedY := sharedY + ((rightViaY - leftViaY) asFloat * param) asInteger.

	"Check the new via points"
	leftViaY := self assureValue: leftViaY between: startY and: sharedY.
	rightViaY := self assureValue: rightViaY between: sharedY and: endY.

	newIndex := self allocateBezierStackEntry.
	engineStopped ifTrue:[^0]. "Something went wrong"

	"Store the first part back"
	self bzViaX: index put: leftViaX.
	self bzViaY: index put: leftViaY.
	self bzEndX: index put: sharedX.
	self bzEndY: index put: sharedY.
	"Store the second point back"
	self bzStartX: newIndex put: sharedX.
	self bzStartY: newIndex put: sharedY.
	self bzViaX: newIndex put: rightViaX.
	self bzViaY: newIndex put: rightViaY.
	self bzEndX: newIndex put: endX.
	self bzEndY: newIndex put: endY.

	^newIndex! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/6/1998 01:26'!
computeBezierSplitAtHalf: index
	"Split the bezier curve at 0.5."
	| startX startY viaX viaY endX endY newIndex 
	leftViaX  leftViaY rightViaX rightViaY sharedX sharedY |
	<inline: false>

	newIndex := self allocateBezierStackEntry.
	engineStopped ifTrue:[^0]. "Something went wrong"

	leftViaX := startX := self bzStartX: index.
	leftViaY := startY := self bzStartY: index.
	rightViaX := viaX := self bzViaX: index.
	rightViaY := viaY := self bzViaY: index.
	endX := self bzEndX: index.
	endY := self bzEndY: index.
	"Compute intermediate points"
	leftViaX := leftViaX + ((viaX - startX) // 2).
	leftViaY := leftViaY + ((viaY - startY) // 2).
	sharedX := rightViaX := rightViaX + ((endX - viaX) // 2).
	sharedY := rightViaY := rightViaY + ((endY - viaY) // 2).
	"Compute new shared point"
	sharedX := sharedX + ((leftViaX - rightViaX) // 2).
	sharedY := sharedY + ((leftViaY - rightViaY) // 2).
	"Store the first part back"
	self bzViaX: index put: leftViaX.
	self bzViaY: index put: leftViaY.
	self bzEndX: index put: sharedX.
	self bzEndY: index put: sharedY.
	"Store the second point back"
	self bzStartX: newIndex put: sharedX.
	self bzStartY: newIndex put: sharedY.
	self bzViaX: newIndex put: rightViaX.
	self bzViaY: newIndex put: rightViaY.
	self bzEndX: newIndex put: endX.
	self bzEndY: newIndex put: endY.

	^newIndex! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/8/1998 03:44'!
computeFinalWideBezierValues: bezier width: lineWidth
	"Get both values from the two boundaries of the given bezier 
	and compute the actual position/width of the line"
	| leftX rightX temp |
	leftX := ((self bezierUpdateDataOf: bezier) at: GBUpdateX) // 256.
	rightX := ((self wideBezierUpdateDataOf: bezier) at: GBUpdateX) // 256.
	leftX > rightX ifTrue:[temp := leftX. leftX := rightX. rightX := temp].
	self edgeXValueOf: bezier put: leftX.
	(rightX - leftX) > lineWidth ifTrue:[
		self wideBezierWidthOf: bezier put: (rightX - leftX).
	] ifFalse:[
		self wideBezierWidthOf: bezier put: lineWidth.
	].! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar (auto pragmas 12/08) 11/25/1998 19:46'!
fillBitmapSpan
	<inline: true>
	^self fillBitmapSpan: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:46'!
fillBitmapSpan: bmFill from: leftX to: rightX at: yValue
	| x x1 dsX ds dtX dt deltaX deltaY bits xp yp bmWidth bmHeight fillValue tileFlag |
	<inline: false>
	<var: #bits type: 'int *'>
	self aaLevelGet = 1
		ifFalse:[^self fillBitmapSpanAA: bmFill from: leftX to: rightX at: yValue].

	bits := self loadBitsFrom: bmFill.
	bits == nil ifTrue:[^nil].
	bmWidth := self bitmapWidthOf: bmFill.
	bmHeight := self bitmapHeightOf: bmFill.
	tileFlag := (self bitmapTileFlagOf: bmFill) = 1.
	deltaX := leftX - (self fillOriginXOf: bmFill).
	deltaY := yValue - (self fillOriginYOf: bmFill).
	dsX := self fillDirectionXOf: bmFill.
	dtX := self fillNormalXOf: bmFill.

	ds := (deltaX * dsX) + (deltaY * (self fillDirectionYOf: bmFill)).
	dt := (deltaX * dtX) + (deltaY * (self fillNormalYOf: bmFill)).

	x := leftX.
	x1 := rightX.
	[x < x1] whileTrue:[
		tileFlag ifTrue:[
			ds := self repeatValue: ds max: bmWidth << 16.
			dt := self repeatValue: dt max: bmHeight << 16].
		xp := ds // 16r10000.
		yp := dt // 16r10000.
		tileFlag ifFalse:[
			xp := self clampValue: xp max: bmWidth.
			yp := self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue := self bitmapValue: bmFill bits: bits atX: xp y: yp.
			spanBuffer at: x put: fillValue.
		].
		ds := ds + dsX.
		dt := dt + dtX.
		x := x + 1.
	].! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:46'!
fillBitmapSpanAA: bmFill from: leftX to: rightX at: yValue
	| x dsX ds dtX dt deltaX deltaY bits xp yp bmWidth bmHeight fillValue baseShift cMask cShift idx aaLevel firstPixel lastPixel tileFlag |
	<inline: false>
	<var: #bits type: 'int *'>
	bits := self loadBitsFrom: bmFill.
	bits == nil ifTrue:[^nil].
	bmWidth := self bitmapWidthOf: bmFill.
	bmHeight := self bitmapHeightOf: bmFill.
	tileFlag := (self bitmapTileFlagOf: bmFill) = 1.
	deltaX := leftX - (self fillOriginXOf: bmFill).
	deltaY := yValue - (self fillOriginYOf: bmFill).
	dsX := self fillDirectionXOf: bmFill.
	dtX := self fillNormalXOf: bmFill.

	ds := (deltaX * dsX) + (deltaY * (self fillDirectionYOf: bmFill)).
	dt := (deltaX * dtX) + (deltaY * (self fillNormalYOf: bmFill)).

	aaLevel := self aaLevelGet.
	firstPixel := self aaFirstPixelFrom: leftX to: rightX.
	lastPixel := self aaLastPixelFrom: leftX to: rightX.
	baseShift := self aaShiftGet.
	cMask := self aaColorMaskGet.
	cShift := self aaColorShiftGet.
	x := leftX.
	[x < firstPixel] whileTrue:[
		tileFlag ifTrue:[
			ds := self repeatValue: ds max: bmWidth << 16.
			dt := self repeatValue: dt max: bmHeight << 16].
		xp := ds // 16r10000.
		yp := dt // 16r10000.
		tileFlag ifFalse:[
			xp := self clampValue: xp max: bmWidth.
			yp := self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue := self bitmapValue: bmFill bits: bits atX: xp y: yp.
			fillValue := (fillValue bitAnd: cMask) >> cShift.
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + fillValue.
		].
		ds := ds + dsX.
		dt := dt + dtX.
		x := x + 1.
	].

	cMask := (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
	cShift := self aaShiftGet.
	[x < lastPixel] whileTrue:[
		tileFlag ifTrue:[
			ds := self repeatValue: ds max: bmWidth << 16.
			dt := self repeatValue: dt max: bmHeight << 16].
		xp := ds // 16r10000.
		yp := dt // 16r10000.
		tileFlag ifFalse:[
			xp := self clampValue: xp max: bmWidth.
			yp := self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue := self bitmapValue: bmFill bits: bits atX: xp y: yp.
			fillValue := (fillValue bitAnd: cMask) >> cShift.
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + fillValue.
		].
		ds := ds + (dsX << cShift).
		dt := dt + (dtX << cShift).
		x := x + aaLevel.
	].

	cMask := self aaColorMaskGet.
	cShift := self aaColorShiftGet.
	[x < rightX] whileTrue:[
		tileFlag ifTrue:[
			ds := self repeatValue: ds max: bmWidth << 16.
			dt := self repeatValue: dt max: bmHeight << 16].
		xp := ds // 16r10000.
		yp := dt // 16r10000.
		tileFlag ifFalse:[
			xp := self clampValue: xp max: bmWidth.
			yp := self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue := self bitmapValue: bmFill bits: bits atX: xp y: yp.
			fillValue := (fillValue bitAnd: cMask) >> cShift.
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + fillValue.
		].
		ds := ds + dsX.
		dt := dt + dtX.
		x := x + 1.
	].
! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillDirectionXOf: fill

	^self obj: fill at: GFDirectionX! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillDirectionXOf: fill put: value

	^self obj: fill at: GFDirectionX put: value! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:19'!
fillDirectionYOf: fill

	^self obj: fill at: GFDirectionY! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillDirectionYOf: fill put: value

	^self obj: fill at: GFDirectionY put: value! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:20'!
fillLinearGradient
	<inline: true>
	^self fillLinearGradient: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:46'!
fillLinearGradient: fill from: leftX to: rightX at: yValue
	"Draw a linear gradient fill."
	| x0 x1 ramp rampSize dsX ds x rampIndex |
	<inline: false>
	<var: #ramp type: 'int *'>
	ramp := self gradientRampOf: fill.
	rampSize := self gradientRampLengthOf: fill.

	dsX := self fillDirectionXOf: fill.
	ds := ((leftX - (self fillOriginXOf: fill)) * dsX) + 
			((yValue - (self fillOriginYOf: fill)) * (self fillDirectionYOf: fill)).

	x := x0 := leftX.
	x1 := rightX.

	"Note: The inner loop has been divided into three parts for speed"
	"Part one: Fill everything outside the left boundary"
	[((rampIndex := ds // 16r10000) < 0 or:[rampIndex >= rampSize]) and:[x < x1]] 
		whileTrue:[	x := x + 1.
					ds := ds + dsX].
	x > x0 ifTrue:[
		rampIndex < 0 ifTrue:[rampIndex := 0].
		rampIndex >= rampSize ifTrue:[rampIndex := rampSize - 1].
		self fillColorSpan: (self makeUnsignedFrom: (ramp at: rampIndex)) from: x0 to: x].

	"Part two: Fill everything inside the boundaries"
	self aaLevelGet = 1 ifTrue:[
		"Fast version w/o anti-aliasing"
		[((rampIndex := ds // 16r10000) < rampSize and:[rampIndex >= 0]) and:[x < x1]] whileTrue:[
			spanBuffer at: x put: (self makeUnsignedFrom: (ramp at: rampIndex)).
			x := x + 1.
			ds := ds + dsX.
		].
	] ifFalse:[x := self fillLinearGradientAA: fill ramp: ramp ds: ds dsX: dsX from: x to: rightX].
	"Part three fill everything outside right boundary"
	x < x1 ifTrue:[
		rampIndex < 0 ifTrue:[rampIndex := 0].
		rampIndex >= rampSize ifTrue:[rampIndex := rampSize-1].
		self fillColorSpan: (self makeUnsignedFrom: (ramp at: rampIndex)) from: x to: x1].
! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:46'!
fillLinearGradientAA: fill ramp: ramp ds: deltaS dsX: dsX from: leftX to: rightX
	"This is the AA version of linear gradient filling."
	| colorMask colorShift baseShift rampIndex ds rampSize x idx rampValue 
	 aaLevel firstPixel lastPixel |
	<inline: false>
	<var: #ramp type: 'int *'>

	aaLevel := self aaLevelGet.
	baseShift := self aaShiftGet.
	rampSize := self gradientRampLengthOf: fill.
	ds := deltaS.
	x := leftX.
	rampIndex := ds // 16r10000.

	firstPixel := self aaFirstPixelFrom: leftX to: rightX.
	lastPixel := self aaLastPixelFrom: leftX to: rightX.

	"Deal with the first n sub-pixels"
	colorMask := self aaColorMaskGet.
	colorShift := self aaColorShiftGet.
	[x < firstPixel and:[rampIndex < rampSize and:[rampIndex >= 0]]] whileTrue:[
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		"Copy as many pixels as possible"
		[x < firstPixel and:[(ds//16r10000) = rampIndex]] whileTrue:[
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + rampValue.
			x := x + 1.
			ds := ds + dsX].
		rampIndex := ds // 16r10000.
	].

	"Deal with the full pixels"
	colorMask := (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
	colorShift := self aaShiftGet.
	[x < lastPixel and:[rampIndex < rampSize and:[rampIndex >= 0]]] whileTrue:[
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		"Copy as many pixels as possible"
		[x < lastPixel and:[(ds//16r10000) = rampIndex]] whileTrue:[
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + rampValue.
			x := x + aaLevel.
			ds := ds + (dsX << colorShift)].
		rampIndex := ds // 16r10000.
	].

	"Deal with the last n sub-pixels"
	colorMask := self aaColorMaskGet.
	colorShift := self aaColorShiftGet.
	[x < rightX and:[rampIndex < rampSize and:[rampIndex>=0]]] whileTrue:[
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		"Copy as many pixels as possible"
		[x < rightX and:[(ds//16r10000) = rampIndex]] whileTrue:[
			idx := x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + rampValue.
			x := x + 1.
			ds := ds + dsX].
		rampIndex := ds // 16r10000.
	].
	^x! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillNormalXOf: fill

	^self obj: fill at: GFNormalX! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillNormalXOf: fill put: value

	^self obj: fill at: GFNormalX put: value! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillNormalYOf: fill

	^self obj: fill at: GFNormalY! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:16'!
fillNormalYOf: fill put: value

	^self obj: fill at: GFNormalY put: value! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:17'!
fillOriginXOf: fill

	^self obj: fill at: GFOriginX! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:17'!
fillOriginXOf: fill put: value

	^self obj: fill at: GFOriginX put: value! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:17'!
fillOriginYOf: fill

	^self obj: fill at: GFOriginY! !
!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillOriginYOf: fill put: value

	^self obj: fill at: GFOriginY put: value! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar (auto pragmas 12/08) 11/24/1998 19:02'!
fillRadialDecreasing: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2a) Compute the decreasing part of the ramp"
	| ds dt rampIndex rampValue length2 x x1 nextLength |
	<inline: true>
	ds := (self cCoerce: deltaST to:'int*') at: 0.
	dt := (self cCoerce: deltaST to:'int*') at: 1.
	rampIndex := self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
	length2 := (rampIndex-1) * (rampIndex-1).

	x := leftX.
	x1 := rightX.
	x1 > (self fillOriginXOf: fill) ifTrue:[x1 := self fillOriginXOf: fill].
	[x < x1] whileTrue:[
		"Try to copy the current value more than just once"
		[x < x1 and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
			whileTrue:[	spanBuffer at: x put: rampValue.
						x := x + 1.
						ds := ds + dsX.
						dt := dt + dtX].
		"Step to next ramp value"
		nextLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
		[nextLength < length2] whileTrue:[
			rampIndex := rampIndex - 1.
			rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
			length2 := (rampIndex-1) * (rampIndex-1).
		].
	].

	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:47'!
fillRadialDecreasingAA: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2a) Compute the decreasing part of the ramp"
	| ds dt rampIndex rampValue length2 x nextLength x1
	aaLevel colorMask colorShift baseShift index firstPixel lastPixel |
	<inline: false>
	<var: #ramp type: 'int *'>
	<var: #deltaST type: ' int *'>

	ds := (self cCoerce: deltaST to:'int*') at: 0.
	dt := (self cCoerce: deltaST to:'int*') at: 1.
	aaLevel := self aaLevelGet.
	baseShift := self aaShiftGet.
	rampIndex := self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	length2 := (rampIndex-1) * (rampIndex-1).

	x := leftX.
	x1 := self fillOriginXOf: fill.
	x1 > rightX ifTrue:[x1 := rightX].
	firstPixel := self aaFirstPixelFrom: leftX to: x1.
	lastPixel := self aaLastPixelFrom: leftX to: x1.

	"Deal with the first n sub-pixels"
	(x < firstPixel) ifTrue:[
		colorMask := self aaColorMaskGet.
		colorShift := self aaColorShiftGet.
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		[x < firstPixel] whileTrue:[
			"Try to copy the current value more than just once"
			[x < firstPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
				whileTrue:[	index := x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x := x + 1.
							ds := ds + dsX.
							dt := dt + dtX].
			"Step to next ramp value"
			nextLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[nextLength < length2] whileTrue:[
				rampIndex := rampIndex - 1.
				rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue := (rampValue bitAnd: colorMask) >> colorShift.
				length2 := (rampIndex-1) * (rampIndex-1).
			].
		].
	].

	"Deal with the full pixels"
	(x < lastPixel) ifTrue:[
		colorMask := (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
		colorShift := self aaShiftGet.
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		[x < lastPixel] whileTrue:[
			"Try to copy the current value more than just once"
			[x < lastPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
				whileTrue:[	index := x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x := x + aaLevel.
							ds := ds + (dsX << colorShift).
							dt := dt + (dtX << colorShift)].
			"Step to next ramp value"
			nextLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[nextLength < length2] whileTrue:[
				rampIndex := rampIndex - 1.
				rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue := (rampValue bitAnd: colorMask) >> colorShift.
				length2 := (rampIndex-1) * (rampIndex-1).
			].
		].
	].

	"Deal with the last n sub-pixels"
	(x < x1) ifTrue:[
		colorMask := self aaColorMaskGet.
		colorShift := self aaColorShiftGet.
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		[x < x1] whileTrue:[
			"Try to copy the current value more than just once"
			[x < x1 and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
				whileTrue:[	index := x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x := x + 1.
							ds := ds + dsX.
							dt := dt + dtX].
			"Step to next ramp value"
			nextLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[nextLength < length2] whileTrue:[
				rampIndex := rampIndex - 1.
				rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue := (rampValue bitAnd: colorMask) >> colorShift.
				length2 := (rampIndex-1) * (rampIndex-1).
			].
		].
	].
	"Done -- store stuff back"
	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:20'!
fillRadialGradient
	<inline: true>
	^self fillRadialGradient: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:47'!
fillRadialGradient: fill from: leftX to: rightX at: yValue
	"Draw a radial gradient fill."
	| x x1 ramp rampSize dsX ds dtX dt length2 deltaX deltaY deltaST |
	<inline: false>
	<var: #ramp type: 'int *'>
	<var: #deltaST type: 'int *'>

	ramp := self gradientRampOf: fill.
	rampSize := self gradientRampLengthOf: fill.

	deltaX := leftX - (self fillOriginXOf: fill).
	deltaY := yValue - (self fillOriginYOf: fill).

	dsX := self fillDirectionXOf: fill.
	dtX := self fillNormalXOf: fill.

	ds := (deltaX * dsX) + (deltaY * (self fillDirectionYOf: fill)).
	dt := (deltaX * dtX) + (deltaY * (self fillNormalYOf: fill)).

	x := leftX.
	x1 := rightX.

	"Note: The inner loop has been divided into three parts for speed"
	"Part one: Fill everything outside the left boundary"
	length2 := (rampSize-1) * (rampSize-1). "This is the upper bound"
	[(self squaredLengthOf: ds // 16r10000 with: dt // 16r10000) >= length2 and:[x < x1]]
		whileTrue:[	x := x + 1.	ds := ds + dsX.	dt := dt + dtX].
	x > leftX ifTrue:[self fillColorSpan: (self makeUnsignedFrom: (ramp at: rampSize-1)) from: leftX to: x].

	"Part two: Fill everything inside the boundaries"
	deltaST := self point1Get.
	deltaST at: 0 put: ds.
	deltaST at: 1 put: dt.
	(x < (self fillOriginXOf: fill)) ifTrue:[
		"Draw the decreasing part"
		self aaLevelGet = 1 
			ifTrue:[x := self fillRadialDecreasing: fill ramp: ramp deltaST: deltaST 
							dsX: dsX dtX: dtX from: x to: x1]
			ifFalse:[x := self fillRadialDecreasingAA: fill ramp: ramp deltaST: deltaST 
							dsX: dsX dtX: dtX from: x to: x1].
	].
	x < x1 ifTrue:[
		"Draw the increasing part"
		self aaLevelGet = 1
			ifTrue:[x := self fillRadialIncreasing: fill ramp: ramp deltaST: deltaST
							dsX: dsX dtX: dtX from: x to: x1]
			ifFalse:[x := self fillRadialIncreasingAA: fill ramp: ramp deltaST: deltaST
							dsX: dsX dtX: dtX from: x to: x1].
	].

	"Part three fill everything outside right boundary"
	x < rightX ifTrue:[self fillColorSpan: (self makeUnsignedFrom: (ramp at: rampSize-1)) from: x to: rightX].
! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar (auto pragmas 12/08) 11/9/1998 01:21'!
fillRadialIncreasing: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2b) Compute the increasing part of the ramp"
	| ds dt rampIndex rampValue length2 x x1 nextLength rampSize lastLength |
	<inline: true>
	ds := (self cCoerce: deltaST to:'int*') at: 0.
	dt := (self cCoerce: deltaST to:'int*') at: 1.
	rampIndex := self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
	rampSize := self gradientRampLengthOf: fill.
	length2 := (rampSize-1) * (rampSize-1). "This is the upper bound"
	nextLength := (rampIndex+1) * (rampIndex+1).
	lastLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.

	x := leftX.
	x1 := rightX.

	[x < x1 and:[lastLength < length2]] whileTrue:[
		"Try to copy the current value more than once"
		[x < x1 and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
			whileTrue:[	spanBuffer at: x put: rampValue.
						x := x + 1.
						ds := ds + dsX.
						dt := dt + dtX].
		lastLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
		[lastLength > nextLength] whileTrue:[
			rampIndex := rampIndex + 1.
			rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
			nextLength := (rampIndex+1) * (rampIndex+1).
		].
	].

	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:47'!
fillRadialIncreasingAA: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2b) Compute the increasing part of the ramp"
	| ds dt rampIndex rampValue length2 x nextLength rampSize lastLength 
	aaLevel colorMask colorShift baseShift index firstPixel lastPixel |
	<inline: false>
	<var: #ramp type: 'int *'>
	<var: #deltaST type: ' int *'>

	ds := (self cCoerce: deltaST to:'int*') at: 0.
	dt := (self cCoerce: deltaST to:'int*') at: 1.
	aaLevel := self aaLevelGet.
	baseShift := self aaShiftGet.
	rampIndex := self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	rampSize := self gradientRampLengthOf: fill.
	length2 := (rampSize-1) * (rampSize-1). "This is the upper bound"
	nextLength := (rampIndex+1) * (rampIndex+1).
	lastLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.

	x := leftX.

	firstPixel := self aaFirstPixelFrom: leftX to: rightX.
	lastPixel := self aaLastPixelFrom: leftX to: rightX.

	"Deal with the first n subPixels"
	(x < firstPixel and:[lastLength < length2]) ifTrue:[
		colorMask := self aaColorMaskGet.
		colorShift := self aaColorShiftGet.
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		[x < firstPixel and:[lastLength < length2]] whileTrue:[
			"Try to copy the current value more than once"
			[x < firstPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
				whileTrue:[	index := x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x := x + 1.
							ds := ds + dsX.
							dt := dt + dtX].
			lastLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[lastLength > nextLength] whileTrue:[
				rampIndex := rampIndex + 1.
				rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue := (rampValue bitAnd: colorMask) >> colorShift.
				nextLength := (rampIndex+1) * (rampIndex+1).
			].
		].
	].

	"Deal with the full pixels"
	(x < lastPixel and:[lastLength < length2]) ifTrue:[
		colorMask := (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
		colorShift := self aaShiftGet.
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		[x < lastPixel and:[lastLength < length2]] whileTrue:[
			"Try to copy the current value more than once"
			[x < lastPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
				whileTrue:[	index := x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x := x + aaLevel.
							ds := ds + (dsX << colorShift).
							dt := dt + (dtX << colorShift)].
			lastLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[lastLength > nextLength] whileTrue:[
				rampIndex := rampIndex + 1.
				rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue := (rampValue bitAnd: colorMask) >> colorShift.
				nextLength := (rampIndex+1) * (rampIndex+1).
			].
		].
	].

	"Deal with last n sub-pixels"
	(x < rightX and:[lastLength < length2]) ifTrue:[
		colorMask := self aaColorMaskGet.
		colorShift := self aaColorShiftGet.
		rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue := (rampValue bitAnd: colorMask) >> colorShift.
		[x < rightX and:[lastLength < length2]] whileTrue:[
			"Try to copy the current value more than once"
			[x < rightX and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
				whileTrue:[	index := x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x := x + 1.
							ds := ds + dsX.
							dt := dt + dtX].
			lastLength := self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[lastLength > nextLength] whileTrue:[
				rampIndex := rampIndex + 1.
				rampValue := self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue := (rampValue bitAnd: colorMask) >> colorShift.
				nextLength := (rampIndex+1) * (rampIndex+1).
			].
		].
	].
	"Done -- store stuff back"
	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !
!BalloonEnginePlugin methodsFor: 'accessing gradients' stamp: 'ar 11/24/1998 22:18'!
gradientRampLengthOf: fill

	^self obj: fill at: GFRampLength! !
!BalloonEnginePlugin methodsFor: 'accessing gradients' stamp: 'ar 11/24/1998 22:17'!
gradientRampLengthOf: fill put: value

	^self obj: fill at: GFRampLength put: value! !
!BalloonEnginePlugin methodsFor: 'accessing gradients' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/24/1998 22:25'!
gradientRampOf: fill
	<returnTypeC: 'int *'>

	^objBuffer + fill +  GFRampOffset! !
!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/4/1998 21:46'!
isBezier: bezier
	^((self objectTypeOf: bezier) bitAnd: GEPrimitiveWideMask) = GEPrimitiveBezier! !
!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:14'!
isFillOkay: fill
	<inline: false>
	^(fill = 0 or:[(self isFillColor: fill) or:[((self isObject: fill) and:[self isFill: fill])]]) 
! !
!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/4/1998 21:46'!
isLine: line
	^((self objectTypeOf: line) bitAnd: GEPrimitiveWideMask) = GEPrimitiveLine! !
!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/6/1998 01:53'!
isWideBezier: bezier
	^(self isBezier: bezier) and:[self isWide: bezier]! !
!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/4/1998 22:08'!
isWideLine: line
	^(self isLine: line) and:[self isWide: line]! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndXOf: line

	^self obj: line at: GLEndX! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndXOf: line put: value

	^self obj: line at: GLEndX put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndYOf: line

	^self obj: line at: GLEndY! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndYOf: line put: value

	^self obj: line at: GLEndY put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineErrorAdjDownOf: line

	^self obj: line at: GLErrorAdjDown! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineErrorAdjDownOf: line put: value

	^self obj: line at: GLErrorAdjDown put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorAdjUpOf: line

	^self obj: line at: GLErrorAdjUp! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorAdjUpOf: line put: value

	^self obj: line at: GLErrorAdjUp put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorOf: line

	^self obj: line at: GLError! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorOf: line put: value

	^self obj: line at: GLError put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineXDirectionOf: line

	^self obj: line at: GLXDirection! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineXDirectionOf: line put: value

	^self obj: line at: GLXDirection put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineXIncrementOf: line

	^self obj: line at: GLXIncrement! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineXIncrementOf: line put: value

	^self obj: line at: GLXIncrement put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineYDirectionOf: line

	^self obj: line at: GLYDirection! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineYDirectionOf: line put: value

	^self obj: line at: GLYDirection put: value! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:47'!
loadAndSubdivideBezierFrom: point1 via: point2 to: point3 isWide: wideFlag
	"Load and subdivide the bezier curve from point1/point2/point3.
	If wideFlag is set then make sure the curve is monoton in X."
	| bz1 bz2 index2 index1 |
	<inline: false>
	<var: #point1 type: 'int *'>
	<var: #point2 type: 'int *'>
	<var: #point3 type: 'int *'>
	bz1 := self allocateBezierStackEntry.	
	engineStopped ifTrue:[^0].
	"Load point1/point2/point3 on the top of the stack"
	self bzStartX: bz1 put: (point1 at: 0).
	self bzStartY: bz1 put: (point1 at: 1).
	self bzViaX: bz1 put: (point2 at: 0).
	self bzViaY: bz1 put: (point2 at: 1).
	self bzEndX: bz1 put: (point3 at: 0).
	self bzEndY: bz1 put: (point3 at: 1).

	"Now check if the bezier curve is monoton. If not, subdivide it."
	index2 := bz2 := self subdivideToBeMonoton: bz1 inX: wideFlag.
	bz1 to: bz2 by: 6 do:[:index|
		index1 := self subdivideBezierFrom: index.
		index1 > index2 ifTrue:[index2 := index1].
		engineStopped ifTrue:[^0]. "Something went wrong"
	].
	"Return the number of segments"
	^index2 // 6! !
!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'ar 11/24/1998 23:09'!
loadArrayPolygon: points nPoints: nPoints fill: fillIndex lineWidth: lineWidth lineFill: lineFill
	| x0 y0 x1 y1 |
	self loadPoint: self point1Get from: (interpreterProxy fetchPointer: 0 ofObject: points).
	interpreterProxy failed ifTrue:[^nil].
	x0 := self point1Get at: 0.
	y0 := self point1Get at: 1.
	1 to: nPoints-1 do:[:i|
		self loadPoint: self point1Get from: (interpreterProxy fetchPointer: i ofObject: points).
		interpreterProxy failed ifTrue:[^nil].
		x1 := self point1Get at: 0.
		y1 := self point1Get at: 1.
		self point1Get at: 0 put: x0.
		self point1Get at: 1 put: y0.
		self point2Get at: 0 put: x1.
		self point2Get at: 1 put: y1.
		self transformPoints: 2.
		self loadWideLine: lineWidth 
			from: self point1Get
			to: self point2Get
			lineFill: lineFill 
			leftFill: fillIndex
			rightFill: 0.
		engineStopped ifTrue:[^nil].
		x0 := x1.
		y0 := y1.
	].! !
!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'ar (auto pragmas 12/08) 11/24/1998 23:14'!
loadArrayShape: points nSegments: nSegments fill: fillIndex lineWidth: lineWidth lineFill: lineFill 
	| pointOop x0 y0 x1 y1 x2 y2 segs |
	<inline: false>
	0 to: nSegments-1 do:[:i|
		pointOop := interpreterProxy fetchPointer: (i * 3) ofObject: points.
		self loadPoint: self point1Get from: pointOop.
		pointOop := interpreterProxy fetchPointer: (i * 3 + 1) ofObject: points.
		self loadPoint: self point2Get from: pointOop.
		pointOop := interpreterProxy fetchPointer: (i * 3 + 2) ofObject: points.
		self loadPoint: self point3Get from: pointOop.
		interpreterProxy failed ifTrue:[^nil].
		self transformPoints: 3.
		x0 := self point1Get at: 0.
		y0 := self point1Get at: 1.
		x1 := self point2Get at: 0.
		y1 := self point2Get at: 1.
		x2 := self point3Get at: 0.
		y2 := self point3Get at: 1.
		"Check if we can use a line"
		((x0 = y0 and:[x1 = y1]) or:[x1 = x2 and:[y1 = y2]]) ifTrue:[
			self loadWideLine: lineWidth
				from: self point1Get
				to: self point3Get
				lineFill: lineFill
				leftFill: fillIndex
				rightFill: 0.
		] ifFalse:["Need bezier"
			segs := self loadAndSubdivideBezierFrom: self point1Get
					via: self point2Get
					to: self point3Get
					isWide: (lineWidth ~= 0 and:[lineFill ~= 0]).
			engineStopped ifTrue:[^nil].
			self loadWideBezier: lineWidth
				lineFill: lineFill
				leftFill: fillIndex
				rightFill: 0
				n: segs.
		].
		engineStopped ifTrue:[^nil].
	].! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/24/1998 23:15'!
loadBezier: bezier segment: index leftFill: leftFillIndex rightFill: rightFillIndex offset: yOffset
	"Initialize the bezier segment stored on the stack"
	<inline: false>
	(self bzEndY: index) >= (self bzStartY: index) ifTrue:[
		"Top to bottom"
		self edgeXValueOf: bezier put: (self bzStartX: index).
		self edgeYValueOf: bezier put: (self bzStartY: index) - yOffset.
		self bezierViaXOf: bezier put: (self bzViaX: index).
		self bezierViaYOf: bezier put: (self bzViaY: index) - yOffset.
		self bezierEndXOf: bezier put: (self bzEndX: index).
		self bezierEndYOf: bezier put: (self bzEndY: index) - yOffset.
	] ifFalse:[
		self edgeXValueOf: bezier put: (self bzEndX: index).
		self edgeYValueOf: bezier put: (self bzEndY: index) - yOffset.
		self bezierViaXOf: bezier put: (self bzViaX: index).
		self bezierViaYOf: bezier put: (self bzViaY: index) - yOffset.
		self bezierEndXOf: bezier put: (self bzStartX: index).
		self bezierEndYOf: bezier put: (self bzStartY: index) - yOffset.
	].
	self edgeZValueOf: bezier put: self currentZGet.
	self edgeLeftFillOf: bezier put: leftFillIndex.
	self edgeRightFillOf: bezier put: rightFillIndex.
	"self debugDrawBezier: bezier."! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:47'!
loadBitmapFill: formOop colormap: cmOop tile: tileFlag from: point1 along: point2 normal: point3 xIndex: xIndex
	"Load the bitmap fill."
	| bmFill cmSize cmBits bmBits bmBitsSize bmWidth bmHeight bmDepth ppw bmRaster |
	<var: #cmBits type: 'int *'>
	<var: #point1 type: 'int *'>
	<var: #point2 type: 'int *'>
	<var: #point3 type: 'int *'>

	cmOop == interpreterProxy nilObject ifTrue:[
		cmSize := 0.
		cmBits := nil.
	] ifFalse:[
		(interpreterProxy fetchClassOf: cmOop) == interpreterProxy classBitmap
			ifFalse:[^interpreterProxy primitiveFail].
		cmSize := interpreterProxy slotSizeOf: cmOop.
		cmBits := interpreterProxy firstIndexableField: cmOop.
	].
	(interpreterProxy isIntegerObject: formOop) 
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isPointers: formOop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: formOop) < 5 
		ifTrue:[^interpreterProxy primitiveFail].
	bmBits := interpreterProxy fetchPointer: 0 ofObject: formOop.
	(interpreterProxy fetchClassOf: bmBits) == interpreterProxy classBitmap
		ifFalse:[^interpreterProxy primitiveFail].
	bmBitsSize := interpreterProxy slotSizeOf: bmBits.
	bmWidth := interpreterProxy fetchInteger: 1 ofObject: formOop.
	bmHeight := interpreterProxy fetchInteger: 2 ofObject: formOop.
	bmDepth := interpreterProxy fetchInteger: 3 ofObject: formOop.
	interpreterProxy failed ifTrue:[^nil].
	(bmWidth >= 0 and:[bmHeight >= 0]) ifFalse:[^interpreterProxy primitiveFail].
	(bmDepth = 32) | (bmDepth = 8) | (bmDepth = 16) | 
		(bmDepth = 1) | (bmDepth = 2) | (bmDepth = 4)
			ifFalse:[^interpreterProxy primitiveFail].
	(cmSize = 0 or:[cmSize = (1 << bmDepth)])
		ifFalse:[^interpreterProxy primitiveFail].
	ppw := 32 // bmDepth.
	bmRaster := bmWidth + (ppw-1) // ppw.
	bmBitsSize = (bmRaster * bmHeight)
		ifFalse:[^interpreterProxy primitiveFail].
	bmFill := self allocateBitmapFill: cmSize colormap: cmBits.
	engineStopped ifTrue:[^nil].
	self bitmapWidthOf: bmFill put: bmWidth.
	self bitmapHeightOf: bmFill put: bmHeight.
	self bitmapDepthOf: bmFill put: bmDepth.
	self bitmapRasterOf: bmFill put: bmRaster.
	self bitmapSizeOf: bmFill put: bmBitsSize.
	self bitmapTileFlagOf: bmFill put: tileFlag.
	self objectIndexOf: bmFill put: xIndex.
	self loadFillOrientation: bmFill
		from: point1 along: point2 normal: point3
		width: bmWidth height: bmHeight.
	^bmFill! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/25/1998 17:25'!
loadBitsFrom: bmFill
	"Note: Assumes that the contents of formArray has been checked before"
	| xIndex formOop bitsOop bitsLen |
	<returnTypeC: 'int *'>
	xIndex := self objectIndexOf: bmFill.
	xIndex > (interpreterProxy slotSizeOf: formArray) ifTrue:[^nil].
	formOop := interpreterProxy fetchPointer: xIndex ofObject: formArray.
	bitsOop := interpreterProxy fetchPointer: 0 ofObject: formOop.
	bitsLen := interpreterProxy slotSizeOf: bitsOop.
	bitsLen = (self bitmapSizeOf: bmFill) ifFalse:[^nil].
	^interpreterProxy firstIndexableField: bitsOop! !
!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar (auto pragmas 12/08) 11/24/1998 21:13'!
loadCompressedSegment: segmentIndex from: points short: pointsShort leftFill: leftFill rightFill: rightFill lineWidth: lineWidth lineColor: lineFill 
	"Load the compressed segment identified by segment index"
	| x0 y0 x1 y1 x2 y2 index segs |
	<inline: true>

	"Check if have anything to do at all"
	(leftFill = rightFill and:[lineWidth = 0 or:[lineFill = 0]]) 
		ifTrue:[^nil]. "Nothing to do"

	index := segmentIndex * 6. "3 points with x/y each"
	pointsShort ifTrue:["Load short points"
		x0 := self loadPointShortAt: (index+0) from: points.
		y0 := self loadPointShortAt: (index+1) from: points.
		x1 := self loadPointShortAt: (index+2) from: points.
		y1 := self loadPointShortAt: (index+3) from: points.
		x2 := self loadPointShortAt: (index+4) from: points.
		y2 := self loadPointShortAt: (index+5) from: points.
	] ifFalse:[
		x0 := self loadPointIntAt: (index+0) from: points.
		y0 := self loadPointIntAt: (index+1) from: points.
		x1 := self loadPointIntAt: (index+2) from: points.
		y1 := self loadPointIntAt: (index+3) from: points.
		x2 := self loadPointIntAt: (index+4) from: points.
		y2 := self loadPointIntAt: (index+5) from: points.
	].
	"Briefly check if can represent the bezier as a line"
	((x0 = x1 and:[y0 = y1]) or:[x1 = x2 and:[y1 = y2]]) ifTrue:[
		"We can use a line from x0/y0 to x2/y2"
		(x0 = x2 and:[y0 = y2]) ifTrue:[^nil]. "Nothing to do"
		"Load and transform points"
		self point1Get at: 0 put: x0.
		self point1Get at: 1 put: y0.
		self point2Get at: 0 put: x2.
		self point2Get at: 1 put: y2.
		self transformPoints: 2.
		^self loadWideLine: lineWidth 
			from: self point1Get
			to: self point2Get
			lineFill: lineFill 
			leftFill: leftFill 
			rightFill: rightFill.
	].
	"Need bezier curve"
	"Load and transform points"
	self point1Get at: 0 put: x0.
	self point1Get at: 1 put: y0.
	self point2Get at: 0 put: x1.
	self point2Get at: 1 put: y1.
	self point3Get at: 0 put: x2.
	self point3Get at: 1 put: y2.
	self transformPoints: 3.
	segs := self loadAndSubdivideBezierFrom: self point1Get 
				via: self point2Get 
				to: self point3Get 
				isWide: (lineWidth ~= 0 and:[lineFill ~= 0]).
	engineStopped ifTrue:[^nil].
	self loadWideBezier: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill n: segs.
! !
!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:48'!
loadCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList pointShort: pointsShort
	"Load a compressed shape into the engine.
		WARNING: THIS METHOD NEEDS THE FULL FRAME SIZE!!!!!!!!
	"
	| leftRun rightRun widthRun lineFillRun
	leftLength rightLength widthLength lineFillLength
	leftValue rightValue widthValue lineFillValue |

	<inline: false>
	<var: #points type: 'int *'>
	<var: #leftFills type: 'int *'>
	<var: #rightFills type: 'int *'>
	<var: #lineWidths type: 'int *'>
	<var: #lineFills type: 'int *'>
	<var: #fillIndexList type: 'int *'>

	nSegments = 0 ifTrue:[^0].

	"Initialize run length encodings"
	leftRun :=  rightRun := widthRun := lineFillRun := -1.
	leftLength := rightLength := widthLength := lineFillLength := 1.
	leftValue := rightValue := widthValue := lineFillValue := 0.

	1 to: nSegments do:[:i|
		"Decrement current run length and load new stuff"
		(leftLength := leftLength - 1) <= 0 ifTrue:[
			leftRun := leftRun + 1.
			leftLength := self shortRunLengthAt: leftRun from: leftFills.
			leftValue := self shortRunValueAt: leftRun from: leftFills.
			leftValue = 0 ifFalse:[
				leftValue := fillIndexList at: leftValue-1.
				leftValue := self transformColor: leftValue.
				engineStopped ifTrue:[^nil]]].
		(rightLength := rightLength - 1) <= 0 ifTrue:[
			rightRun := rightRun + 1.
			rightLength := self shortRunLengthAt: rightRun from: rightFills.
			rightValue := self shortRunValueAt: rightRun from: rightFills.
			rightValue = 0 ifFalse:[
				rightValue := fillIndexList at: rightValue-1.
				rightValue := self transformColor: rightValue]].
		(widthLength := widthLength - 1) <= 0 ifTrue:[
			widthRun := widthRun + 1.
			widthLength := self shortRunLengthAt: widthRun from: lineWidths.
			widthValue := self shortRunValueAt: widthRun from: lineWidths.
			widthValue = 0 ifFalse:[widthValue := self transformWidth: widthValue]].
		(lineFillLength := lineFillLength - 1) <= 0 ifTrue:[
			lineFillRun := lineFillRun + 1.
			lineFillLength := self shortRunLengthAt: lineFillRun from: lineFills.
			lineFillValue := self shortRunValueAt: lineFillRun from: lineFills.
			lineFillValue = 0 ifFalse:[lineFillValue := fillIndexList at: lineFillValue-1]].
		self loadCompressedSegment: i - 1
			from: points 
			short: pointsShort 
			leftFill: leftValue 
			rightFill: rightValue 
			lineWidth: widthValue 
			lineColor: lineFillValue.
		engineStopped ifTrue:[^nil].
	].! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:48'!
loadFillOrientation: fill from: point1 along: point2 normal: point3 width: fillWidth height: fillHeight
	"Transform the points"
	| dirX dirY nrmX nrmY dsLength2 dsX dsY dtLength2 dtX dtY |
	<var: #point1 type: 'int *'>
	<var: #point2 type: 'int *'>
	<var: #point3 type: 'int *'>

	point2 at: 0 put: (point2 at: 0) + (point1 at: 0).
	point2 at: 1 put: (point2 at: 1) + (point1 at: 1).
	point3 at: 0 put: (point3 at: 0) + (point1 at: 0).
	point3 at: 1 put: (point3 at: 1) + (point1 at: 1).
	self transformPoint: point1.
	self transformPoint: point2.
	self transformPoint: point3.
	dirX := (point2 at: 0) - (point1 at: 0).
	dirY := (point2 at: 1) - (point1 at: 1).
	nrmX := (point3 at: 0) - (point1 at: 0).
	nrmY := (point3 at: 1) - (point1 at: 1).

	"Compute the scale from direction/normal into ramp size"
	dsLength2 := (dirX * dirX) + (dirY * dirY).
	dsLength2 > 0 ifTrue:[
		dsX := (dirX asFloat * fillWidth asFloat * 65536.0 / dsLength2 asFloat) asInteger.
		dsY := (dirY asFloat * fillWidth asFloat * 65536.0 / dsLength2 asFloat) asInteger.
	] ifFalse:[ dsX := 0. dsY := 0].
	dtLength2 := (nrmX * nrmX) + (nrmY * nrmY).
	dtLength2 > 0 ifTrue:[
		dtX := (nrmX asFloat * fillHeight asFloat * 65536.0 / dtLength2 asFloat) asInteger.
		dtY := (nrmY asFloat * fillHeight asFloat * 65536.0 / dtLength2 asFloat) asInteger.
	] ifFalse:[dtX := 0. dtY := 0].
	self fillOriginXOf: fill put: (point1 at: 0).
	self fillOriginYOf: fill put: (point1 at: 1).
	self fillDirectionXOf: fill put: dsX.
	self fillDirectionYOf: fill put: dsY.
	self fillNormalXOf: fill put: dtX.
	self fillNormalYOf: fill put: dtY.
! !
!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:50'!
loadGradientFill: rampOop from: point1 along: point2 normal: point3 isRadial: isRadial
	"Load the gradient fill as defined by the color ramp."
	| rampWidth fill |
	<inline: false>
	<var: #point1 type: 'int *'>
	<var: #point2 type: 'int *'>
	<var: #point3 type: 'int *'>
	(interpreterProxy fetchClassOf: rampOop) = interpreterProxy classBitmap
		ifFalse:[^interpreterProxy primitiveFail].
	rampWidth := interpreterProxy slotSizeOf: rampOop.
	fill := self allocateGradientFill: (interpreterProxy firstIndexableField: rampOop)
				rampWidth: rampWidth isRadial: isRadial.
	engineStopped ifTrue:[^nil].
	self loadFillOrientation: fill 
		from: point1 along: point2 normal: point3 
		width: rampWidth height: rampWidth.
	^fill! !
!BalloonEnginePlugin methodsFor: 'lines-loading' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:50'!
loadLine: line from: point1 to: point2 offset: yOffset leftFill: leftFill rightFill: rightFill
	"Load the line defined by point1 and point2."
	| p1 p2 yDir |
	<var: #point1 type: 'int *'>
	<var: #point2 type: 'int *'>
	<var: #p1 type: 'int *'>
	<var: #p2 type: 'int *'>

	(point1 at: 1) <= (point2 at: 1) 
		ifTrue:[	p1 := point1.
				p2 := point2.
				yDir := 1]
		ifFalse:[	p1 := point2.
				p2 := point1.
				yDir := -1].
	self edgeXValueOf: line put: (p1 at: 0).
	self edgeYValueOf: line put: (p1 at: 1) - yOffset.
	self edgeZValueOf: line put: self currentZGet.
	self edgeLeftFillOf: line put: leftFill.
	self edgeRightFillOf: line put: rightFill.
	self lineEndXOf: line put: (p2 at: 0).
	self lineEndYOf: line put: (p2 at: 1) - yOffset.
	self lineYDirectionOf: line put: yDir.! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/25/1998 23:21'!
loadOval: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill
	"Load a rectangular oval currently defined by point1/point2"
	| w h cx cy nSegments |
	<inline: false>
	w := ((self point2Get at: 0) - (self point1Get at: 0)) // 2.
	h := ((self point2Get at: 1) - (self point1Get at: 1)) // 2.
	cx := ((self point2Get at: 0) + (self point1Get at: 0)) // 2.
	cy := ((self point2Get at: 1) + (self point1Get at: 1)) // 2.
	0 to: 15 do:[:i|
		self loadOvalSegment: i w: w h: h cx: cx cy: cy.
		self transformPoints: 3.
		nSegments := self loadAndSubdivideBezierFrom: self point1Get 
							via: self point2Get to: self point3Get
							isWide: (lineWidth ~= 0 and:[lineFill ~= 0]).
		engineStopped ifTrue:[^nil].
		self loadWideBezier: lineWidth lineFill: lineFill 
			leftFill: leftFill rightFill: rightFill n: nSegments.
		engineStopped ifTrue:[^nil].
	].! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:17'!
loadOvalSegment: seg w: w h: h cx: cx cy: cy
	| x0 y0 x2 y2 x1 y1 |
	<inline: false>
	"Load start point of segment"
	x0 := ((self circleCosTable at: seg * 2 + 0) * w asFloat + cx) asInteger.
	y0 := ((self circleSinTable at: seg * 2 + 0) * h asFloat + cy) asInteger.
	self point1Get at: 0 put: x0.
	self point1Get at: 1 put: y0.
	"Load end point of segment"
	x2 := ((self circleCosTable at: seg * 2 + 2) * w asFloat + cx) asInteger.
	y2 := ((self circleSinTable at: seg * 2 + 2) * h asFloat + cy) asInteger.
	self point3Get at: 0 put: x2.
	self point3Get at: 1 put: y2.
	"Load intermediate point of segment"
	x1 := ((self circleCosTable at: seg * 2 + 1) * w asFloat + cx) asInteger.
	y1 := ((self circleSinTable at: seg * 2 + 1) * h asFloat + cy) asInteger.
	"NOTE: The intermediate point is the point ON the curve
	and not yet the control point (which is OFF the curve)"
	x1 := (x1 * 2) - (x0 + x2 // 2).
	y1 := (y1 * 2) - (y0 + y2 // 2).
	self point2Get at: 0 put: x1.
	self point2Get at: 1 put: y1.! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/3/1998 23:24'!
loadPointIntAt: index from: intArray
	"Load the int value from the given index in intArray"
	^(self cCoerce: intArray to: 'int *') at: index! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/3/1998 23:23'!
loadPointShortAt: index from: shortArray
	"Load the short value from the given index in shortArray"
	<returnTypeC: 'short'>
	^(self cCoerce: shortArray to: 'short *') at: index! !
!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:51'!
loadPolygon: points nPoints: nPoints fill: fillIndex lineWidth: lineWidth lineFill: lineFill pointsShort: isShort
	| x0 y0 x1 y1 |
	<var: #points type: 'int *'>
	isShort ifTrue:[
		x0 := self loadPointShortAt: 0 from: points.
		y0 := self loadPointShortAt: 1 from: points.
	] ifFalse:[
		x0 := self loadPointIntAt: 0 from: points.
		y0 := self loadPointIntAt: 1 from: points.
	].
	1 to: nPoints-1 do:[:i|
		isShort ifTrue:[
			x1 := self loadPointShortAt: i*2 from: points.
			y1 := self loadPointShortAt: i*2+1 from: points.
		] ifFalse:[
			x1 := self loadPointIntAt: i*2 from: points.
			y1 := self loadPointIntAt: i*2+1 from: points.
		].
		self point1Get at: 0 put: x0.
		self point1Get at: 1 put: y0.
		self point2Get at: 0 put: x1.
		self point2Get at: 1 put: y1.
		self transformPoints: 2.
		self loadWideLine: lineWidth 
			from: self point1Get
			to: self point2Get
			lineFill: lineFill 
			leftFill: fillIndex
			rightFill: 0.
		engineStopped ifTrue:[^nil].
		x0 := x1.
		y0 := y1.
	].! !
!BalloonEnginePlugin methodsFor: 'lines-loading' stamp: 'ar 11/6/1998 17:07'!
loadRectangle: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill
	"Load a rectangle currently defined by point1-point4"

	self loadWideLine: lineWidth from: self point1Get to: self point2Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
	self loadWideLine: lineWidth from: self point2Get to: self point3Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
	self loadWideLine: lineWidth from: self point3Get to: self point4Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
	self loadWideLine: lineWidth from: self point4Get to: self point1Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
! !
!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:51'!
loadShape: points nSegments: nSegments fill: fillIndex lineWidth: lineWidth lineFill: lineFill  pointsShort: pointsShort
	<inline: false>
	<var: #points type: 'int *'>
	1 to: nSegments do:[:i|
		self loadCompressedSegment: i-1
			from: points
			short: pointsShort
			leftFill: fillIndex
			rightFill: 0
			lineWidth: lineWidth
			lineColor: lineFill.
		engineStopped ifTrue:[^nil].
	].! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/8/1998 03:41'!
loadWideBezier: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill n: nSegments
	"Load the (possibly wide) bezier from the segments currently on the bezier stack."
	| index bezier wide offset |
	<inline: false>
	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[wide := false.
				offset := 0]
		ifFalse:[wide := true.
				offset := self offsetFromWidth: lineWidth].
	index := nSegments * 6.
	[index > 0] whileTrue:[
		wide 
			ifTrue:[bezier := self allocateWideBezier]
			ifFalse:[bezier := self allocateBezier].
		engineStopped ifTrue:[^0].
		self loadBezier: bezier 
			segment: index 
			leftFill: leftFill 
			rightFill: rightFill 
			offset: offset.
		wide ifTrue:[
			self wideBezierFillOf: bezier put: lineFill.
			self wideBezierWidthOf: bezier put: lineWidth.
			self wideBezierExtentOf: bezier put: lineWidth.
		].
		index := index - 6.
	].
	self wbStackClear.! !
!BalloonEnginePlugin methodsFor: 'lines-loading' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:51'!
loadWideLine: lineWidth from: p1 to: p2 lineFill: lineFill leftFill: leftFill rightFill: rightFill
	"Load a (possibly wide) line defined by the points p1 and p2"
	| line offset |
	<var: #p1 type: 'int *'>
	<var: #p2 type: 'int *'>
	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[	line := self allocateLine.
				offset := 0]
		ifFalse:[	line := self allocateWideLine.
				offset := self offsetFromWidth: lineWidth].
	engineStopped ifTrue:[^0].
	self loadLine: line 
		from: p1
		to: p2
		offset: offset 
		leftFill: leftFill
		rightFill: rightFill.
	(self isWide: line) ifTrue:[
		self wideLineFillOf: line put: lineFill.
		self wideLineWidthOf: line put: lineWidth.
		self wideLineExtentOf: line put: lineWidth].! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/1/1998 03:16'!
makeRectFromPoints
	self point2Get at: 0 put: (self point3Get at: 0).
	self point2Get at: 1 put: (self point1Get at: 1).
	self point4Get at: 0 put: (self point1Get at: 0).
	self point4Get at: 1 put: (self point3Get at: 1).! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar (auto pragmas 12/08) 11/6/1998 17:55'!
offsetFromWidth: lineWidth
	"Common function so that we don't compute that wrong in any place
	and can easily find all the places where we deal with one-pixel offsets."
	<inline: true>
	^lineWidth // 2! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:07'!
primitiveAddBezier
	| leftFill rightFill viaOop endOop startOop nSegments |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	rightFill := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	leftFill := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	viaOop := interpreterProxy stackObjectValue: 2.
	endOop := interpreterProxy stackObjectValue: 3.
	startOop := interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: leftFill) and:[self isFillOkay: rightFill])
			ifFalse:[^interpreterProxy primitiveFail].

	"Do a quick check if the fillIndices are equal - if so, just ignore it"
	leftFill = rightFill & false ifTrue:[
		^interpreterProxy pop: 6. "Leave rcvr on stack"
	].


	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point2Get from: viaOop.
	self loadPoint: self point3Get from: endOop.
	interpreterProxy failed ifTrue:[^0].

	self transformPoints: 3.

	nSegments := self loadAndSubdivideBezierFrom: self point1Get 
						via: self point2Get 
						to: self point3Get 
						isWide: false.
	self needAvailableSpace: nSegments * GBBaseSize.
	engineStopped ifFalse:[
		leftFill := self transformColor: leftFill.
		rightFill := self transformColor: rightFill].
	engineStopped ifFalse:[
		self loadWideBezier: 0 lineFill: 0 leftFill: leftFill rightFill: rightFill n: nSegments.
	].
	engineStopped ifTrue:[
		"Make sure the stack is okay"
		self wbStackClear.
		^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 12/5/2003 20:07'!
primitiveAddBezierShape
	| points lineFill lineWidth fillIndex length isArray segSize nSegments |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	lineFill := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	lineWidth := interpreterProxy stackIntegerValue: 1.
	fillIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	nSegments := interpreterProxy stackIntegerValue: 3.
	points := interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"First, do a check if the points look okay"
	length := interpreterProxy slotSizeOf: points.
	(interpreterProxy isWords: points) ifTrue:[
		isArray := false.
		"Either PointArray or ShortPointArray"
		(length = (nSegments * 3) or:[length = (nSegments * 6)])
			ifFalse:[^interpreterProxy primitiveFail].
	] ifFalse:["Must be Array of points"
		(interpreterProxy isArray: points)
			ifFalse:[^interpreterProxy primitiveFail].
		length = (nSegments * 3)
			ifFalse:[^interpreterProxy primitiveFail].
		isArray := true.
	].

	"Now check that we have some hope to have enough free space.
	Do this by assuming nPoints boundaries of maximum size,
	hoping that most of the fills will be colors and many boundaries
	will be line segments"

	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[segSize := GLBaseSize]
		ifFalse:[segSize := GLWideSize].
	(self needAvailableSpace: segSize * nSegments)
		ifFalse:[^interpreterProxy primitiveFail].

	"Check the fills"
	((self isFillOkay: lineFill) and:[self isFillOkay: fillIndex])
		ifFalse:[^interpreterProxy primitiveFail]. 

	"Transform colors"
	lineFill := self transformColor: lineFill.
	fillIndex := self transformColor: fillIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if have anything at all to do"
	((lineFill = 0 or:[lineWidth = 0]) and:[fillIndex = 0])
		ifTrue:[^interpreterProxy pop: 5].

	"Transform the lineWidth"
	lineWidth = 0 ifFalse:[
		lineWidth := self transformWidth: lineWidth.
		lineWidth < 1 ifTrue:[lineWidth := 1]].

	"And load the actual shape"
	isArray ifTrue:[
		self loadArrayShape: points nSegments: nSegments
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill.
	] ifFalse:[
		self loadShape: (interpreterProxy firstIndexableField: points) nSegments: nSegments
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill 
			pointsShort: (nSegments * 3 = length)].

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:10'!
primitiveAddBitmapFill

	| nrmOop dirOop originOop tileFlag fill xIndex cmOop formOop |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 7 
		ifFalse:[^interpreterProxy primitiveFail].

	xIndex := interpreterProxy stackIntegerValue: 0.
	xIndex <= 0 ifTrue:[^interpreterProxy primitiveFail].
	nrmOop := interpreterProxy stackObjectValue: 1.
	dirOop := interpreterProxy stackObjectValue: 2.
	originOop := interpreterProxy stackObjectValue: 3.
	tileFlag := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 4).
	tileFlag ifTrue:[tileFlag := 1] ifFalse:[tileFlag := 0].
	cmOop := interpreterProxy stackObjectValue: 5.
	formOop := interpreterProxy stackObjectValue: 6.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 7) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadPoint: self point1Get from: originOop.
	self loadPoint: self point2Get from: dirOop.
	self loadPoint: self point3Get from: nrmOop.
	interpreterProxy failed ifTrue:[^0].

	fill := self loadBitmapFill: formOop 
				colormap: cmOop
				tile: tileFlag
				from: self point1Get 
				along: self point2Get 
				normal: self point3Get 
				xIndex: xIndex-1.
	engineStopped ifTrue:[
		"Make sure the stack is okay"
		^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 8.
		interpreterProxy push: (interpreterProxy positive32BitIntegerFor: fill).
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:06'!
primitiveAddCompressedShape
	| fillIndexList lineFills lineWidths rightFills leftFills nSegments points pointsShort |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 7 
		ifFalse:[^interpreterProxy primitiveFail].

	fillIndexList := interpreterProxy stackObjectValue: 0.
	lineFills := interpreterProxy stackObjectValue: 1.
	lineWidths := interpreterProxy stackObjectValue: 2.
	rightFills := interpreterProxy stackObjectValue: 3.
	leftFills := interpreterProxy stackObjectValue: 4.
	nSegments := interpreterProxy stackIntegerValue: 5.
	points := interpreterProxy stackObjectValue: 6.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 7) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"First, do a check if the compressed shape is okay"
	(self checkCompressedShape: points 
			segments: nSegments 
			leftFills: leftFills 
			rightFills: rightFills 
			lineWidths: lineWidths 
			lineFills: lineFills 
			fillIndexList: fillIndexList) ifFalse:[^interpreterProxy primitiveFail].

	"Now check that we have some hope to have enough free space.
	Do this by assuming nSegments boundaries of maximum size,
	hoping that most of the fills will be colors and many boundaries
	will be line segments"

	(self needAvailableSpace: (GBBaseSize max: GLBaseSize) * nSegments)
		ifFalse:[^interpreterProxy primitiveFail].

	"Check if the points are short"
	pointsShort := (interpreterProxy slotSizeOf: points) = (nSegments * 3).

	"Then actually load the compressed shape"
	self loadCompressedShape: (interpreterProxy firstIndexableField: points)
			segments: nSegments 
			leftFills: (interpreterProxy firstIndexableField: leftFills)
			rightFills: (interpreterProxy firstIndexableField: rightFills)
			lineWidths: (interpreterProxy firstIndexableField: lineWidths)
			lineFills: (interpreterProxy firstIndexableField: lineFills)
			fillIndexList: (interpreterProxy firstIndexableField: fillIndexList)
			pointShort: pointsShort.

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 7. "Leave rcvr on stack"
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:13'!
primitiveAddGradientFill

	| isRadial nrmOop dirOop originOop rampOop fill |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	isRadial := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	nrmOop := interpreterProxy stackValue: 1.
	dirOop := interpreterProxy stackValue: 2.
	originOop := interpreterProxy stackValue: 3.
	rampOop := interpreterProxy stackValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadPoint: self point1Get from: originOop.
	self loadPoint: self point2Get from: dirOop.
	self loadPoint: self point3Get from: nrmOop.
	interpreterProxy failed ifTrue:[^0].

	fill := self loadGradientFill: rampOop 
				from: self point1Get 
				along: self point2Get 
				normal: self point3Get 
				isRadial: isRadial.
	engineStopped ifTrue:[
		"Make sure the stack is okay"
		^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 6.
		interpreterProxy push: (interpreterProxy positive32BitIntegerFor: fill).
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:08'!
primitiveAddLine
	| leftFill rightFill endOop startOop |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 4 
		ifFalse:[^interpreterProxy primitiveFail].

	rightFill := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	leftFill := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	endOop := interpreterProxy stackObjectValue: 2.
	startOop := interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 4) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: leftFill) and:[self isFillOkay: rightFill])
			ifFalse:[^interpreterProxy primitiveFail].

	"Load the points"
	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point2Get from: endOop.
	interpreterProxy failed ifTrue:[^0].

	"Transform points"
	self transformPoints: 2.

	"Transform colors"
	leftFill := self transformColor: leftFill.
	rightFill := self transformColor: rightFill.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Load line"
	self loadWideLine: 0 from: self point1Get to: self point2Get 
		lineFill: 0 leftFill: leftFill rightFill: rightFill.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 4. "Leave rcvr on stack"
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:12'!
primitiveAddOval
	| fillIndex borderWidth borderIndex endOop startOop |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	borderIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	borderWidth := interpreterProxy stackIntegerValue: 1.
	fillIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	endOop := interpreterProxy stackObjectValue: 3.
	startOop := interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: borderIndex) and:[self isFillOkay: fillIndex])
			ifFalse:[^interpreterProxy primitiveFail].

	"Transform colors"
	fillIndex := self transformColor: fillIndex.
	borderIndex := self transformColor: borderIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if we have anything at all to do"
	(fillIndex = 0 and:[borderIndex = 0 or:[borderWidth <= 0]]) ifTrue:[
		^interpreterProxy pop: 5. "Leave rcvr on stack"
	].

	"Make sure we have some space"
	(self needAvailableSpace: (16 * GBBaseSize)) 
		ifFalse:[^interpreterProxy primitiveFail].

	"Check if we need a border"
	(borderWidth > 0 and:[borderIndex ~= 0]) 
		ifTrue:[borderWidth := self transformWidth: borderWidth]
		ifFalse:[borderWidth := 0].


	"Load the rectangle points"
	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point2Get from: endOop.
	interpreterProxy failed ifTrue:[^0].

	self loadOval: borderWidth lineFill: borderIndex 
		leftFill: 0 rightFill: fillIndex.

	engineStopped ifTrue:[
		self wbStackClear.
		^interpreterProxy primitiveFail.
	].
	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 12/5/2003 20:08'!
primitiveAddPolygon
	| points lineFill lineWidth fillIndex nPoints length isArray segSize |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	lineFill := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	lineWidth := interpreterProxy stackIntegerValue: 1.
	fillIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	nPoints := interpreterProxy stackIntegerValue: 3.
	points := interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"First, do a check if the points look okay"
	length := interpreterProxy slotSizeOf: points.
	(interpreterProxy isWords: points) ifTrue:[
		isArray := false.
		"Either PointArray or ShortPointArray"
		(length = nPoints or:[nPoints * 2 = length])
			ifFalse:[^interpreterProxy primitiveFail].
	] ifFalse:["Must be Array of points"
		(interpreterProxy isArray: points)
			ifFalse:[^interpreterProxy primitiveFail].
		length = nPoints
			ifFalse:[^interpreterProxy primitiveFail].
		isArray := true.
	].

	"Now check that we have some hope to have enough free space.
	Do this by assuming nPoints boundaries of maximum size,
	hoping that most of the fills will be colors and many boundaries
	will be line segments"

	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[segSize := GLBaseSize]
		ifFalse:[segSize := GLWideSize].
	(self needAvailableSpace: segSize * nPoints)
		ifFalse:[^interpreterProxy primitiveFail].

	"Check the fills"
	((self isFillOkay: lineFill) and:[self isFillOkay: fillIndex])
		ifFalse:[^interpreterProxy primitiveFail]. 

	"Transform colors"
	lineFill := self transformColor: lineFill.
	fillIndex := self transformColor: fillIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if have anything at all to do"
	((lineFill = 0 or:[lineWidth = 0]) and:[fillIndex = 0])
		ifTrue:[^interpreterProxy pop: 6].

	"Transform the lineWidth"
	lineWidth = 0 ifFalse:[lineWidth := self transformWidth: lineWidth].

	"And load the actual polygon"
	isArray ifTrue:[
		self loadArrayPolygon: points nPoints: nPoints
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill
	] ifFalse:[
		self loadPolygon: (interpreterProxy firstIndexableField: points) nPoints: nPoints 
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill 
			pointsShort: (nPoints = length)].

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-27) 5/11/2000 23:09'!
primitiveAddRect
	| fillIndex borderWidth borderIndex endOop startOop |
	<export: true>
	<inline: false>

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	borderIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	borderWidth := interpreterProxy stackIntegerValue: 1.
	fillIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	endOop := interpreterProxy stackObjectValue: 3.
	startOop := interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: borderIndex) and:[self isFillOkay: fillIndex])
			ifFalse:[^interpreterProxy primitiveFail].

	"Transform colors"
	borderIndex := self transformColor: borderIndex.
	fillIndex := self transformColor: fillIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if we have anything at all to do"
	(fillIndex = 0 and:[borderIndex = 0 or:[borderWidth = 0]]) ifTrue:[
		^interpreterProxy pop: 5. "Leave rcvr on stack"
	].

	"Make sure we have some space"
	(self needAvailableSpace: (4 * GLBaseSize)) 
		ifFalse:[^interpreterProxy primitiveFail].

	"Check if we need a border"
	(borderWidth > 0 and:[borderIndex ~= 0]) 
		ifTrue:[borderWidth := self transformWidth: borderWidth]
		ifFalse:[borderWidth := 0].

	"Load the rectangle"
	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point3Get from: endOop.
	interpreterProxy failed ifTrue:[^nil].
	self point2Get at: 0 put: (self point3Get at: 0).
	self point2Get at: 1 put: (self point1Get at: 1).
	self point4Get at: 0 put: (self point1Get at: 0).
	self point4Get at: 1 put: (self point3Get at: 1).
	"Transform the points"
	self transformPoints: 4.

	self loadRectangle: borderWidth lineFill: borderIndex leftFill: 0 rightFill: fillIndex.

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !
!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:51'!
primitiveGetBezierStats
	| statOop stats |
	<export: true>
	<inline: false>
	<var: #stats type: 'int *'>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	statOop := interpreterProxy stackObjectValue: 0.
	engine := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: statOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: statOop) < 4
		ifTrue:[^interpreterProxy primitiveFail].
	stats := interpreterProxy firstIndexableField: statOop.
	stats at: 0 put: (stats at: 0) + (workBuffer at: GWBezierMonotonSubdivisions).
	stats at: 1 put: (stats at: 1) + (workBuffer at: GWBezierHeightSubdivisions).
	stats at: 2 put: (stats at: 2) + (workBuffer at: GWBezierOverflowSubdivisions).
	stats at: 3 put: (stats at: 3) + (workBuffer at: GWBezierLineConversions).

	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar (auto pragmas dtl 2010-09-27) 11/25/1998 19:27'!
rShiftTable
	| theTable |
	<returnTypeC: 'int *'>
	<inline: false>
	<var: #theTable declareC: 'static int theTable[17] =
		{0, 5, 4, 0, 3, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 1}'>
	^theTable! !
!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar (auto pragmas 12/08) 11/27/1998 14:14'!
repeatValue: delta max: maxValue
	| newDelta |
	<inline: true>
	newDelta := delta.
	[newDelta < 0] whileTrue:[newDelta := newDelta + maxValue].
	[newDelta >= maxValue] whileTrue:[newDelta := newDelta - maxValue].
	^newDelta! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/6/1998 01:54'!
returnWideBezierFill
	^(dispatchReturnValue := self wideBezierFillOf: dispatchedValue).! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/6/1998 01:54'!
returnWideBezierWidth
	^(dispatchReturnValue := self wideBezierWidthOf: dispatchedValue).! !
!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/6/1998 17:08'!
returnWideLineFill
	"Return the fill of the (wide) line - this method is called from a case."
	^(dispatchReturnValue := self wideLineFillOf: dispatchedValue).! !
!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/6/1998 17:08'!
returnWideLineWidth
	"Return the width of the (wide) line - this method is called from a case."
	^(dispatchReturnValue := self wideLineWidthOf: dispatchedValue).! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'eem 5/20/2010 15:05'!
shortRunLengthAt: i from: runArray
	"Return the run-length value from the given ShortRunArray."
	^((self cCoerce: runArray to:'int *') at: i) bitShift: -16! !
!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/3/1998 22:54'!
shortRunValueAt: i from: runArray
	"Return the run-length value from the given ShortRunArray.
	Note: We don't need any coercion to short/int here, since
	we deal basically only with unsigned values."
	^(((self cCoerce: runArray to:'int *') at: i) bitAnd: 16rFFFF)! !
!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar (auto pragmas 12/08) 11/6/1998 00:07'!
stepToFirstBezier
	"Initialize the current entry in the GET by stepping to the current scan line"
	<inline: true>
	^self stepToFirstBezierIn: (getBuffer at: self getStartGet) at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 15:52'!
stepToFirstBezierIn: bezier at: yValue
	"Initialize the bezier at yValue.
	TODO: Check if reducing maxSteps from 2*deltaY to deltaY 
		brings a *significant* performance improvement.
		In theory this should make for double step performance
		but will cost in quality. Might be that the AA stuff will
		compensate for this - but I'm not really sure."
	| updateData deltaY maxSteps scaledStepSize squaredStepSize 
	startX startY viaX viaY endX endY 
	fwX1 fwX2 fwY1 fwY2 
	fwDx fwDDx fwDy fwDDy |
	<inline: false>
	<var: #updateData type: 'int *'>


	"Do a quick check if there is anything at all to do"
	((self isWide: bezier) not and:[yValue >= (self bezierEndYOf: bezier)])
		ifTrue:[^self edgeNumLinesOf: bezier put: 0].

	"Now really initialize bezier"
	startX := self edgeXValueOf: bezier.
	startY := self edgeYValueOf: bezier.
	viaX := self bezierViaXOf: bezier.
	viaY := self bezierViaYOf: bezier.
	endX := self bezierEndXOf: bezier.
	endY := self bezierEndYOf: bezier.
	deltaY := endY - startY.

	"Initialize integer forward differencing"
	fwX1 := (viaX - startX) * 2.
	fwX2 := startX + endX - (viaX * 2).
	fwY1 := (viaY - startY) * 2.
	fwY2 := startY + endY - (viaY * 2).
	maxSteps := deltaY * 2.
	maxSteps < 2 ifTrue:[maxSteps := 2].
	scaledStepSize := 16r1000000 // maxSteps.
	squaredStepSize := self absoluteSquared8Dot24: scaledStepSize.
	fwDx := fwX1 * scaledStepSize.
	fwDDx := fwX2 * squaredStepSize * 2.
	fwDx := fwDx + (fwDDx // 2).
	fwDy := fwY1 * scaledStepSize.
	fwDDy := fwY2 * squaredStepSize * 2.
	fwDy := fwDy + (fwDDy // 2).

	"Store the values"
	self edgeNumLinesOf: bezier put: deltaY.

	updateData := self bezierUpdateDataOf: bezier.
	updateData at: GBUpdateX put: (startX * 256).
	updateData at: GBUpdateY put: (startY * 256).
	updateData at: GBUpdateDX put: fwDx.
	updateData at: GBUpdateDY put: fwDy.
	updateData at: GBUpdateDDX put: fwDDx.
	updateData at: GBUpdateDDY put: fwDDy.

	"And step to the first scan line"
	(startY := self edgeYValueOf: bezier) = yValue ifFalse:[
		self stepToNextBezierIn: bezier at: yValue.
		"Adjust number of lines remaining"
		self edgeNumLinesOf: bezier put: deltaY - (yValue - startY).
	].! !
!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar (auto pragmas 12/08) 11/4/1998 21:52'!
stepToFirstLine
	"Initialize the current entry in the GET by stepping to the current scan line"
	<inline: true>
	^self stepToFirstLineIn: (getBuffer at: self getStartGet) at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:38'!
stepToFirstLineIn: line at: yValue
	"Initialize the line at yValue"
	| deltaX deltaY xDir widthX error xInc errorAdjUp startY |
	<inline: false>

	"Do a quick check if there is anything at all to do"
	((self isWide: line) not and:[yValue >= (self lineEndYOf: line)])
		ifTrue:[^self edgeNumLinesOf: line put: 0].

	deltaX := (self lineEndXOf: line) - (self edgeXValueOf: line).
	deltaY := (self lineEndYOf: line) - (self edgeYValueOf: line).

	"Check if edge goes left to right"
	deltaX >= 0 
		ifTrue:[	xDir := 1.
				widthX := deltaX.
				error := 0]
		ifFalse:[	xDir := -1.
				widthX := 0 - deltaX.
				error := 1 - deltaY].

	"Check if deltaY is zero.
	Note: We could actually get out here immediately 
	but wide lines rely on an accurate setup in this case"
	deltaY = 0
		ifTrue:[	error := 0.			"No error for horizontal edges"
				xInc := deltaX.		"Encodes width and direction"
				errorAdjUp := 0]
		ifFalse:["Check if edge is y-major"
				deltaY > widthX "Note: The '>' instead of '>=' could be important here..."
					ifTrue:[	xInc := 0.
							errorAdjUp := widthX]
					ifFalse:[	xInc := (widthX // deltaY) * xDir.
							errorAdjUp := widthX \\ deltaY]].

	"Store the values"
	self edgeNumLinesOf: line put: deltaY.
	self lineXDirectionOf: line put: xDir.
	"self lineYDirectionOf: line put: yDir." "<-- Already set"
	self lineXIncrementOf: line put: xInc.
	self lineErrorOf: line put: error.
	self lineErrorAdjUpOf: line put: errorAdjUp.
	self lineErrorAdjDownOf: line put: deltaY.

	"And step to the first scan line"
	(startY := self edgeYValueOf: line) = yValue ifFalse:[
		startY to: yValue-1 do:[:i| self stepToNextLineIn: line at: i].
		"Adjust number of lines remaining"
		self edgeNumLinesOf: line put: deltaY - (yValue - startY).
	].! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar (auto pragmas 12/08) 11/6/1998 02:00'!
stepToFirstWideBezier
	"Initialize the current entry in the GET by stepping to the current scan line"
	<inline: true>
	^self stepToFirstWideBezierIn: (getBuffer at: self getStartGet) at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:38'!
stepToFirstWideBezierIn: bezier at: yValue
	"Initialize the bezier at yValue"	
	| lineWidth startY nLines yEntry yExit lineOffset endX xDir |
	<inline: false>

	"Get some values"
	lineWidth := self wideBezierExtentOf: bezier.
	lineOffset := self offsetFromWidth: lineWidth.

	"Compute the incremental values of the bezier"
	endX := self bezierEndXOf: bezier.
	startY := self edgeYValueOf: bezier.
	self stepToFirstBezierIn: bezier at: startY.
	nLines := (self edgeNumLinesOf: bezier).

	"Copy the incremental update data"
	0 to: 5 do:[:i|
		(self wideBezierUpdateDataOf: bezier) at: i put:
			((self bezierUpdateDataOf: bezier) at: i).
	].

	"Compute primary x direction of curve (e.g., 1: left to right; -1: right to left)."
	xDir := ((self bezierUpdateDataOf: bezier) at: GBUpdateDX).
	xDir = 0 ifTrue:[((self bezierUpdateDataOf: bezier) at: GBUpdateDDX)].
	xDir >= 0 ifTrue:[xDir := 1] ifFalse:[xDir := -1].

	"Adjust the curve to start/end at the right position"
	xDir < 0
		ifTrue:[self adjustWideBezierLeft: bezier width: lineWidth offset: lineOffset endX: endX]
		ifFalse:[self adjustWideBezierRight: bezier width: lineWidth offset: lineOffset endX: endX].

	"Adjust the last value for horizontal lines"
	nLines = 0 ifTrue:[(self bezierUpdateDataOf: bezier) at: GBUpdateX put: 
						(self bezierFinalXOf: bezier) * 256].
	"Adjust the number of lines to include the lineWidth"
	self edgeNumLinesOf: bezier put: nLines + lineWidth.

	"Compute the points where we have to turn on/off the fills"
	yEntry := 0.						"turned on at lineOffset"
	yExit := 0 - nLines - lineOffset.	"turned off at zero"
	self wideBezierEntryOf: bezier put: yEntry.
	self wideBezierExitOf: bezier put: yExit.

	"Turn the fills on/off as necessary"
	(yEntry >= lineOffset and:[yExit < 0])
		ifTrue:[self edgeFillsValidate: bezier]
		ifFalse:[self edgeFillsInvalidate: bezier].

	self computeFinalWideBezierValues: bezier width: lineWidth.

	"And step to the first scan line"
	startY = yValue ifFalse:[
		"Note: Must single step here so that entry/exit works"
		startY to: yValue-1 do:[:i| self stepToNextWideBezierIn: bezier at: i].
		"Adjust number of lines remaining"
		self edgeNumLinesOf: bezier put: (self edgeNumLinesOf: bezier) - (yValue - startY).
	].! !
!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar (auto pragmas 12/08) 11/4/1998 21:54'!
stepToFirstWideLine
	"Initialize the current entry in the GET by stepping to the current scan line"
	<inline: true>
	^self stepToFirstWideLineIn: (getBuffer at: self getStartGet) at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:38'!
stepToFirstWideLineIn: line at: yValue
	"Initialize the wide line at yValue."
	| startY yEntry yExit lineWidth nLines lineOffset startX xDir |
	<inline: false>

	"Get some values"
	lineWidth := self wideLineExtentOf: line.
	lineOffset := self offsetFromWidth: lineWidth.

	"Compute the incremental values of the line"
	startX := self edgeXValueOf: line.
	startY := self edgeYValueOf: line.
	self stepToFirstLineIn: line at: startY.
	nLines := (self edgeNumLinesOf: line).
	xDir := self lineXDirectionOf: line.

	"Adjust the line to start at the correct X position"
	self edgeXValueOf: line put: startX - lineOffset.

	"Adjust the number of lines to include the lineWidth"
	self edgeNumLinesOf: line put: nLines + lineWidth.

	"Adjust the values for x-major lines"
	xDir > 0 ifTrue:[
		self wideLineWidthOf: line put: (self lineXIncrementOf: line) + lineWidth.
	] ifFalse:[
		self wideLineWidthOf: line put: lineWidth - (self lineXIncrementOf: line). "adding"
		self edgeXValueOf: line put: (self edgeXValueOf: line) + (self lineXIncrementOf: line).
	].

	"Compute the points where we have to turn on/off the fills"
	yEntry := 0.						"turned on at lineOffset"
	yExit := 0 - nLines - lineOffset.	"turned off at zero"
	self wideLineEntryOf: line put: yEntry.
	self wideLineExitOf: line put: yExit.

	"Turn the fills on/off as necessary"
	(yEntry >= lineOffset and:[yExit < 0])
		ifTrue:[self edgeFillsValidate: line]
		ifFalse:[self edgeFillsInvalidate: line].

	"And step to the first scan line"
	startY = yValue ifFalse:[
		startY to: yValue-1 do:[:i| self stepToNextWideLineIn: line at: i].
		"Adjust number of lines remaining"
		self edgeNumLinesOf: line put: (self edgeNumLinesOf: line) - (yValue - startY).
	].
! !
!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar (auto pragmas 12/08) 11/6/1998 00:08'!
stepToNextBezier
	"Process the current entry in the AET by stepping to the next scan line"
	<inline: true>
	^self stepToNextBezierIn: (aetBuffer at: self aetStartGet) at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar (auto pragmas 12/08) 11/9/1998 01:49'!
stepToNextBezierForward: updateData at: yValue
	"Incrementally step to the next scan line in the given bezier update data.
	Note: This method has been written so that inlining works, e.g.,
		not declaring updateData as 'int*' but casting it on every use."
	| minY lastX lastY fwDx fwDy |
	<inline: true>
	lastX := (self cCoerce: updateData to: 'int*') at: GBUpdateX.
	lastY := (self cCoerce: updateData to: 'int*') at: GBUpdateY.
	fwDx := (self cCoerce: updateData to: 'int*') at: GBUpdateDX.
	fwDy := (self cCoerce: updateData to: 'int*') at: GBUpdateDY.
	minY := yValue * 256.
	"Step as long as we haven't yet reached minY and also
	as long as fwDy is greater than zero thus stepping down.
	Note: The test for fwDy should not be necessary in theory
		but is a good insurance in practice."
	[minY > lastY and:[fwDy >= 0]] whileTrue:[
		lastX := lastX + ((fwDx + 16r8000) // 16r10000).
		lastY := lastY + ((fwDy + 16r8000) // 16r10000).
		fwDx := fwDx + ((self cCoerce: updateData to: 'int*') at: GBUpdateDDX).
		fwDy := fwDy + ((self cCoerce: updateData to: 'int*') at: GBUpdateDDY).
	].
	(self cCoerce: updateData to: 'int*') at: GBUpdateX put: lastX.
	(self cCoerce: updateData to: 'int*') at: GBUpdateY put: lastY.
	(self cCoerce: updateData to: 'int*') at: GBUpdateDX put: fwDx.
	(self cCoerce: updateData to: 'int*') at: GBUpdateDY put: fwDy.
	^lastX // 256
! !
!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:39'!
stepToNextBezierIn: bezier at: yValue
	"Incrementally step to the next scan line in the given bezier"
	|  xValue |
	<inline: true>
	xValue := self stepToNextBezierForward: (self bezierUpdateDataOf: bezier) at: yValue.
	self edgeXValueOf: bezier put: xValue.! !
!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar (auto pragmas 12/08) 11/4/1998 21:53'!
stepToNextLine
	"Process the current entry in the AET by stepping to the next scan line"
	<inline: true>
	^self stepToNextLineIn: (aetBuffer at: self aetStartGet) at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:39'!
stepToNextLineIn: line at: yValue
	"Incrementally step to the next scan line in the given line"
	| x  err |
	<inline: true>
	x := (self edgeXValueOf: line) + (self lineXIncrementOf: line).
	err := (self lineErrorOf: line) + (self lineErrorAdjUpOf: line).
	err > 0 ifTrue:[
		x := x + (self lineXDirectionOf: line).
		err := err - (self lineErrorAdjDownOf: line).
	].
	self lineErrorOf: line put: err.
	self edgeXValueOf: line put: x.! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar (auto pragmas 12/08) 11/6/1998 02:34'!
stepToNextWideBezier
	"Initialize the current entry in the GET by stepping to the current scan line"
	<inline: true>
	self stepToNextWideBezierIn: (aetBuffer at: self aetStartGet) at: self currentYGet.! !
!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:39'!
stepToNextWideBezierIn: bezier at: yValue
	"Incrementally step to the next scan line in the given wide bezier"
	|  yEntry yExit lineWidth lineOffset |
	<inline: false>	"Don't inline this"

	lineWidth := self wideBezierExtentOf: bezier.
	lineOffset := self offsetFromWidth: lineWidth.

	yEntry := (self wideBezierEntryOf: bezier) + 1.
	yExit := (self wideBezierExitOf: bezier) + 1.
	self wideBezierEntryOf: bezier put: yEntry.
	self wideBezierExitOf: bezier put: yExit.
	yEntry >= lineOffset ifTrue:[self edgeFillsValidate: bezier].
	yExit >= 0 ifTrue:[self edgeFillsInvalidate: bezier].

	"Check if we have to step the upper curve"
	(yExit + lineOffset < 0) ifTrue:[
		self stepToNextBezierForward: (self bezierUpdateDataOf: bezier) at: yValue.
	] ifFalse:[
		"Adjust the last x value to the final x recorded previously"
		(self bezierUpdateDataOf: bezier) at: GBUpdateX put: (self bezierFinalXOf: bezier) * 256.
	].
	"Step the lower curve"
	self stepToNextBezierForward: (self wideBezierUpdateDataOf: bezier) at: yValue.

	self computeFinalWideBezierValues: bezier width: lineWidth.! !
!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar (auto pragmas 12/08) 11/4/1998 21:55'!
stepToNextWideLine
	"Process the current entry in the AET by stepping to the next scan line"
	<inline: true>
	^self stepToNextWideLineIn: (aetBuffer at: self aetStartGet) at: self currentYGet! !
!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar (auto pragmas 12/08) 11/9/1998 15:39'!
stepToNextWideLineIn: line at: yValue
	"Incrementally step to the next scan line in the given wide line"
	|  yEntry yExit lineWidth lineOffset lastX nextX |
	<inline: true>

	"Adjust entry/exit values"
	yEntry := (self wideLineEntryOf: line) + 1.
	yExit := (self wideLineExitOf: line) + 1.
	self wideLineEntryOf: line put: yEntry.
	self wideLineExitOf: line put: yExit.

	"Turn fills on/off"
	lineWidth := self wideLineExtentOf: line.
	lineOffset := self offsetFromWidth: lineWidth.
	yEntry >= lineOffset ifTrue:[self edgeFillsValidate: line].
	yExit >= 0 ifTrue:[self edgeFillsInvalidate: line].

	"Step to the next scan line"
	lastX := self edgeXValueOf: line.
	self stepToNextLineIn: line at: yValue.
	nextX := self edgeXValueOf: line.

	"Check for special start/end adjustments"
	(yEntry <= lineWidth or:[yExit+lineOffset >= 0]) ifTrue:[
		"Yes, need an update"
		self adjustWideLine: line afterSteppingFrom: lastX to: nextX.
	].! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/8/1998 14:36'!
subdivideBezier: index
	"Subdivide the given bezier curve if necessary"
	| startX startY endX endY deltaX deltaY |
	<inline: false>
	startY := self bzStartY: index.
	endY := self bzEndY: index.

	"If the receiver is horizontal, don't do anything"
	(endY = startY) ifTrue:[^index].

	"TODO: If the curve can be represented as a line, then do so"

	"If the height of the curve exceeds 256 pixels, subdivide 
	(forward differencing is numerically not very stable)"
	deltaY := endY - startY.
	deltaY < 0 ifTrue:[deltaY := 0 - deltaY].
	(deltaY > 255) ifTrue:[
		self incrementStat: GWBezierHeightSubdivisions by: 1.
		^self computeBezierSplitAtHalf: index].

	"Check if the incremental values could possibly overflow the scaled integer range"
	startX := self bzStartX: index.
	endX := self bzEndX: index.
	deltaX := endX - startX.
	deltaX < 0 ifTrue:[deltaX := 0 - deltaX].
	deltaY * 32 < deltaX ifTrue:[
		self incrementStat: GWBezierOverflowSubdivisions by: 1.
		^self computeBezierSplitAtHalf: index].
	^index
! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/8/1998 03:43'!
subdivideBezierFrom: index
	"Recursively subdivide the curve on the bezier stack."
	| otherIndex index1 index2 |
	<inline: false>
	otherIndex := self subdivideBezier: index.
	otherIndex = index ifFalse:[
		index1 := self subdivideBezierFrom: index.
		engineStopped ifTrue:[^0].
		index2 := self subdivideBezierFrom: otherIndex.
		engineStopped ifTrue:[^0].
		index1 >= index2
			ifTrue:[^index1]
			ifFalse:[^index2]
	].
	^index! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/8/1998 15:17'!
subdivideToBeMonoton: base inX: doTestX
	"Check if the given bezier curve is monoton in Y, and, if desired in X. 
	If not, subdivide it"
	| index1 index2 base2 |
	<inline: false>
	base2 := index1 := index2 := self subdivideToBeMonotonInY: base.
	doTestX ifTrue:[index1 := self subdivideToBeMonotonInX: base].
	index1 > index2 ifTrue:[index2 := index1].
	(base ~= base2 and:[doTestX]) ifTrue:[index1 := self subdivideToBeMonotonInX: base2].
	index1 > index2 ifTrue:[index2 := index1].
	^index2! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/7/1998 19:42'!
subdivideToBeMonotonInX: index
	"Check if the given bezier curve is monoton in X. If not, subdivide it"
	| denom num startX viaX endX dx1 dx2 |
	<inline: false>
	startX := self bzStartX: index.
	viaX := self bzViaX: index.
	endX := self bzEndX: index.

	dx1 := viaX - startX.
	dx2 := endX - viaX.
	(dx1 * dx2) >= 0 ifTrue:[^index]. "Bezier is monoton"

	self incrementStat: GWBezierMonotonSubdivisions by: 1.
	"Compute split value"
	denom := dx2 - dx1.
	num := dx1.
	num < 0 ifTrue:[num := 0 - num].
	denom < 0 ifTrue:[denom := 0 - denom].
	^self computeBezier: index splitAt: (num asFloat / denom asFloat).! !
!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar (auto pragmas 12/08) 11/7/1998 19:42'!
subdivideToBeMonotonInY: index
	"Check if the given bezier curve is monoton in Y. If not, subdivide it"
	| startY viaY endY dy1 dy2 denom num |
	<inline: false>
	startY := self bzStartY: index.
	viaY := self bzViaY: index.
	endY := self bzEndY: index.

	dy1 := viaY - startY.
	dy2 := endY - viaY.
	(dy1 * dy2) >= 0 ifTrue:[^index]. "Bezier is monoton"

	self incrementStat: GWBezierMonotonSubdivisions by: 1.
	"Compute split value"
	denom := dy2 - dy1.
	num := dy1.
	num < 0 ifTrue:[num := 0 - num].
	denom < 0 ifTrue:[denom := 0 - denom].
	^self computeBezier: index splitAt: (num asFloat / denom asFloat).! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierEntryOf: line

	^self obj: line at: GBWideEntry! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierEntryOf: line put: value

	^self obj: line at: GBWideEntry put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierExitOf: line

	^self obj: line at: GBWideExit! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierExitOf: line put: value

	^self obj: line at: GBWideExit put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierExtentOf: bezier

	^self obj: bezier at: GBWideExtent! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierExtentOf: bezier put: value

	^self obj: bezier at: GBWideExtent put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:19'!
wideBezierFillOf: bezier

	^self obj: bezier at: GBWideFill! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
wideBezierFillOf: bezier put: value

	^self obj: bezier at: GBWideFill put: value! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar (auto pragmas 12/08) 11/24/1998 22:25'!
wideBezierUpdateDataOf: bezier
	<returnTypeC: 'int *'>

	^objBuffer + bezier +  GBWideUpdateData! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierWidthOf: line

	^self obj: line at: GBWideWidth! !
!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierWidthOf: line put: value

	^self obj: line at: GBWideWidth put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
wideLineEntryOf: line

	^self obj: line at: GLWideEntry! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineEntryOf: line put: value

	^self obj: line at: GLWideEntry put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExitOf: line

	^self obj: line at: GLWideExit! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExitOf: line put: value

	^self obj: line at: GLWideExit put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExtentOf: line

	^self obj: line at: GLWideExtent! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExtentOf: line put: value

	^self obj: line at: GLWideExtent put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineFillOf: line

	^self obj: line at: GLWideFill! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:11'!
wideLineFillOf: line put: value

	^self obj: line at: GLWideFill put: value! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:11'!
wideLineWidthOf: line

	^self obj: line at: GLWideWidth! !
!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:11'!
wideLineWidthOf: line put: value

	^self obj: line at: GLWideWidth put: value! !

BalloonEnginePlugin subclass: #BalloonEngineSimulation
	instanceVariableNames: 'bbObj workBufferArray'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!BalloonEngineSimulation commentStamp: 'tpr 5/5/2003 11:48' prior: 0!
Support for the VM simulator Balloon graphics calls!
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/28/1998 20:46'!
assert: bool
	bool ifFalse:[^self error:'Assertion failed'].! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/9/1998 01:23'!
circleCosTable
	^CArrayAccessor on:
#(1.0 0.98078528040323 0.923879532511287 0.831469612302545 0.7071067811865475 0.555570233019602 0.38268343236509 0.1950903220161286 0.0 -0.1950903220161283 -0.3826834323650896 -0.555570233019602 -0.707106781186547 -0.831469612302545 -0.9238795325112865 -0.98078528040323 -1.0 -0.98078528040323 -0.923879532511287 -0.831469612302545 -0.707106781186548 -0.555570233019602 -0.3826834323650903 -0.1950903220161287 0.0 0.1950903220161282 0.38268343236509 0.555570233019602 0.707106781186547 0.831469612302545 0.9238795325112865 0.98078528040323 1.0 )! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/9/1998 01:23'!
circleSinTable
	^CArrayAccessor on:
#(0.0 0.1950903220161282 0.3826834323650897 0.555570233019602 0.707106781186547 0.831469612302545 0.923879532511287 0.98078528040323 1.0 0.98078528040323 0.923879532511287 0.831469612302545 0.7071067811865475 0.555570233019602 0.38268343236509 0.1950903220161286 0.0 -0.1950903220161283 -0.3826834323650896 -0.555570233019602 -0.707106781186547 -0.831469612302545 -0.9238795325112865 -0.98078528040323 -1.0 -0.98078528040323 -0.923879532511287 -0.831469612302545 -0.707106781186548 -0.555570233019602 -0.3826834323650903 -0.1950903220161287 0.0 )! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/24/1998 20:50'!
colorTransform
	^super colorTransform asPluggableAccessor:
		(Array 
			with:[:obj :index| obj floatAt: index]
			with:[:obj :index :value| obj floatAt: index put: value])! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/13/2004 16:42'!
copyBitsFrom: x0 to: x1 at: y
	"Simulate the copyBits primitive"

	| bb |
	bbObj isInteger ifTrue:
		["Create a proxy object to handle BitBlt calls"
		bb := BitBltSimulator new.
		bb initialiseModule.
		bb setInterpreter: interpreterProxy.
		(bb loadBitBltFrom: bbObj)
			ifTrue: [bbObj := bb]
			ifFalse: [^ self]].
	bbObj copyBitsFrom: x0 to: x1 at: y.
"
	interpreterProxy showDisplayBits: bbObj destForm
		Left: bb affectedLeft Top: bb affectedTop
		Right: bb affectedRight Bottom: bb affectedBottom.
"! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawBezier: line
	| canvas p1 p2 p3 |
	self assert:(self isBezier: line).
	p1 := (self edgeXValueOf: line) @ (self edgeYValueOf: line) // self aaLevelGet.
	p2 := (self bezierViaXOf: line) @ (self bezierViaYOf: line) // self aaLevelGet.
	p3 := (self bezierEndXOf: line) @ (self bezierEndYOf: line) // self aaLevelGet.
	canvas := Display getCanvas.
	canvas
		line: p1 to: p2 width: 2 color: Color blue;
		line: p2 to: p3 width: 2 color: Color blue.! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/1/1998 01:16'!
debugDrawEdge: edge
	self assert: (self isEdge: edge).
	(self isLine: edge) ifTrue:[^self debugDrawLine: edge].
	(self isBezier: edge) ifTrue:[^self debugDrawBezier: edge].
	self halt.! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawHLine: yValue
	| canvas |
	canvas := Display getCanvas.
	canvas
		line: 0 @ (yValue // self aaLevelGet)
		to: Display extent x @ (yValue // self aaLevelGet)
		width: 2
		color: Color green.! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawLine: line
	| canvas |
	self assert: (self isLine: line).
	canvas := Display getCanvas.
	canvas
		line: (self edgeXValueOf: line) @ (self edgeYValueOf: line) // self aaLevelGet
		to: (self lineEndXOf: line) @ (self lineEndYOf: line) // self aaLevelGet
		width: 2
		color: Color red.! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawLineFrom: pt1 to: pt2
	| canvas |
	canvas := Display getCanvas.
	canvas
		line: (pt1 at: 0) @ (pt1 at: 1) // self aaLevelGet
		to: (pt2 at: 0) @ (pt2 at: 1) // self aaLevelGet
		width: 1
		color: Color red.! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawPt: pt
	| canvas |
	canvas := Display getCanvas.
	canvas
		fillRectangle:((pt-2) corner: pt+2) color: Color red! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawPtLineFrom: pt1 to: pt2
	| canvas |
	canvas := Display getCanvas.
	canvas
		line: pt1
		to: pt2
		width: 1
		color: Color red.! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar (auto pragmas 12/08) 11/25/1998 00:43'!
debugPrintObjects
	| object end |
	<inline: false>
	object := 0.
	end := objUsed.
	[object < end] whileTrue:[
		Transcript cr; 
			nextPut:$#; print: object; space;
			print: (self objectHeaderOf: object); space.
		(self isEdge: object) 
			ifTrue:[Transcript nextPutAll:'(edge) '].
		(self isFill:object)
			ifTrue:[Transcript nextPutAll:'(fill) '].
		Transcript print: (self objectLengthOf: object); space.
		Transcript endEntry.
		object := object + (self objectLengthOf: object).
	].! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/1/1998 17:21'!
debugPrintPoints: n
	Transcript cr.
	n > 0 ifTrue:[
		Transcript print: (self point1Get at: 0) @ (self point1Get at: 1); space.
	].
	n > 1 ifTrue:[
		Transcript print: (self point2Get at: 0) @ (self point2Get at: 1); space.
	].
	n > 2 ifTrue:[
		Transcript print: (self point3Get at: 0) @ (self point3Get at: 1); space.
	].
	n > 3 ifTrue:[
		Transcript print: (self point4Get at: 0) @ (self point4Get at: 1); space.
	].
	Transcript endEntry.! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/29/1998 18:44'!
dispatchOn: anInteger in: selectorArray
	"Simulate a case statement via selector table lookup.
	The given integer must be between 0 and selectorArray size-1, inclusive.
	For speed, no range test is done, since it is done by the at: operation."
	self perform: (selectorArray at: (anInteger + 1)).! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/24/1998 20:50'!
edgeTransform
	^super edgeTransform asPluggableAccessor:
		(Array 
			with:[:obj :index| obj floatAt: index]
			with:[:obj :index :value| obj floatAt: index put: value])! !
!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/12/2004 15:54'!
initialiseModule
	super initialiseModule.
	^ true! !
!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'tpr 4/2/2004 18:06'!
initialize
	doProfileStats := false.
	bbPluginName := 'BitBltPlugin'! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/29/1998 19:19'!
ioMicroMSecs
	^Time millisecondClockValue! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/28/1998 01:05'!
loadBitBltFrom: oop
	bbObj := oop.
	^true! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/4/1998 14:05'!
loadPointIntAt: index from: intArray
	"Load the int value from the given index in intArray"
	^(index bitAnd: 1) = 0
		ifTrue:[(intArray getObject at: (index // 2) + 1) x]
		ifFalse:[(intArray getObject at: (index // 2) + 1) y]! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 15:07'!
loadPointShortAt: index from: intArray
	"Load the short value from the given index in intArray"

	| long |
	long := intArray at: index // 2.
	^ ((index bitAnd: 1) = 0
		ifTrue:[interpreterProxy halfWordHighInLong32: long]
		ifFalse:[interpreterProxy halfWordLowInLong32: long])
		signedIntFromShort
! !
!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/15/2004 16:19'!
loadWordTransformFrom: transformOop into: destPtr length: n
	"Load a float array transformation from the given oop"

	| srcPtr wordDestPtr |

true ifTrue:
[^ super loadWordTransformFrom: transformOop into: destPtr length: n].

	srcPtr := interpreterProxy firstIndexableField: transformOop.
	wordDestPtr := destPtr as: CArrayAccessor.  "Remove float conversion shell"
	0 to: n-1 do: [:i | wordDestPtr at: i put: (srcPtr at: i)].! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/28/1998 01:05'!
makeUnsignedFrom: integer
	integer < 0 
		ifTrue:[^(0 - integer - 1) bitInvert32]
		ifFalse:[^integer]! !
!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/16/2004 12:06'!
primitiveInitializeBuffer

	"Fix an uninitialized variable (should probably go into the real engine too)"
	super primitiveInitializeBuffer.
	self spanEndAAPut: 0.! !
!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/12/2004 16:15'!
primitiveSetBitBltPlugin
	"Primitive. Set the BitBlt plugin to use."
	| pluginName |
	pluginName := interpreterProxy stackValue: 0.
	"Must be string to work"
	(interpreterProxy isBytes: pluginName) 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy stringOf: pluginName) = bbPluginName
		ifTrue: [interpreterProxy pop: 1. "Return receiver"]
		ifFalse: [^interpreterProxy primitiveFail]! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/5/1998 21:15'!
printAET

	| edge |
	Transcript cr; show:'************* ActiveEdgeTable **************'.
	0 to: self aetUsedGet - 1 do:[:i|
		edge := aetBuffer at: i.
		Transcript cr;
			print: i; space;
			nextPutAll:'edge #';print: edge; space;
			nextPutAll:'x: '; print: (self edgeXValueOf: edge); space;
			nextPutAll:'y: '; print: (self edgeYValueOf: edge); space;
			nextPutAll:'z: '; print: (self edgeZValueOf: edge); space;
			nextPutAll:'fill0: '; print: (self edgeLeftFillOf: edge); space;
			nextPutAll:'fill1: '; print: (self edgeRightFillOf: edge); space;
			nextPutAll:'lines: '; print: (self edgeNumLinesOf: edge); space.
		(self areEdgeFillsValid: edge) ifFalse:[Transcript nextPutAll:' disabled'].
		Transcript endEntry.
	].! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/5/1998 21:14'!
printGET

	| edge |
	Transcript cr; show:'************* GlobalEdgeTable **************'.
	0 to: self getUsedGet - 1 do:[:i|
		edge := getBuffer at: i.
		Transcript cr;
			print: i; space;
			nextPutAll:'edge #';print: edge; space;
			nextPutAll:'x: '; print: (self edgeXValueOf: edge); space;
			nextPutAll:'y: '; print: (self edgeYValueOf: edge); space;
			nextPutAll:'z: '; print: (self edgeZValueOf: edge); space;
			nextPutAll:'fill0: '; print: (self edgeLeftFillOf: edge); space;
			nextPutAll:'fill1: '; print: (self edgeRightFillOf: edge); space;
			nextPutAll:'lines: '; print: (self edgeNumLinesOf: edge); space.
		(self areEdgeFillsValid: edge) ifFalse:[Transcript nextPutAll:' disabled'].
		Transcript endEntry.
	].! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 10/30/1998 21:57'!
quickPrint: curve
	Transcript nextPut:$(;
		print: curve start;
		space;
		print: curve via;
		space;
		print: curve end;
		nextPut:$).! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 10/30/1998 22:18'!
quickPrintBezier: bezier
	Transcript cr.
	Transcript nextPut:$(;
		print: (self edgeXValueOf: bezier)@(self edgeYValueOf: bezier);
		space;
		print: (self bezierViaXOf: bezier)@(self bezierViaYOf: bezier);
		space;
		print: (self bezierEndXOf: bezier)@(self bezierEndYOf: bezier);
		nextPut:$).
	Transcript endEntry.! !
!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 10/30/1998 22:00'!
quickPrintBezier: index first: aBool
	aBool ifTrue:[Transcript cr].
	Transcript nextPut:$(;
		print: (self bzStartX: index)@(self bzStartY: index);
		space;
		print: (self bzViaX: index)@(self bzViaY: index);
		space;
		print: (self bzEndX: index)@(self bzEndY: index);
		nextPut:$).
	Transcript endEntry.! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/25/1998 19:24'!
rShiftTable
	^CArrayAccessor on: #(0 5 4 0 3 0 0 0 2 0 0 0 0 0 0 0 1).! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 15:11'!
shortRunLengthAt: index from: runArray
	"Load the short value from the given index in intArray"

	^ interpreterProxy halfWordHighInLong32: (runArray at: index)! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 15:10'!
shortRunValueAt: index from: runArray
	"Load the short value from the given index in intArray"

	^ (interpreterProxy halfWordLowInLong32: (runArray at: index)) signedIntFromShort ! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/31/1998 23:07'!
showDisplayBits
	"Do nothing."! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/4/1998 19:51'!
smallSqrtTable
	"Return a lookup table for rounded integer square root values from 0 to 31"
	^CArrayAccessor on:#(0 1 1 2 2 2 2 3 3 3 3 3 3 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 5 5 6 )! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/25/1998 02:23'!
stopBecauseOf: stopReason
	"Don't stop because of need to flush."
	stopReason = GErrorNeedFlush ifFalse:[
		^super stopBecauseOf: stopReason.
	].! !
!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 12:37'!
workBufferPut: wbOop
	interpreterProxy isInterpreterProxy 
		ifTrue:[^super workBufferPut: wbOop].
	workBuffer := ((interpreterProxy firstIndexableField: wbOop) as: BalloonArray) asCArrayAccessor.
	workBufferArray ifNil:
		[workBufferArray := Array new: (interpreterProxy slotSizeOf: wbOop)].
	workBuffer getObject setSimArray: workBufferArray! !

InterpreterPlugin subclass: #BitBltSimulation
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight sourceWidth sourceHeight sourceDepth sourcePitch sourceBits sourcePPW sourceMSB destWidth destHeight destDepth destPitch destBits destPPW destMSB bitCount skew mask1 mask2 preload nWords destMask hDir vDir sourceIndex sourceDelta destIndex destDelta sx sy dx dy bbW bbH halftoneHeight noSource noHalftone halftoneBase sourceAlpha srcBitShift dstBitShift bitBltOop affectedL affectedR affectedT affectedB opTable maskTable ditherMatrix4x4 ditherThresholds16 ditherValues16 hasSurfaceLock warpSrcShift warpSrcMask warpAlignShift warpAlignMask warpBitShiftTable querySurfaceFn lockSurfaceFn unlockSurfaceFn isWarping cmFlags cmMask cmShiftTable cmMaskTable cmLookupTable cmBitsPerColor dither8Lookup'
	classVariableNames: 'AllOnes AlphaIndex BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBLastIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWarpBase BBWidthIndex BBXTableIndex BinaryPoint BlueIndex ColorMapFixedPart ColorMapIndexedPart ColorMapNewStyle ColorMapPresent CrossedX EndOfRun FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex GreenIndex JitBltHookSize OpTable OpTableSize RedIndex'
	poolDictionaries: ''
	category: 'VMMaker-Interpreter'!
!BitBltSimulation commentStamp: '<historical>' prior: 0!
This class implements BitBlt, much as specified in the Blue Book spec.

Performance has been enhanced through the use of pointer variables such as sourceIndex and destIndex, and by separating several special cases of the inner loop.

Operation has been extended to color, with support for 1, 2, 4, 8, 16, and 32-bit pixel sizes.  Conversion between different pixel sizes is facilitated by accepting an optional color map.

In addition to the original 16 combination rules, this BitBlt supports
	16	fail (for old paint mode)
	17	fail (for old mask mode)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	OLDrgbDiff: sourceWord with: destinationWord
	23	OLDtallyIntoMap: destinationWord -- old vers doesn't clip to bit boundary
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord
	30	alphaBlendConst: sourceWord with: destinationWord -- alpha passed as an arg
	31	alphaPaintConst: sourceWord with: destinationWord -- alpha passed as an arg
	32	rgbDiff: sourceWord with: destinationWord
	33	tallyIntoMap: destinationWord
	34	alphaBlendScaled: sourceWord with: destinationWord

This implementation has also been fitted with an experimental "warp drive" that allows abritrary scaling and rotation (and even limited affine deformations) with all BitBlt storage modes supported.

To add a new rule to BitBlt...
	1.  add the new rule method or methods in the category 'combination rules' of BBSim
	2.  describe it in the class comment  of BBSim and in the class comment for BitBlt
	3.  add refs to initializeRuleTable in proper positions
	4.  add refs to initBBOpTable, following the pattern
!
!BitBltSimulation class methodsFor: 'system simulation' stamp: 'tpr 3/24/2004 13:01'!
copyBitsFrom: aBitBlt
	"Simulate the copyBits primitive"
	| proxy bb |
	proxy := InterpreterProxy new.
	proxy loadStackFrom: thisContext sender home.
	bb := self simulatorClass new.
	bb initialiseModule.
	bb setInterpreter: proxy.
	proxy success: (bb loadBitBltFrom: aBitBlt).
	bb copyBits.
	proxy failed ifFalse:[
		proxy showDisplayBits: aBitBlt destForm Left: bb affectedLeft Top: bb affectedTop Right: bb affectedRight Bottom: bb affectedBottom].
	^proxy stackValue: 0! !
!BitBltSimulation class methodsFor: 'translation' stamp: 'tpr 12/29/2005 15:55'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator var: 'opTable'
		declareC: 'void *opTable[' , OpTableSize printString , ']'.
	aCCodeGenerator var: 'maskTable'
		declareC:'int maskTable[33] = {
0, 1, 3, 0, 15, 31, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 65535,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1
}'.
	aCCodeGenerator var: 'ditherMatrix4x4'
		declareC:'const int ditherMatrix4x4[16] = {
0,	8,	2,	10,
12,	4,	14,	6,
3,	11,	1,	9,
15,	7,	13,	5
}'.
	aCCodeGenerator var: 'ditherThresholds16'
		declareC:'const int ditherThresholds16[8] = { 0, 2, 4, 6, 8, 12, 14, 16 }'.
	aCCodeGenerator var: 'ditherValues16'
		declareC:'const int ditherValues16[32] = {
0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30
}'.

	aCCodeGenerator var: 'warpBitShiftTable'
		declareC:'int warpBitShiftTable[32]'.

	aCCodeGenerator var:'cmShiftTable' 
		type:'int *'.
	aCCodeGenerator var:'cmMaskTable' 
		type:'unsigned int *'.
	aCCodeGenerator var:'cmLookupTable' 
		type:'unsigned int *'.

	aCCodeGenerator var: 'dither8Lookup'
		declareC:' unsigned char dither8Lookup[4096]'.

	aCCodeGenerator var: 'querySurfaceFn' type: 'void *'.
	aCCodeGenerator var: 'lockSurfaceFn' type: 'void *'.
	aCCodeGenerator var: 'unlockSurfaceFn' type: 'void *'! !
!BitBltSimulation class methodsFor: 'initialization' stamp: 'ar 5/4/2001 14:43'!
initialize
	"BitBltSimulation initialize"

	self initializeRuleTable.

	"Mask constants"
	AllOnes := 16rFFFFFFFF.
	BinaryPoint := 14.
	FixedPt1 := 1 << BinaryPoint.  "Value of 1.0 in Warp's fixed-point representation"
 
	"Indices into stopConditions for scanning"
	EndOfRun := 257.
	CrossedX := 258.
 
	"Form fields"
	FormBitsIndex := 0.
	FormWidthIndex := 1.
	FormHeightIndex := 2.
	FormDepthIndex := 3.
 
	"BitBlt fields"
	BBDestFormIndex := 0.
	BBSourceFormIndex := 1.
	BBHalftoneFormIndex := 2.
	BBRuleIndex := 3.
	BBDestXIndex := 4.
	BBDestYIndex := 5.
	BBWidthIndex := 6.
	BBHeightIndex := 7.
	BBSourceXIndex := 8.
	BBSourceYIndex := 9.
	BBClipXIndex := 10.
	BBClipYIndex := 11.
	BBClipWidthIndex := 12.
	BBClipHeightIndex := 13.
	BBColorMapIndex := 14.
	BBWarpBase := 15.
	BBLastIndex := 15.
	BBXTableIndex := 16.

	"RGBA indexes"
	RedIndex := 0.
	GreenIndex := 1.
	BlueIndex := 2.
	AlphaIndex := 3.

	"Color map flags"
	ColorMapPresent := 1.		"do we have one?"
	ColorMapFixedPart := 2.		"does it have a fixed part?"
	ColorMapIndexedPart := 4.	"does it have an indexed part?"
	ColorMapNewStyle := 8.		"new style color map"! !
!BitBltSimulation class methodsFor: 'initialization' stamp: 'ar 8/21/2002 20:59'!
initializeRuleTable
	"BitBltSimulation initializeRuleTable"
	"**WARNING** You MUST change initBBOpTable if you change this"
	OpTable := #(
		"0" clearWord:with:
		"1" bitAnd:with:
		"2" bitAndInvert:with:
		"3" sourceWord:with:
		"4" bitInvertAnd:with:
		"5" destinationWord:with:
		"6" bitXor:with:
		"7" bitOr:with:
		"8" bitInvertAndInvert:with:
		"9" bitInvertXor:with:
		"10" bitInvertDestination:with:
		"11" bitOrInvert:with:
		"12" bitInvertSource:with:
		"13" bitInvertOr:with:
		"14" bitInvertOrInvert:with:
		"15" destinationWord:with:
		"16" destinationWord:with: "unused - was old paint"
		"17" destinationWord:with: "unused - was old mask"
		"18" addWord:with:
		"19" subWord:with:
		"20" rgbAdd:with:
		"21" rgbSub:with:
		"22" OLDrgbDiff:with:
		"23" OLDtallyIntoMap:with:
		"24" alphaBlend:with:
		"25" pixPaint:with:
		"26" pixMask:with:
		"27" rgbMax:with:
		"28" rgbMin:with:
		"29" rgbMinInvert:with:
		"30" alphaBlendConst:with:
		"31" alphaPaintConst:with:
		"32" rgbDiff:with:
		"33" tallyIntoMap:with:
		"34" alphaBlendScaled:with:

		"35" alphaBlendScaled:with:	"unused here - only used by FXBlt"
		"36" alphaBlendScaled:with:	"unused here - only used by FXBlt"
		"37" rgbMul:with:
		"38" pixSwap:with:
		"39" pixClear:with:
		"40" fixAlpha:with:
	).
	OpTableSize := OpTable size + 1.  "0-origin indexing"
! !
!BitBltSimulation class methodsFor: 'translation' stamp: 'ar 2/19/2000 20:55'!
moduleName
	^'BitBltPlugin'! !
!BitBltSimulation class methodsFor: 'translation' stamp: 'jm 5/12/1999 12:02'!
opTable

	^ OpTable
! !
!BitBltSimulation class methodsFor: 'translation' stamp: 'tpr 2/29/2004 20:05'!
requiredMethodNames
	^self opTable asSet! !
!BitBltSimulation class methodsFor: 'system simulation' stamp: 'ar 10/27/1999 14:06'!
simulatorClass
	^BitBltSimulator! !
!BitBltSimulation class methodsFor: 'testing' stamp: 'tpr 3/24/2004 13:03'!
test2
	"BitBltSimulation test2"
	| f |
	Display fillWhite: (0 @ 0 extent: 300 @ 140).
	1 to: 12 do: [:i | 
			f := (Form extent: i @ 5) fillBlack.
			0 to: 20 do: [:x | f displayOn: Display at: x * 13 @ (i * 10)]]! !
!BitBltSimulation class methodsFor: 'testing' stamp: 'tpr 3/24/2004 13:03'!
timingTest: extent 
	"BitBltSimulation timingTest: 640@480"
	| f f2 map |
	f := Form extent: extent depth: 8.
	f2 := Form extent: extent depth: 8.
	map := Bitmap new: 1 << f2 depth.
	^ Array
		with: (Time millisecondsToRun: [100 timesRepeat: [f fillWithColor: Color white]])
		with: (Time millisecondsToRun: [100 timesRepeat: [f copy: f boundingBox from: 0 @ 0 in: f2 rule: Form over]])
		with: (Time millisecondsToRun: [100 timesRepeat: [f copyBits: f boundingBox from: f2 at: 0 @ 0 colorMap: map]])! !
!BitBltSimulation class methodsFor: 'system simulation' stamp: 'tpr 3/24/2004 13:02'!
warpBitsFrom: aBitBlt
	"Simulate the warpBits primitive"
	| proxy bb |
	proxy := InterpreterProxy new.
	proxy loadStackFrom: thisContext sender home.
	bb := self simulatorClass new.
	bb initialiseModule.
	bb setInterpreter: proxy.
	proxy success: (bb loadWarpBltFrom: aBitBlt).
	bb warpBits.
	proxy failed ifFalse:[
		proxy showDisplayBits: aBitBlt destForm Left: bb affectedLeft Top: bb affectedTop Right: bb affectedRight Bottom: bb affectedBottom].
	^proxy stackValue: 0! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 4/18/2001 20:36'!
OLDrgbDiff: sourceWord with: destinationWord
	"Subract the pixels in the source and destination, color by color,
	and return the sum of the absolute value of all the differences.
	For non-rgb, XOR the two and return the number of differing pixels.
	Note that the region is not clipped to bit boundaries, but only to the
	nearest (enclosing) word.  This is because copyLoop does not do
	pre-merge masking.  For accurate results, you must subtract the
	values obtained from the left and right fringes."
	| diff pixMask |
	<inline: false>
	destDepth < 16 ifTrue:
		["Just xor and count differing bits if not RGB"
		diff := sourceWord bitXor: destinationWord.
		pixMask := maskTable at: destDepth.
		[diff = 0] whileFalse:
			[(diff bitAnd: pixMask) ~= 0 ifTrue: [bitCount := bitCount + 1].
			diff := diff >> destDepth].
		^ destinationWord "for no effect"].
 	destDepth = 16
		ifTrue:
		[diff := (self partitionedSub: sourceWord from: destinationWord
						nBits: 5 nPartitions: 3).
		bitCount := bitCount + (diff bitAnd: 16r1F)
							+ (diff>>5 bitAnd: 16r1F)
							+ (diff>>10 bitAnd: 16r1F).
		diff := (self partitionedSub: sourceWord>>16 from: destinationWord>>16
						nBits: 5 nPartitions: 3).
		bitCount := bitCount + (diff bitAnd: 16r1F)
							+ (diff>>5 bitAnd: 16r1F)
							+ (diff>>10 bitAnd: 16r1F)]
		ifFalse:
		[diff := (self partitionedSub: sourceWord from: destinationWord
						nBits: 8 nPartitions: 3).
		bitCount := bitCount + (diff bitAnd: 16rFF)
							+ (diff>>8 bitAnd: 16rFF)
							+ (diff>>16 bitAnd: 16rFF)].
	^ destinationWord  "For no effect on dest"! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 5/17/2001 15:15'!
OLDtallyIntoMap: sourceWord with: destinationWord
	"Tally pixels into the color map.  Note that the source should be 
	specified = destination, in order for the proper color map checks 
	to be performed at setup.
	Note that the region is not clipped to bit boundaries, but only to the
	nearest (enclosing) word.  This is because copyLoop does not do
	pre-merge masking.  For accurate results, you must subtract the
	values obtained from the left and right fringes."
	| mapIndex pixMask shiftWord |
	(cmFlags bitAnd: (ColorMapPresent bitOr: ColorMapIndexedPart)) =
		(ColorMapPresent bitOr: ColorMapIndexedPart)
			ifFalse: [^ destinationWord "no op"].
	destDepth < 16 ifTrue:
		["loop through all packed pixels."
		pixMask := (maskTable at: destDepth) bitAnd: cmMask.
		shiftWord := destinationWord.
		1 to: destPPW do:
			[:i |
			mapIndex := shiftWord bitAnd: pixMask.
			self tallyMapAt: mapIndex put: (self tallyMapAt: mapIndex) + 1.
			shiftWord := shiftWord >> destDepth].
		^ destinationWord].
	destDepth = 16 ifTrue:
		["Two pixels  Tally the right half..."
		mapIndex := self rgbMap: (destinationWord bitAnd: 16rFFFF) from: 5 to: cmBitsPerColor.
		self tallyMapAt: mapIndex put: (self tallyMapAt: mapIndex) + 1.
		"... and then left half"
		mapIndex := self rgbMap: destinationWord>>16 from: 5 to: cmBitsPerColor.
		self tallyMapAt: mapIndex put: (self tallyMapAt: mapIndex) + 1]
	ifFalse:
		["Just one pixel."
		mapIndex := self rgbMap: destinationWord from: 8 to: cmBitsPerColor.
		self tallyMapAt: mapIndex put: (self tallyMapAt: mapIndex) + 1].
	^ destinationWord  "For no effect on dest"! !
!BitBltSimulation methodsFor: 'combination rules'!
addWord: sourceWord with: destinationWord
	^sourceWord + destinationWord! !
!BitBltSimulation methodsFor: 'accessing'!
affectedBottom

	^affectedB! !
!BitBltSimulation methodsFor: 'accessing'!
affectedLeft

	^affectedL! !
!BitBltSimulation methodsFor: 'accessing'!
affectedRight

	^affectedR! !
!BitBltSimulation methodsFor: 'accessing'!
affectedTop

	^affectedT! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 4/6/2003 18:52'!
alphaBlend: sourceWord with: destinationWord
	"Blend sourceWord with destinationWord, assuming both are 32-bit pixels.
	The source is assumed to have 255*alpha in the high 8 bits of each pixel,
	while the high 8 bits of the destinationWord will be ignored.
	The blend produced is alpha*source + (1-alpha)*dest, with
	the computation being performed independently on each color
	component.  The high byte of the result will be 0."
	| alpha unAlpha colorMask result blend shift |
	<inline: false>
	alpha := sourceWord >> 24.  "High 8 bits of source pixel"
	alpha = 0 ifTrue: [ ^ destinationWord ].
	alpha = 255 ifTrue: [ ^ sourceWord ].
	unAlpha := 255 - alpha.
	colorMask := 16rFF.
	result := 0.

	"red"
	shift := 0.
	blend := ((sourceWord >> shift bitAnd: colorMask) * alpha) +
				((destinationWord>>shift bitAnd: colorMask) * unAlpha)
			 	+ 254 // 255 bitAnd: colorMask.
	result := result bitOr: blend << shift.
	"green"
	shift := 8.
	blend := ((sourceWord >> shift bitAnd: colorMask) * alpha) +
				((destinationWord>>shift bitAnd: colorMask) * unAlpha)
			 	+ 254 // 255 bitAnd: colorMask.
	result := result bitOr: blend << shift.
	"blue"
	shift := 16.
	blend := ((sourceWord >> shift bitAnd: colorMask) * alpha) +
				((destinationWord>>shift bitAnd: colorMask) * unAlpha)
			 	+ 254 // 255 bitAnd: colorMask.
	result := result bitOr: blend << shift.
	"alpha (pre-multiplied)"
	shift := 24.
	blend := (alpha * 255) +
				((destinationWord>>shift bitAnd: colorMask) * unAlpha)
			 	+ 254 // 255 bitAnd: colorMask.
	result := result bitOr: blend << shift.
	^ result
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 6/29/1998 19:55'!
alphaBlendConst: sourceWord with: destinationWord

	^ self alphaBlendConst: sourceWord with: destinationWord paintMode: false! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 1/24/2002 17:31'!
alphaBlendConst: sourceWord with: destinationWord paintMode: paintMode
	"Blend sourceWord with destinationWord using a constant alpha.
	Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
	The blend produced is alpha*source + (1.0-alpha)*dest, with the
	computation being performed independently on each color component.
	This function could eventually blend into any depth destination,
	using the same color averaging and mapping as warpBlt.
	paintMode = true means do nothing if the source pixel value is zero."

	"This first implementation works with dest depths of 16 and 32 bits only.
	Normal color mapping will allow sources of lower depths in this case,
	and results can be mapped directly by truncation, so no extra color maps are needed.
	To allow storing into any depth will require subsequent addition of two other
	colormaps, as is the case with WarpBlt."

	| pixMask destShifted sourceShifted destPixVal rgbMask sourcePixVal unAlpha result pixBlend shift blend maskShifted bitsPerColor |
	<inline: false>
	destDepth < 16 ifTrue: [^ destinationWord "no-op"].
	unAlpha := 255 - sourceAlpha.
	pixMask := maskTable at: destDepth.
	destDepth = 16 
		ifTrue: [bitsPerColor := 5]
		ifFalse:[bitsPerColor := 8].
	rgbMask := (1<<bitsPerColor) - 1.
	maskShifted := destMask.
	destShifted := destinationWord.
	sourceShifted := sourceWord.
	result := destinationWord.
	destPPW = 1 ifTrue:["32bpp blends include alpha"
		paintMode & (sourceWord = 0)  "painting a transparent pixel" ifFalse:[
			result := 0.
			1 to: 4 do:[:i|
				shift := (i-1)*8.
				blend := (((sourceWord>>shift bitAnd: rgbMask) * sourceAlpha)
							+ ((destinationWord>>shift bitAnd: rgbMask) * unAlpha))
					 	+ 254 // 255 bitAnd: rgbMask.
				result := result bitOr: blend<<shift].
		].
	] ifFalse:[
		1 to: destPPW do:[:j |
			sourcePixVal := sourceShifted bitAnd: pixMask.
			((maskShifted bitAnd: pixMask) = 0  "no effect if outside of dest rectangle"
				or: [paintMode & (sourcePixVal = 0)  "or painting a transparent pixel"])
			ifFalse:
				[destPixVal := destShifted bitAnd: pixMask.
				pixBlend := 0.
				1 to: 3 do:
					[:i | shift := (i-1)*bitsPerColor.
					blend := (((sourcePixVal>>shift bitAnd: rgbMask) * sourceAlpha)
								+ ((destPixVal>>shift bitAnd: rgbMask) * unAlpha))
						 	+ 254 // 255 bitAnd: rgbMask.
					pixBlend := pixBlend bitOr: blend<<shift].
				destDepth = 16
					ifTrue: [result := (result bitAnd: (pixMask << (j-1*16)) bitInvert32)
										bitOr: pixBlend << (j-1*16)]
					ifFalse: [result := pixBlend]].
			maskShifted := maskShifted >> destDepth.
			sourceShifted := sourceShifted >> destDepth.
			destShifted := destShifted >> destDepth].
	].
	^ result
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 11/27/1998 23:56'!
alphaBlendScaled: sourceWord with: destinationWord
	"Blend sourceWord with destinationWord using the alpha value from sourceWord.
	Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
	In contrast to alphaBlend:with: the color produced is

		srcColor + (1-srcAlpha) * dstColor

	e.g., it is assumed that the source color is already scaled."
	| unAlpha dstMask srcMask b g r a |
	<inline: false>	"Do NOT inline this into optimized loops"
	unAlpha := 255 - (sourceWord >> 24).  "High 8 bits of source pixel"
	dstMask := destinationWord.
	srcMask := sourceWord.
	b := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	b > 255 ifTrue:[b := 255].
	dstMask := dstMask >> 8.
	srcMask := srcMask >> 8.
	g := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	g > 255 ifTrue:[g := 255].
	dstMask := dstMask >> 8.
	srcMask := srcMask >> 8.
	r := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	r > 255 ifTrue:[r := 255].
	dstMask := dstMask >> 8.
	srcMask := srcMask >> 8.
	a := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	a > 255 ifTrue:[a := 255].
	^(((((a << 8) + r) << 8) + g) << 8) + b! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 6/29/1998 19:56'!
alphaPaintConst: sourceWord with: destinationWord

	sourceWord = 0 ifTrue: [^ destinationWord  "opt for all-transparent source"].
	^ self alphaBlendConst: sourceWord with: destinationWord paintMode: true! !
!BitBltSimulation methodsFor: 'inner loop' stamp: 'JMM (auto pragmas 12/08) 7/3/2003 23:55'!
alphaSourceBlendBits16
	"This version assumes 
		combinationRule = 34
		sourcePixSize = 32
		destPixSize = 16
		sourceForm ~= destForm.
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY 
	srcY dstY dstMask srcShift ditherBase ditherIndex ditherThreshold |
	<inline: false> "This particular method should be optimized in itself"
	deltaY := bbH + 1. "So we can pre-decrement"
	srcY := sy.
	dstY := dy.
	srcShift := (dx bitAnd: 1) * 16.
	destMSB ifTrue:[srcShift := 16 - srcShift].
	mask1 := 16rFFFF << (16 - srcShift).
	"This is the outer loop"
	[(deltaY := deltaY - 1) ~= 0] whileTrue:[
		srcIndex := sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex := destBits + (dstY * destPitch) + (dx // 2 * 4).
		ditherBase := (dstY bitAnd: 3) * 4.
		ditherIndex := (sx bitAnd: 3) - 1. "For pre-increment"
		deltaX := bbW + 1. "So we can pre-decrement"
		dstMask := mask1.
		dstMask = 16rFFFF ifTrue:[srcShift := 16] ifFalse:[srcShift := 0].

		"This is the inner loop"
		[(deltaX := deltaX - 1) ~= 0] whileTrue:[
			ditherThreshold := ditherMatrix4x4 at: ditherBase + (ditherIndex := ditherIndex + 1 bitAnd: 3).
			sourceWord := self srcLongAt: srcIndex.
			srcAlpha := sourceWord >> 24.
			srcAlpha = 255 ifTrue:[
				"Dither from 32 to 16 bit"
				sourceWord := self dither32To16: sourceWord threshold: ditherThreshold.
				sourceWord = 0 
					ifTrue:[sourceWord := 1 << srcShift]
					ifFalse: [sourceWord := sourceWord << srcShift].
				"Store masked value"
				self dstLongAt: dstIndex put: sourceWord mask: dstMask.
			] ifFalse:[ "srcAlpha ~= 255"
				srcAlpha = 0 ifFalse:[ "0 < srcAlpha < 255"
					"If we have to mix colors then just copy a single word"
					destWord := self dstLongAt: dstIndex.
					destWord := destWord bitAnd: dstMask bitInvert32.
					destWord := destWord >> srcShift.
					"Expand from 16 to 32 bit by adding zero bits"
					destWord := (((destWord bitAnd: 16r7C00) bitShift: 9) bitOr:
									((destWord bitAnd: 16r3E0) bitShift: 6)) bitOr:
								(((destWord bitAnd: 16r1F) bitShift: 3) bitOr:
									16rFF000000).
					"Mix colors"
					sourceWord := self alphaBlendScaled: sourceWord with: destWord.
					"And dither"
					sourceWord := self dither32To16: sourceWord threshold: ditherThreshold.
					sourceWord = 0 
						ifTrue:[sourceWord := 1 << srcShift]
						ifFalse:[sourceWord := sourceWord << srcShift].
					"Store back"
					self dstLongAt: dstIndex put: sourceWord mask: dstMask.
				].
			].
			srcIndex := srcIndex + 4.
			destMSB
				ifTrue:[srcShift = 0 ifTrue:[dstIndex := dstIndex + 4]]
				ifFalse:[srcShift = 0 ifFalse:[dstIndex := dstIndex + 4]].
			srcShift := srcShift bitXor: 16. "Toggle between 0 and 16"
			dstMask := dstMask bitInvert32. "Mask other half word"
		].
		srcY := srcY + 1.
		dstY := dstY + 1.
	].! !
!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp (auto pragmas 12/08) 8/4/2004 18:03'!
alphaSourceBlendBits32
	"This version assumes 
		combinationRule = 34
		sourcePixSize = destPixSize = 32
		sourceForm ~= destForm.
	Note: The inner loop has been optimized for dealing
		with the special cases of srcAlpha = 0.0 and srcAlpha = 1.0 
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY |
	<inline: false> "This particular method should be optimized in itself"

	"Give the compile a couple of hints"

	"The following should be declared as pointers so the compiler will
	notice that they're used for accessing memory locations 
	(good to know on an Intel architecture) but then the increments
	would be different between ST code and C code so must hope the
	compiler notices what happens (MS Visual C does)"

	deltaY := bbH + 1. "So we can pre-decrement"
	srcY := sy.
	dstY := dy.

	"This is the outer loop"
	[(deltaY := deltaY - 1) ~= 0] whileTrue:[
		srcIndex := sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex := destBits + (dstY * destPitch) + (dx * 4).
		deltaX := bbW + 1. "So we can pre-decrement"

		"This is the inner loop"
		[(deltaX := deltaX - 1) ~= 0] whileTrue:[
			sourceWord := self srcLongAt: srcIndex.
			srcAlpha := sourceWord >> 24.
			srcAlpha = 255 ifTrue:[
				self dstLongAt: dstIndex put: sourceWord.
				srcIndex := srcIndex + 4.
				dstIndex := dstIndex + 4.
				"Now copy as many words as possible with alpha = 255"
				[(deltaX := deltaX - 1) ~= 0 and:[
					(sourceWord := self srcLongAt: srcIndex) >> 24 = 255]]
						whileTrue:[
							self dstLongAt: dstIndex put: sourceWord.
							srcIndex := srcIndex + 4.
							dstIndex := dstIndex + 4.
						].
				"Adjust deltaX"
				deltaX := deltaX + 1.
			] ifFalse:[ "srcAlpha ~= 255"
				srcAlpha = 0 ifTrue:[
					srcIndex := srcIndex + 4.
					dstIndex := dstIndex + 4.
					"Now skip as many words as possible,"
					[(deltaX := deltaX - 1) ~= 0 and:[
						(sourceWord := self srcLongAt: srcIndex) >> 24 = 0]]
						whileTrue:[
							srcIndex := srcIndex + 4.
							dstIndex := dstIndex + 4.
						].
					"Adjust deltaX"
					deltaX := deltaX + 1.
				] ifFalse:[ "0 < srcAlpha < 255"
					"If we have to mix colors then just copy a single word"
					destWord := self dstLongAt: dstIndex.
					destWord := self alphaBlendScaled: sourceWord with: destWord.
					self dstLongAt: dstIndex put: destWord.
					srcIndex := srcIndex + 4.
					dstIndex := dstIndex + 4.
				].
			].
		].
		srcY := srcY + 1.
		dstY := dstY + 1.
	].! !
!BitBltSimulation methodsFor: 'inner loop' stamp: 'tpr (auto pragmas dtl 2010-09-26) 12/29/2005 15:52'!
alphaSourceBlendBits8
	"This version assumes 
		combinationRule = 34
		sourcePixSize = 32
		destPixSize = 8
		sourceForm ~= destForm.
	Note: This is not real blending since we don't have the source colors available.
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY 
	srcY dstY dstMask srcShift adjust mappingTable mapperFlags |
	<inline: false>
	<var: #mappingTable type: 'unsigned int *'>
	mappingTable := self default8To32Table.
	mapperFlags := cmFlags bitAnd: ColorMapNewStyle bitInvert32.
	deltaY := bbH + 1. "So we can pre-decrement"
	srcY := sy.
	dstY := dy.
	mask1 := ((dx bitAnd: 3) * 8).
	destMSB ifTrue:[mask1 := 24 - mask1].
	mask2 := AllOnes bitXor:(16rFF << mask1).
	(dx bitAnd: 1) = 0 
		ifTrue:[adjust := 0]
		ifFalse:[adjust := 16r1F1F1F1F].
	(dy bitAnd: 1) = 0
		ifTrue:[adjust := adjust bitXor: 16r1F1F1F1F].
	"This is the outer loop"
	[(deltaY := deltaY - 1) ~= 0] whileTrue:[
		adjust := adjust bitXor: 16r1F1F1F1F.
		srcIndex := sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex := destBits + (dstY * destPitch) + (dx // 4 * 4).
		deltaX := bbW + 1. "So we can pre-decrement"
		srcShift := mask1.
		dstMask := mask2.

		"This is the inner loop"
		[(deltaX := deltaX - 1) ~= 0] whileTrue:[
			sourceWord := ((self srcLongAt: srcIndex) bitAnd: (adjust bitInvert32)) + adjust.
			srcAlpha := sourceWord >> 24.
			srcAlpha > 31 ifTrue:["Everything below 31 is transparent"
				srcAlpha < 224 ifTrue:["Everything above 224 is opaque"
					destWord := self dstLongAt: dstIndex.
					destWord := destWord bitAnd: dstMask bitInvert32.
					destWord := destWord >> srcShift.
					destWord := mappingTable at: destWord.
					sourceWord := self alphaBlendScaled: sourceWord with: destWord.
				].
				sourceWord := self mapPixel: sourceWord flags: mapperFlags.
				sourceWord := sourceWord << srcShift.
				"Store back"
				self dstLongAt: dstIndex put: sourceWord mask: dstMask.
			].
			srcIndex := srcIndex + 4.
			destMSB ifTrue:[
				srcShift = 0 
					ifTrue:[dstIndex := dstIndex + 4.
							srcShift := 24.
							dstMask := 16r00FFFFFF]
					ifFalse:[srcShift := srcShift - 8.
							dstMask := (dstMask >> 8) bitOr: 16rFF000000].
			] ifFalse:[
				srcShift = 32
					ifTrue:[dstIndex := dstIndex + 4.
							srcShift := 0.
							dstMask := 16rFFFFFF00]
					ifFalse:[srcShift := srcShift + 8.
							dstMask := dstMask << 8 bitOr: 255].
			].
			adjust := adjust bitXor: 16r1F1F1F1F.
		].
		srcY := srcY + 1.
		dstY := dstY + 1.
	].! !
!BitBltSimulation methodsFor: 'combination rules'!
bitAnd: sourceWord with: destinationWord
	^sourceWord bitAnd: destinationWord! !
!BitBltSimulation methodsFor: 'combination rules'!
bitAndInvert: sourceWord with: destinationWord
	^sourceWord bitAnd: destinationWord bitInvert32! !
!BitBltSimulation methodsFor: 'combination rules'!
bitInvertAnd: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitAnd: destinationWord! !
!BitBltSimulation methodsFor: 'combination rules'!
bitInvertAndInvert: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitAnd: destinationWord bitInvert32! !
!BitBltSimulation methodsFor: 'combination rules'!
bitInvertDestination: sourceWord with: destinationWord
	^destinationWord bitInvert32! !
!BitBltSimulation methodsFor: 'combination rules'!
bitInvertOr: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitOr: destinationWord! !
!BitBltSimulation methodsFor: 'combination rules'!
bitInvertOrInvert: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitOr: destinationWord bitInvert32! !
!BitBltSimulation methodsFor: 'combination rules'!
bitInvertSource: sourceWord with: destinationWord
	^sourceWord bitInvert32! !
!BitBltSimulation methodsFor: 'combination rules'!
bitInvertXor: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitXor: destinationWord! !
!BitBltSimulation methodsFor: 'combination rules'!
bitOr: sourceWord with: destinationWord
	^sourceWord bitOr: destinationWord! !
!BitBltSimulation methodsFor: 'combination rules'!
bitOrInvert: sourceWord with: destinationWord
	^sourceWord bitOr: destinationWord bitInvert32! !
!BitBltSimulation methodsFor: 'combination rules'!
bitXor: sourceWord with: destinationWord
	^sourceWord bitXor: destinationWord! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 4/18/2001 20:39'!
checkSourceOverlap
	"check for possible overlap of source and destination"
	"ar 10/19/1999: This method requires surfaces to be locked."
	| t |
	<inline: true>
	(sourceForm = destForm and: [dy >= sy]) ifTrue:
		[dy > sy ifTrue:
			["have to start at bottom"
			vDir := -1.
			sy := sy + bbH - 1.
			dy := dy + bbH - 1]
		ifFalse:
			[(dy = sy) & (dx > sx) ifTrue:
				["y's are equal, but x's are backward"
				hDir := -1.
				sx := sx + bbW - 1.
				"start at right"
				dx := dx + bbW - 1.
				"and fix up masks"
				nWords > 1 ifTrue: 
					[t := mask1.
					mask1 := mask2.
					mask2 := t]]].
		"Dest inits may be affected by this change"
		destIndex := destBits + (dy * destPitch) + ((dx // destPPW) *4).
		destDelta := (destPitch * vDir) - (4 * (nWords * hDir))]! !
!BitBltSimulation methodsFor: 'combination rules'!
clearWord: source with: destination
	^ 0! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar 4/18/2001 21:15'!
clipRange
	"clip and adjust source origin and extent appropriately"
	"first in x"
	destX >= clipX
		ifTrue: [sx := sourceX.
				dx := destX.
				bbW := width]
		ifFalse: [sx := sourceX + (clipX - destX).
				bbW := width - (clipX - destX).
				dx := clipX].
	(dx + bbW) > (clipX + clipWidth)
		ifTrue: [bbW := bbW - ((dx + bbW) - (clipX + clipWidth))].
	"then in y"
	destY >= clipY
		ifTrue: [sy := sourceY.
				dy := destY.
				bbH := height]
		ifFalse: [sy := sourceY + clipY - destY.
				bbH := height - (clipY - destY).
				dy := clipY].
	(dy + bbH) > (clipY + clipHeight)
		ifTrue: [bbH := bbH - ((dy + bbH) - (clipY + clipHeight))].
	noSource ifTrue: [^ nil].
	sx < 0
		ifTrue: [dx := dx - sx.
				bbW := bbW + sx.
				sx := 0].
	sx + bbW > sourceWidth
		ifTrue: [bbW := bbW - (sx + bbW - sourceWidth)].
	sy < 0
		ifTrue: [dy := dy - sy.
				bbH := bbH + sy.
				sy := 0].
	sy + bbH > sourceHeight
		ifTrue: [bbH := bbH - (sy + bbH - sourceHeight)]! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 4/24/2001 21:19'!
copyBits
	"This function is exported for the Balloon engine"
	<export: true>
	<inline: false>
	self clipRange.
	(bbW <= 0 or: [bbH <= 0]) ifTrue:
		["zero width or height; noop"
		affectedL := affectedR := affectedT := affectedB := 0.
		^ nil].
	"Lock the surfaces"
	self lockSurfaces ifFalse:[^interpreterProxy primitiveFail].
	self copyBitsLockedAndClipped.
	self unlockSurfaces.! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 2/20/2000 19:42'!
copyBitsFrom: startX to: stopX at: yValue
	"Support for the balloon engine."
	<export: true>
	destX := startX.
	destY := yValue.
	sourceX := startX.
	width := (stopX - startX).
	self copyBits.
	self showDisplayBits.! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 2/20/2001 21:11'!
copyBitsLockedAndClipped
	"Perform the actual copyBits operation.
	Assume: Surfaces have been locked and clipping was performed."
	| done |
	<inline: true>
	"Try a shortcut for stuff that should be run as quickly as possible"
 	done := self tryCopyingBitsQuickly.
	done ifTrue:[^nil].

	(combinationRule = 30) | (combinationRule = 31) ifTrue:
		["Check and fetch source alpha parameter for alpha blend"
		interpreterProxy methodArgumentCount = 1
			ifTrue: [sourceAlpha := interpreterProxy stackIntegerValue: 0.
					(interpreterProxy failed not and: [(sourceAlpha >= 0) & (sourceAlpha <= 255)])
						ifFalse: [^ interpreterProxy primitiveFail]]
			ifFalse: [^ interpreterProxy primitiveFail]].

	bitCount := 0.
	"Choose and perform the actual copy loop."
	self performCopyLoop.

	(combinationRule = 22) | (combinationRule = 32) ifTrue:
		["zero width and height; return the count"
		affectedL := affectedR := affectedT := affectedB := 0]. 
	hDir > 0
		ifTrue: [affectedL := dx.
				affectedR := dx + bbW]
		ifFalse: [affectedL := dx - bbW + 1.
				affectedR := dx + 1].
	vDir > 0
		ifTrue: [affectedT := dy.
				affectedB := dy + bbH]
		ifFalse: [affectedT := dy - bbH + 1.
				affectedB := dy + 1]! !
!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp (auto pragmas 12/08) 6/11/2004 16:27'!
copyLoop
	| prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask mergeFnwith destWord |
	"This version of the inner loop assumes noSource = false."
	<inline: false>
	<var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'>
	mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	hInc := hDir*4.  "Byte delta"
	"degenerate skew fixed for Sparc. 10/20/96 ikp"
	skew == -32
		ifTrue: [skew := unskew := skewMask := 0]
		ifFalse: [skew < 0
			ifTrue:
				[unskew := skew+32.
				skewMask := AllOnes << (0-skew)]
			ifFalse:
				[skew = 0
					ifTrue:
						[unskew := 0.
						skewMask := AllOnes]
					ifFalse:
						[unskew := skew-32.
						skewMask := AllOnes >> skew]]].
	notSkewMask := skewMask bitInvert32.
	noHalftone
		ifTrue: [halftoneWord := AllOnes.  halftoneHeight := 0]
		ifFalse: [halftoneWord := self halftoneAt: 0].

	y := dy.
	1 to: bbH do: "here is the vertical loop"
		[ :i |
		halftoneHeight > 1 ifTrue:  "Otherwise, its always the same"
			[halftoneWord := self halftoneAt: y.
			y := y + vDir].
		preload ifTrue:
			["load the 64-bit shifter"
			prevWord := self srcLongAt: sourceIndex.
			sourceIndex := sourceIndex + hInc]
			ifFalse:
			[prevWord := 0].

	"Note: the horizontal loop has been expanded into three parts for speed:"

			"This first section requires masking of the destination store..."
			destMask := mask1.
			thisWord := self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex := sourceIndex + hInc.
			skewWord := ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord := thisWord.
			destWord := self dstLongAt: destIndex.
			mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord) with: destWord.
			destWord := (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex := destIndex + hInc.

		"This central horizontal loop requires no store masking"
		destMask := AllOnes.
combinationRule = 3
ifTrue: [(skew = 0) & (halftoneWord = AllOnes)
		ifTrue: 
		["Very special inner loop for STORE mode with no skew -- just move words"
		hDir = -1
		ifTrue: ["Woeful patch: revert to older code for hDir = -1"
				2 to: nWords-1 do: 
					[ :word |
					thisWord := self srcLongAt: sourceIndex.
					sourceIndex := sourceIndex + hInc.
					self dstLongAt: destIndex put: thisWord.
					destIndex := destIndex + hInc]]
		ifFalse: [2 to: nWords-1 do: 
					[ :word |  "Note loop starts with prevWord loaded (due to preload)"
					self dstLongAt: destIndex put: prevWord.
					destIndex := destIndex + hInc.
					prevWord := self srcLongAt: sourceIndex.
					sourceIndex := sourceIndex + hInc]]]
		ifFalse:
		["Special inner loop for STORE mode -- no need to call merge"
		2 to: nWords-1 do: 
			[ :word |
			thisWord := self srcLongAt: sourceIndex.
			sourceIndex := sourceIndex + hInc.
			skewWord := ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord := thisWord.
			self dstLongAt: destIndex put: (skewWord bitAnd: halftoneWord).
			destIndex := destIndex + hInc]]
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge:"
			[ :word |
			thisWord := self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex := sourceIndex + hInc.
			skewWord := ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord := thisWord.
			mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
							with: (self dstLongAt: destIndex).
			self dstLongAt: destIndex put: mergeWord.
			destIndex := destIndex + hInc]
].

		"This last section, if used, requires masking of the destination store..."
		nWords > 1 ifTrue:
			[destMask := mask2.
			thisWord := self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex := sourceIndex + hInc.
			skewWord := ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			destWord := self dstLongAt: destIndex.
			mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord) with: destWord.
			destWord := (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex := destIndex + hInc].

	sourceIndex := sourceIndex + sourceDelta.
	destIndex := destIndex + destDelta]! !
!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp (auto pragmas 12/08) 6/11/2004 16:27'!
copyLoopNoSource
	"Faster copyLoop when source not used.  hDir and vDir are both
	positive, and perload and skew are unused"
	| halftoneWord mergeWord mergeFnwith destWord |
	<inline: false>
	<var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'>
	mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		noHalftone
			ifTrue: [halftoneWord := AllOnes]
			ifFalse: [halftoneWord := self halftoneAt: dy+i-1].

	"Note: the horizontal loop has been expanded into three parts for speed:"

			"This first section requires masking of the destination store..."
			destMask := mask1.
			destWord := self dstLongAt: destIndex.
			mergeWord := self mergeFn: halftoneWord
							with: destWord.
			destWord := (destMask bitAnd: mergeWord) bitOr: 
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex := destIndex + 4.

		"This central horizontal loop requires no store masking"
			destMask := AllOnes.
			combinationRule = 3 ifTrue: ["Special inner loop for STORE"
				destWord := halftoneWord.
				2 to: nWords-1 do:[ :word |
					self dstLongAt: destIndex put: destWord.
					destIndex := destIndex + 4].
			] ifFalse:[ "Normal inner loop does merge"
				2 to: nWords-1 do:[ :word | "Normal inner loop does merge"
					destWord := self dstLongAt: destIndex.
					mergeWord := self mergeFn: halftoneWord with: destWord.
					self dstLongAt: destIndex put: mergeWord.
					destIndex := destIndex + 4].
			].

		"This last section, if used, requires masking of the destination store..."
		nWords > 1 ifTrue:
			[destMask := mask2.
			destWord := self dstLongAt: destIndex.
			mergeWord := self mergeFn: halftoneWord with: destWord.
			destWord := (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex := destIndex + 4].

	destIndex := destIndex + destDelta]! !
!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp (auto pragmas 12/08) 6/11/2004 16:28'!
copyLoopPixMap
	"This version of the inner loop maps source pixels
	to a destination form with different depth.  Because it is already
	unweildy, the loop is not unrolled as in the other versions.
	Preload, skew and skewMask are all overlooked, since pickSourcePixels
	delivers its destination word already properly aligned.
	Note that pickSourcePixels could be copied in-line at the top of
	the horizontal loop, and some of its inits moved out of the loop."
	"ar 12/7/1999:
	The loop has been rewritten to use only one pickSourcePixels call.
	The idea is that the call itself could be inlined. If we decide not
	to inline pickSourcePixels we could optimize the loop instead."
	| skewWord halftoneWord mergeWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask mergeFnwith nPix srcShift dstShift destWord words srcShiftInc dstShiftInc dstShiftLeft mapperFlags |
	<inline: false>
	<var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'>
	mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	"Additional inits peculiar to unequal source and dest pix size..."
	sourcePPW := 32//sourceDepth.
	sourcePixMask := maskTable at: sourceDepth.
	destPixMask := maskTable at: destDepth.
	mapperFlags := cmFlags bitAnd: ColorMapNewStyle bitInvert32.
	sourceIndex := sourceBits +
					(sy * sourcePitch) + ((sx // sourcePPW) *4).
	scrStartBits := sourcePPW - (sx bitAnd: sourcePPW-1).
	bbW < scrStartBits
		ifTrue: [nSourceIncs := 0]
		ifFalse: [nSourceIncs := (bbW - scrStartBits)//sourcePPW + 1].
	sourceDelta := sourcePitch - (nSourceIncs * 4).

	"Note following two items were already calculated in destmask setup!!"
	startBits := destPPW - (dx bitAnd: destPPW-1).
	endBits := ((dx + bbW - 1) bitAnd: destPPW-1) + 1.

	bbW < startBits ifTrue:[startBits := bbW].

	"Precomputed shifts for pickSourcePixels"
	srcShift := ((sx bitAnd: sourcePPW - 1) * sourceDepth).
	dstShift := ((dx bitAnd: destPPW - 1) * destDepth).
	srcShiftInc := sourceDepth.
	dstShiftInc := destDepth.
	dstShiftLeft := 0.
	sourceMSB ifTrue:[
		srcShift := 32 - sourceDepth - srcShift.
		srcShiftInc := 0 - srcShiftInc].
	destMSB ifTrue:[
		dstShift := 32 - destDepth - dstShift.
		dstShiftInc := 0 - dstShiftInc.
		dstShiftLeft := 32 - destDepth].

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		"*** is it possible at all that noHalftone == false? ***"
		noHalftone
			ifTrue:[halftoneWord := AllOnes]
			ifFalse: [halftoneWord := self halftoneAt: dy+i-1].
		"setup first load"
		srcBitShift := srcShift.
		dstBitShift := dstShift.
		destMask := mask1.
		nPix := startBits.
		"Here is the horizontal loop..."
		words := nWords.
			["pick up the word"
			skewWord := self pickSourcePixels: nPix flags: mapperFlags 
								srcMask: sourcePixMask destMask: destPixMask
								srcShiftInc: srcShiftInc dstShiftInc: dstShiftInc.
			"align next word to leftmost pixel"
			dstBitShift := dstShiftLeft.

			destMask = AllOnes ifTrue:["avoid read-modify-write"
				mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (self dstLongAt: destIndex).
				self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
			] ifFalse:[ "General version using dest masking"
				destWord := self dstLongAt: destIndex.
				mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (destWord bitAnd: destMask).
				destWord := (destMask bitAnd: mergeWord) bitOr:
								(destWord bitAnd: destMask bitInvert32).
				self dstLongAt: destIndex put: destWord.
			].
			destIndex := destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask := mask2.
						nPix := endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask := AllOnes.
						nPix := destPPW].
			(words := words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		sourceIndex := sourceIndex + sourceDelta.
		destIndex := destIndex + destDelta]
! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar (auto pragmas dtl 2010-09-26) 11/16/1998 00:23'!
default8To32Table
	"Return the default translation table from 1..8 bit indexed colors to 32bit"
	"The table has been generated by the following statements"
	"| pvs hex |
	String streamContents:[:s|
		s nextPutAll:'static unsigned int theTable[256] = { '.
		pvs := (Color colorMapIfNeededFrom: 8 to: 32) asArray.
		1 to: pvs size do:[:i|
			i > 1 ifTrue:[s nextPutAll:', '].
			(i-1 \\ 8) = 0 ifTrue:[s cr].
			s nextPutAll:'0x'.
			hex := (pvs at: i) printStringBase: 16.
			s nextPutAll: (hex copyFrom: 4 to: hex size).
		].
		s nextPutAll:'};'.
	]."
	| theTable |
	<returnTypeC: 'unsigned int *'>
	<var: #theTable declareC: 'static unsigned int theTable[256] = { 
0x0, 0xFF000001, 0xFFFFFFFF, 0xFF808080, 0xFFFF0000, 0xFF00FF00, 0xFF0000FF, 0xFF00FFFF, 
0xFFFFFF00, 0xFFFF00FF, 0xFF202020, 0xFF404040, 0xFF606060, 0xFF9F9F9F, 0xFFBFBFBF, 0xFFDFDFDF, 
0xFF080808, 0xFF101010, 0xFF181818, 0xFF282828, 0xFF303030, 0xFF383838, 0xFF484848, 0xFF505050, 
0xFF585858, 0xFF686868, 0xFF707070, 0xFF787878, 0xFF878787, 0xFF8F8F8F, 0xFF979797, 0xFFA7A7A7, 
0xFFAFAFAF, 0xFFB7B7B7, 0xFFC7C7C7, 0xFFCFCFCF, 0xFFD7D7D7, 0xFFE7E7E7, 0xFFEFEFEF, 0xFFF7F7F7, 
0xFF000001, 0xFF003300, 0xFF006600, 0xFF009900, 0xFF00CC00, 0xFF00FF00, 0xFF000033, 0xFF003333, 
0xFF006633, 0xFF009933, 0xFF00CC33, 0xFF00FF33, 0xFF000066, 0xFF003366, 0xFF006666, 0xFF009966, 
0xFF00CC66, 0xFF00FF66, 0xFF000099, 0xFF003399, 0xFF006699, 0xFF009999, 0xFF00CC99, 0xFF00FF99, 
0xFF0000CC, 0xFF0033CC, 0xFF0066CC, 0xFF0099CC, 0xFF00CCCC, 0xFF00FFCC, 0xFF0000FF, 0xFF0033FF, 
0xFF0066FF, 0xFF0099FF, 0xFF00CCFF, 0xFF00FFFF, 0xFF330000, 0xFF333300, 0xFF336600, 0xFF339900, 
0xFF33CC00, 0xFF33FF00, 0xFF330033, 0xFF333333, 0xFF336633, 0xFF339933, 0xFF33CC33, 0xFF33FF33, 
0xFF330066, 0xFF333366, 0xFF336666, 0xFF339966, 0xFF33CC66, 0xFF33FF66, 0xFF330099, 0xFF333399, 
0xFF336699, 0xFF339999, 0xFF33CC99, 0xFF33FF99, 0xFF3300CC, 0xFF3333CC, 0xFF3366CC, 0xFF3399CC, 
0xFF33CCCC, 0xFF33FFCC, 0xFF3300FF, 0xFF3333FF, 0xFF3366FF, 0xFF3399FF, 0xFF33CCFF, 0xFF33FFFF, 
0xFF660000, 0xFF663300, 0xFF666600, 0xFF669900, 0xFF66CC00, 0xFF66FF00, 0xFF660033, 0xFF663333, 
0xFF666633, 0xFF669933, 0xFF66CC33, 0xFF66FF33, 0xFF660066, 0xFF663366, 0xFF666666, 0xFF669966, 
0xFF66CC66, 0xFF66FF66, 0xFF660099, 0xFF663399, 0xFF666699, 0xFF669999, 0xFF66CC99, 0xFF66FF99, 
0xFF6600CC, 0xFF6633CC, 0xFF6666CC, 0xFF6699CC, 0xFF66CCCC, 0xFF66FFCC, 0xFF6600FF, 0xFF6633FF, 
0xFF6666FF, 0xFF6699FF, 0xFF66CCFF, 0xFF66FFFF, 0xFF990000, 0xFF993300, 0xFF996600, 0xFF999900, 
0xFF99CC00, 0xFF99FF00, 0xFF990033, 0xFF993333, 0xFF996633, 0xFF999933, 0xFF99CC33, 0xFF99FF33, 
0xFF990066, 0xFF993366, 0xFF996666, 0xFF999966, 0xFF99CC66, 0xFF99FF66, 0xFF990099, 0xFF993399, 
0xFF996699, 0xFF999999, 0xFF99CC99, 0xFF99FF99, 0xFF9900CC, 0xFF9933CC, 0xFF9966CC, 0xFF9999CC, 
0xFF99CCCC, 0xFF99FFCC, 0xFF9900FF, 0xFF9933FF, 0xFF9966FF, 0xFF9999FF, 0xFF99CCFF, 0xFF99FFFF, 
0xFFCC0000, 0xFFCC3300, 0xFFCC6600, 0xFFCC9900, 0xFFCCCC00, 0xFFCCFF00, 0xFFCC0033, 0xFFCC3333, 
0xFFCC6633, 0xFFCC9933, 0xFFCCCC33, 0xFFCCFF33, 0xFFCC0066, 0xFFCC3366, 0xFFCC6666, 0xFFCC9966, 
0xFFCCCC66, 0xFFCCFF66, 0xFFCC0099, 0xFFCC3399, 0xFFCC6699, 0xFFCC9999, 0xFFCCCC99, 0xFFCCFF99, 
0xFFCC00CC, 0xFFCC33CC, 0xFFCC66CC, 0xFFCC99CC, 0xFFCCCCCC, 0xFFCCFFCC, 0xFFCC00FF, 0xFFCC33FF, 
0xFFCC66FF, 0xFFCC99FF, 0xFFCCCCFF, 0xFFCCFFFF, 0xFFFF0000, 0xFFFF3300, 0xFFFF6600, 0xFFFF9900, 
0xFFFFCC00, 0xFFFFFF00, 0xFFFF0033, 0xFFFF3333, 0xFFFF6633, 0xFFFF9933, 0xFFFFCC33, 0xFFFFFF33, 
0xFFFF0066, 0xFFFF3366, 0xFFFF6666, 0xFFFF9966, 0xFFFFCC66, 0xFFFFFF66, 0xFFFF0099, 0xFFFF3399, 
0xFFFF6699, 0xFFFF9999, 0xFFFFCC99, 0xFFFFFF99, 0xFFFF00CC, 0xFFFF33CC, 0xFFFF66CC, 0xFFFF99CC, 
0xFFFFCCCC, 0xFFFFFFCC, 0xFFFF00FF, 0xFFFF33FF, 0xFFFF66FF, 0xFFFF99FF, 0xFFFFCCFF, 0xFFFFFFFF};'>
	^theTable! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar (auto pragmas 12/08) 10/27/1999 17:54'!
deltaFrom: x1 to: x2 nSteps: n
	"Utility routine for computing Warp increments."
	<inline: true>
	x2 > x1
		ifTrue: [^ x2 - x1 + FixedPt1 // (n+1) + 1]
		ifFalse: [x2 = x1 ifTrue: [^ 0].
				^ 0 - (x1 - x2 + FixedPt1 // (n+1) + 1)]! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 4/18/2001 23:02'!
destMaskAndPointerInit
	"Compute masks for left and right destination words"
	| startBits pixPerM1 endBits |
	<inline: true>
	pixPerM1 := destPPW - 1.  "A mask, assuming power of two"
	"how many pixels in first word"
	startBits := destPPW - (dx bitAnd: pixPerM1).
	destMSB
		ifTrue:[ mask1 := AllOnes >> (32 - (startBits*destDepth))] 
		ifFalse:[ mask1 := AllOnes << (32 - (startBits*destDepth))].
	"how many pixels in last word"
	endBits := ((dx + bbW - 1) bitAnd: pixPerM1) + 1.
	destMSB 
		ifTrue:[mask2 := AllOnes << (32 - (endBits*destDepth))] 
		ifFalse:[mask2 := AllOnes >> (32 - (endBits*destDepth))].
	"determine number of words stored per line; merge masks if only 1"
	bbW < startBits
		ifTrue: [mask1 := mask1 bitAnd: mask2.
				mask2 := 0.
				nWords := 1]
		ifFalse: [nWords := (bbW - startBits) + pixPerM1 // destPPW + 1].
	hDir := vDir := 1. "defaults for no overlap with source"

	"calculate byte addr and delta, based on first word of data"
	"Note pitch is bytes and nWords is longs, not bytes"
	destIndex := destBits + (dy * destPitch) + ((dx // destPPW) *4).
	destDelta := destPitch * vDir - (4 * (nWords * hDir)).  "byte addr delta"
! !
!BitBltSimulation methodsFor: 'combination rules'!
destinationWord: sourceWord with: destinationWord
	^destinationWord! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'JMM (auto pragmas 12/08) 7/4/2003 11:12'!
dither32To16: srcWord threshold: ditherValue
	"Dither the given 32bit word to 16 bit. Ignore alpha."
	| addThreshold  |
	<inline: true> "You bet"
	addThreshold := ditherValue bitShift: 8.
	^((dither8Lookup at: (addThreshold+((srcWord bitShift: -16) bitAnd: 255))) bitShift: 10) + 
		((dither8Lookup at: (addThreshold+((srcWord bitShift: -8) bitAnd: 255))) bitShift: 5) + 
		(dither8Lookup at: (addThreshold+(srcWord bitAnd: 255))).
! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 21:27'!
drawLoopX: xDelta Y: yDelta 
	"This is the primitive implementation of the line-drawing loop.
	See the comments in BitBlt>>drawLoopX:Y:"
	| dx1 dy1 px py P affL affR affT affB |
	xDelta > 0
		ifTrue: [dx1 := 1]
		ifFalse: [xDelta = 0
				ifTrue: [dx1 := 0]
				ifFalse: [dx1 := -1]].
	yDelta > 0
		ifTrue: [dy1 := 1]
		ifFalse: [yDelta = 0
				ifTrue: [dy1 := 0]
				ifFalse: [dy1 := -1]].
	px := yDelta abs.
	py := xDelta abs.
	affL := affT := 9999.  "init null rectangle"
	affR := affB := -9999.
	py > px
		ifTrue: 
			["more horizontal"
			P := py // 2.
			1 to: py do: 
				[:i |
				destX := destX + dx1.
				(P := P - px) < 0 ifTrue: 
					[destY := destY + dy1.
					P := P + py].
				i < py ifTrue:
					[self copyBits.
					interpreterProxy failed ifTrue:
						[^ nil "bail out now on failure -- avoid storing x,y"].
					(affectedL < affectedR and: [affectedT < affectedB]) ifTrue:
						["Affected rectangle grows along the line"
						affL := affL min: affectedL.
						affR := affR max: affectedR.
						affT := affT min: affectedT.
						affB := affB max: affectedB.
						(affR - affL) * (affB - affT) > 4000 ifTrue:
							["If affected rectangle gets large, update it in chunks"
							affectedL := affL.  affectedR := affR.
							affectedT := affT.  affectedB := affB.
							self showDisplayBits.
							affL := affT := 9999.  "init null rectangle"
							affR := affB := -9999]].
					]]]
		ifFalse: 
			["more vertical"
			P := px // 2.
			1 to: px do:
				[:i |
				destY := destY + dy1.
				(P := P - py) < 0 ifTrue: 
					[destX := destX + dx1.
					P := P + px].
				i < px ifTrue:
					[self copyBits.
					interpreterProxy failed ifTrue:
						[^ nil "bail out now on failure -- avoid storing x,y"].
					(affectedL < affectedR and: [affectedT < affectedB]) ifTrue:
						["Affected rectangle grows along the line"
						affL := affL min: affectedL.
						affR := affR max: affectedR.
						affT := affT min: affectedT.
						affB := affB max: affectedB.
						(affR - affL) * (affB - affT) > 4000 ifTrue:
							["If affected rectangle gets large, update it in chunks"
							affectedL := affL.  affectedR := affR.
							affectedT := affT.  affectedB := affB.
							self showDisplayBits.
							affL := affT := 9999.  "init null rectangle"
							affR := affB := -9999]].
					]]].

	"Remaining affected rect"
	affectedL := affL.  affectedR := affR.
	affectedT := affT.  affectedB := affB.

	"store destX, Y back"	
	interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.
	interpreterProxy storeInteger: BBDestYIndex ofObject: bitBltOop withValue: destY.! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:25'!
dstLongAt: idx

	^self long32At: idx! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:29'!
dstLongAt: idx put: value

	^self long32At: idx put: value! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'ar (auto pragmas 12/08) 12/7/1999 21:09'!
dstLongAt: idx put: srcValue mask: dstMask
	"Store the given value back into destination form, using dstMask
	to mask out the bits to be modified. This is an essiantial
	read-modify-write operation on the destination form."
	| dstValue |
	<inline: true>
	dstValue := self dstLongAt: idx.
	dstValue := dstValue bitAnd: dstMask.
	dstValue := dstValue bitOr: srcValue.
	self dstLongAt: idx put: dstValue.! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'JMM (auto pragmas 12/08) 7/3/2003 23:05'!
expensiveDither32To16: srcWord threshold: ditherValue
	"Dither the given 32bit word to 16 bit. Ignore alpha."
	| pv threshold value out |
	<inline: true> "You bet"
	pv := srcWord bitAnd: 255.
	threshold := ditherThresholds16 at: (pv bitAnd: 7).
	value := ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out := value + 1]
		ifFalse:[out := value].
	pv := (srcWord bitShift: -8) bitAnd: 255.
	threshold := ditherThresholds16 at: (pv bitAnd: 7).
	value := ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out := out bitOr: (value+1 bitShift:5)]
		ifFalse:[out := out bitOr: (value bitShift: 5)].
	pv := (srcWord bitShift: -16) bitAnd: 255.
	threshold := ditherThresholds16 at: (pv bitAnd: 7).
	value := ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out := out bitOr: (value+1 bitShift:10)]
		ifFalse:[out := out bitOr: (value bitShift: 10)].
	^out! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'tpr (auto pragmas dtl 2010-09-26) 12/29/2005 15:53'!
fetchIntOrFloat: fieldIndex ofObject: objectPointer
	"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
	| fieldOop floatValue |
	<var: #floatValue type: 'double '>
	fieldOop := interpreterProxy fetchPointer: fieldIndex ofObject: objectPointer.
	(interpreterProxy isIntegerObject: fieldOop)
		ifTrue:[^interpreterProxy integerValueOf: fieldOop].
	floatValue := interpreterProxy floatValueOf: fieldOop.
	(-2147483648.0 <= floatValue and:[floatValue <= 2147483647.0])
		ifFalse:[interpreterProxy primitiveFail. ^0].
	^floatValue asInteger! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'tpr (auto pragmas dtl 2010-09-26) 12/29/2005 15:53'!
fetchIntOrFloat: fieldIndex ofObject: objectPointer ifNil: defaultValue
	"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
	| fieldOop floatValue |
	<var: #floatValue type: 'double '>
	fieldOop := interpreterProxy fetchPointer: fieldIndex ofObject: objectPointer.
	(interpreterProxy isIntegerObject: fieldOop)
		ifTrue:[^interpreterProxy integerValueOf: fieldOop].
	(fieldOop = interpreterProxy nilObject) ifTrue:[^defaultValue].
	floatValue := interpreterProxy floatValueOf: fieldOop.
	(-2147483648.0 <= floatValue and:[floatValue <= 2147483647.0])
		ifFalse:[interpreterProxy primitiveFail. ^0].
	^floatValue asInteger! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 8/21/2002 20:58'!
fixAlpha: sourceWord with: destinationWord
	"For any non-zero pixel value in destinationWord with zero alpha channel take the alpha from sourceWord and fill it in. Intended for fixing alpha channels left at zero during 16->32 bpp conversions."
	destDepth = 32 ifFalse:[^destinationWord]. "no-op for non 32bpp"
	destinationWord = 0 ifTrue:[^0].
	(destinationWord bitAnd: 16rFF000000) = 0 ifFalse:[^destinationWord].
	^destinationWord bitOr: (sourceWord bitAnd: 16rFF000000)
! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:25'!
halftoneAt: idx
	"Return a value from the halftone pattern."

	^self long32At: halftoneBase + (idx \\ halftoneHeight * 4)! !
!BitBltSimulation methodsFor: 'setup'!
ignoreSourceOrHalftone: formPointer

	formPointer = interpreterProxy nilObject ifTrue: [ ^true ].
	combinationRule = 0 ifTrue: [ ^true ].
	combinationRule = 5 ifTrue: [ ^true ].
	combinationRule = 10 ifTrue: [ ^true ].
	combinationRule = 15 ifTrue: [ ^true ].
	^false! !
!BitBltSimulation methodsFor: 'initialize-release' stamp: 'ikp 6/10/2004 15:02'!
initBBOpTable
	self cCode: 'opTable[0+1] = (void *)clearWordwith'.
	self cCode: 'opTable[1+1] = (void *)bitAndwith'.
	self cCode: 'opTable[2+1] = (void *)bitAndInvertwith'.
	self cCode: 'opTable[3+1] = (void *)sourceWordwith'.
	self cCode: 'opTable[4+1] = (void *)bitInvertAndwith'.
	self cCode: 'opTable[5+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[6+1] = (void *)bitXorwith'.
	self cCode: 'opTable[7+1] = (void *)bitOrwith'.
	self cCode: 'opTable[8+1] = (void *)bitInvertAndInvertwith'.
	self cCode: 'opTable[9+1] = (void *)bitInvertXorwith'.
	self cCode: 'opTable[10+1] = (void *)bitInvertDestinationwith'.
	self cCode: 'opTable[11+1] = (void *)bitOrInvertwith'.
	self cCode: 'opTable[12+1] = (void *)bitInvertSourcewith'.
	self cCode: 'opTable[13+1] = (void *)bitInvertOrwith'.
	self cCode: 'opTable[14+1] = (void *)bitInvertOrInvertwith'.
	self cCode: 'opTable[15+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[16+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[17+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[18+1] = (void *)addWordwith'.
	self cCode: 'opTable[19+1] = (void *)subWordwith'.
	self cCode: 'opTable[20+1] = (void *)rgbAddwith'.
	self cCode: 'opTable[21+1] = (void *)rgbSubwith'.
	self cCode: 'opTable[22+1] = (void *)OLDrgbDiffwith'.
	self cCode: 'opTable[23+1] = (void *)OLDtallyIntoMapwith'.
	self cCode: 'opTable[24+1] = (void *)alphaBlendwith'.
	self cCode: 'opTable[25+1] = (void *)pixPaintwith'.
	self cCode: 'opTable[26+1] = (void *)pixMaskwith'.
	self cCode: 'opTable[27+1] = (void *)rgbMaxwith'.
	self cCode: 'opTable[28+1] = (void *)rgbMinwith'.
	self cCode: 'opTable[29+1] = (void *)rgbMinInvertwith'.
	self cCode: 'opTable[30+1] = (void *)alphaBlendConstwith'.
	self cCode: 'opTable[31+1] = (void *)alphaPaintConstwith'.
	self cCode: 'opTable[32+1] = (void *)rgbDiffwith'.
	self cCode: 'opTable[33+1] = (void *)tallyIntoMapwith'.
	self cCode: 'opTable[34+1] = (void *)alphaBlendScaledwith'.
	self cCode: 'opTable[35+1] = (void *)alphaBlendScaledwith'.
	self cCode: 'opTable[36+1] = (void *)alphaBlendScaledwith'.	
	self cCode: 'opTable[37+1] = (void *)rgbMulwith'.
	self cCode: 'opTable[38+1] = (void *)pixSwapwith'.
	self cCode: 'opTable[39+1] = (void *)pixClearwith'.
	self cCode: 'opTable[40+1] = (void *)fixAlphawith'.! !
!BitBltSimulation methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 7/4/2003 11:14'!
initDither8Lookup	
	<inline: false> 
	0 to: 255 do: [:b | 
		0 to: 15 do: [:t | | value |
			value := self expensiveDither32To16: b threshold: t.
			dither8Lookup at: ((t << 8)+b)put: value]].
	! !
!BitBltSimulation methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 7/4/2003 11:16'!
initialiseModule
	<export: true>
	self initBBOpTable.
	self initDither8Lookup.
	^true! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'tpr (auto pragmas dtl 2010-09-26) 12/29/2005 15:53'!
isIdentityMap: shifts with: masks
	"Return true if shiftTable/maskTable define an identity mapping."
	<var: #shifts type: 'int *'>
	<var: #masks type: 'unsigned int *'>
	(shifts == nil or:[masks == nil]) ifTrue:[^true].
	((shifts at: RedIndex) = 0 
		and:[(shifts at: GreenIndex) = 0
		and:[(shifts at: BlueIndex) = 0 
		and:[(shifts at: AlphaIndex) = 0
			and:[((masks at: RedIndex) = 16rFF0000)
			and:[((masks at: GreenIndex) = 16r00FF00)
			and:[((masks at: BlueIndex) = 16r0000FF)
			and:[((masks at: AlphaIndex) = 16rFF000000)]]]]]]])
		ifTrue:[^true].
	^false! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 19:48'!
loadBitBltDestForm
	"Load the dest form for BitBlt. Return false if anything is wrong, true otherwise."

	| destBitsSize |
	<inline: true>
	destBits := interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
	destWidth := interpreterProxy fetchInteger: FormWidthIndex ofObject: destForm.
	destHeight := interpreterProxy fetchInteger: FormHeightIndex ofObject: destForm.
	(destWidth >= 0 and: [destHeight >= 0])
		ifFalse: [^ false].
	destDepth := interpreterProxy fetchInteger: FormDepthIndex ofObject: destForm.
	destMSB := destDepth > 0.
	destDepth < 0 ifTrue:[destDepth := 0 - destDepth].
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: destBits) ifTrue:[
		"Query for actual surface dimensions"
		(self queryDestSurface: (interpreterProxy integerValueOf: destBits))
			ifFalse:[^false].
		destPPW := 32 // destDepth.
		destBits := destPitch := 0.
	] ifFalse:[
		destPPW := 32 // destDepth.
		destPitch := destWidth + (destPPW-1) // destPPW * 4.
		destBitsSize := interpreterProxy byteSizeOf: destBits.
		((interpreterProxy isWordsOrBytes: destBits)
			and: [destBitsSize = (destPitch * destHeight)])
			ifFalse: [^ false].
		"Skip header since external bits don't have one"
		destBits := self oopForPointer: (interpreterProxy firstIndexableField: destBits).
	].
	^true! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar (auto pragmas 12/08) 2/20/2000 19:42'!
loadBitBltFrom: bbObj
	"Load BitBlt from the oop.
	This function is exported for the Balloon engine."
	<export: true>
	^self loadBitBltFrom: bbObj warping: false.! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar (auto pragmas 12/08) 5/4/2001 14:49'!
loadBitBltFrom: bbObj warping: aBool
	"Load context from BitBlt instance.  Return false if anything is amiss"
	"NOTE this should all be changed to minX/maxX coordinates for simpler clipping
		-- once it works!!"
	| ok |
	<inline: false>
	bitBltOop := bbObj.
	isWarping := aBool.
	combinationRule := interpreterProxy fetchInteger: BBRuleIndex ofObject: bitBltOop.
	(interpreterProxy failed
		or: [combinationRule < 0 or: [combinationRule > (OpTableSize - 2)]])
		 ifTrue: [^ false  "operation out of range"].
	(combinationRule >= 16 and: [combinationRule <= 17])
		 ifTrue: [^ false  "fail for old simulated paint, erase modes"].
	sourceForm := interpreterProxy fetchPointer: BBSourceFormIndex ofObject: bitBltOop.
	noSource := self ignoreSourceOrHalftone: sourceForm.
	halftoneForm := interpreterProxy fetchPointer: BBHalftoneFormIndex ofObject: bitBltOop.
	noHalftone := self ignoreSourceOrHalftone: halftoneForm.

	destForm := interpreterProxy fetchPointer: BBDestFormIndex ofObject: bbObj.
	((interpreterProxy isPointers: destForm) and: [(interpreterProxy slotSizeOf: destForm) >= 4])
		ifFalse: [^ false].
	ok := self loadBitBltDestForm.
	ok ifFalse:[^false].

	destX := self fetchIntOrFloat: BBDestXIndex ofObject: bitBltOop ifNil: 0.
	destY := self fetchIntOrFloat: BBDestYIndex ofObject: bitBltOop ifNil: 0.
	width := self fetchIntOrFloat: BBWidthIndex ofObject: bitBltOop ifNil: destWidth.
	height := self fetchIntOrFloat: BBHeightIndex ofObject: bitBltOop ifNil: destHeight.
		interpreterProxy failed ifTrue: [^ false  "non-integer value"].

	noSource ifTrue:
		[sourceX := sourceY := 0]
		ifFalse: 
		[((interpreterProxy isPointers: sourceForm) and: [(interpreterProxy slotSizeOf: sourceForm) >= 4])
			ifFalse: [^ false].
		ok := self loadBitBltSourceForm.
		ok ifFalse:[^false].
		ok := self loadColorMap.
		ok ifFalse:[^false].
		"Need the implicit setup here in case of 16<->32 bit conversions"
		(cmFlags bitAnd: ColorMapNewStyle) = 0 ifTrue:[self setupColorMasks].
		sourceX := self fetchIntOrFloat: BBSourceXIndex ofObject: bitBltOop ifNil: 0.
		sourceY := self fetchIntOrFloat: BBSourceYIndex ofObject: bitBltOop ifNil: 0].

	ok := self loadHalftoneForm.
	ok ifFalse:[^false].
	clipX := self fetchIntOrFloat: BBClipXIndex ofObject: bitBltOop ifNil: 0.
	clipY := self fetchIntOrFloat: BBClipYIndex ofObject: bitBltOop ifNil: 0.
	clipWidth := self fetchIntOrFloat: BBClipWidthIndex ofObject: bitBltOop ifNil: destWidth.
	clipHeight := self fetchIntOrFloat: BBClipHeightIndex ofObject: bitBltOop ifNil: destHeight.
		interpreterProxy failed ifTrue: [^ false  "non-integer value"].
	clipX < 0 ifTrue: [clipWidth := clipWidth + clipX.  clipX := 0].
	clipY < 0 ifTrue: [clipHeight := clipHeight + clipY.  clipY := 0].
	clipX+clipWidth > destWidth ifTrue: [clipWidth := destWidth - clipX].
	clipY+clipHeight > destHeight ifTrue: [clipHeight := destHeight - clipY].
	^ true! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 19:48'!
loadBitBltSourceForm
	"Load the source form for BitBlt. Return false if anything is wrong, true otherwise."
	| sourceBitsSize |
	<inline: true>
	sourceBits := interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
	sourceWidth := self fetchIntOrFloat: FormWidthIndex ofObject: sourceForm.
	sourceHeight := self fetchIntOrFloat: FormHeightIndex ofObject: sourceForm.
	(sourceWidth >= 0 and: [sourceHeight >= 0])
		ifFalse: [^ false].
	sourceDepth := interpreterProxy fetchInteger: FormDepthIndex ofObject: sourceForm.
	sourceMSB := sourceDepth > 0.
	sourceDepth < 0 ifTrue:[sourceDepth := 0 - sourceDepth].
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: sourceBits) ifTrue:[
		"Query for actual surface dimensions"
		(self querySourceSurface: (interpreterProxy integerValueOf: sourceBits))
			ifFalse:[^false].
		sourcePPW := 32 // sourceDepth.
		sourceBits := sourcePitch := 0.
	] ifFalse:[
		sourcePPW := 32 // sourceDepth.
		sourcePitch := sourceWidth + (sourcePPW-1) // sourcePPW * 4.
		sourceBitsSize := interpreterProxy byteSizeOf: sourceBits.
		((interpreterProxy isWordsOrBytes: sourceBits)
			and: [sourceBitsSize = (sourcePitch * sourceHeight)])
			ifFalse: [^ false].
		"Skip header since external bits don't have one"
		sourceBits := self oopForPointer: (interpreterProxy firstIndexableField: sourceBits).
	].
	^true! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar (auto pragmas 12/08) 5/4/2001 14:54'!
loadColorMap
	"ColorMap, if not nil, must be longWords, and 
	2^N long, where N = sourceDepth for 1, 2, 4, 8 bits, 
	or N = 9, 12, or 15 (3, 4, 5 bits per color) for 16 or 32 bits."
	| cmSize oldStyle oop cmOop |
	<inline: true>
	cmFlags := cmMask := cmBitsPerColor := 0.
	cmShiftTable := nil.
	cmMaskTable := nil.
	cmLookupTable := nil.
	cmOop := interpreterProxy fetchPointer: BBColorMapIndex ofObject: bitBltOop.
	cmOop = interpreterProxy nilObject ifTrue:[^true].
	cmFlags := ColorMapPresent. "even if identity or somesuch - may be cleared later"
	oldStyle := false.
	(interpreterProxy isWords: cmOop) ifTrue:[
		"This is an old-style color map (indexed only, with implicit RGBA conversion)"
		cmSize := interpreterProxy slotSizeOf: cmOop.
		cmLookupTable := interpreterProxy firstIndexableField: cmOop.
		oldStyle := true.
	] ifFalse: [
		"A new-style color map (fully qualified)"
		((interpreterProxy isPointers: cmOop) 
			and:[(interpreterProxy slotSizeOf: cmOop) >= 3]) ifFalse:[^false].
		cmShiftTable := self loadColorMapShiftOrMaskFrom:
			(interpreterProxy fetchPointer: 0 ofObject: cmOop).
		cmMaskTable := self loadColorMapShiftOrMaskFrom:
			(interpreterProxy fetchPointer: 1 ofObject: cmOop).
		oop := interpreterProxy fetchPointer: 2 ofObject: cmOop.
		oop = interpreterProxy nilObject 
			ifTrue:[cmSize := 0]
			ifFalse:[(interpreterProxy isWords: oop) ifFalse:[^false].
					cmSize := (interpreterProxy slotSizeOf: oop).
					cmLookupTable := interpreterProxy firstIndexableField: oop].
		cmFlags := cmFlags bitOr: ColorMapNewStyle.
	].
	(cmSize bitAnd: cmSize - 1) = 0 ifFalse:[^false].
	cmMask := cmSize - 1.
	cmBitsPerColor := 0.
	cmSize = 512 ifTrue: [cmBitsPerColor := 3].
	cmSize = 4096 ifTrue: [cmBitsPerColor := 4].
	cmSize = 32768 ifTrue: [cmBitsPerColor := 5].
	cmSize = 0
		ifTrue:[cmLookupTable := nil. cmMask := 0]
		ifFalse:[cmFlags := cmFlags bitOr: ColorMapIndexedPart].
	oldStyle "needs implicit conversion"
		ifTrue:[	self setupColorMasks].
	"Check if colorMap is just identity mapping for RGBA parts"
	(self isIdentityMap: cmShiftTable with: cmMaskTable)
		ifTrue:[ cmMaskTable := nil. cmShiftTable := nil ]
		ifFalse:[ cmFlags := cmFlags bitOr: ColorMapFixedPart].
	^true! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar (auto pragmas dtl 2010-09-26) 5/4/2001 14:52'!
loadColorMapShiftOrMaskFrom: mapOop
	<returnTypeC: 'void *'>
	mapOop = interpreterProxy nilObject ifTrue:[^nil].
	(interpreterProxy isIntegerObject: mapOop) 
		ifTrue:[interpreterProxy primitiveFail. ^nil].
	((interpreterProxy isWords: mapOop) 
		and:[(interpreterProxy slotSizeOf: mapOop) = 4])
			ifFalse:[interpreterProxy primitiveFail. ^nil].
	^interpreterProxy firstIndexableField: mapOop! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 19:49'!
loadHalftoneForm
	"Load the halftone form"
	| halftoneBits |
	<inline: true>
	noHalftone ifTrue:[
		halftoneBase := nil.
		^true].
	((interpreterProxy isPointers: halftoneForm) and: [(interpreterProxy slotSizeOf: halftoneForm) >= 4])
		ifTrue:
		["Old-style 32xN monochrome halftone Forms"
		halftoneBits := interpreterProxy fetchPointer: FormBitsIndex ofObject: halftoneForm.
		halftoneHeight := interpreterProxy fetchInteger: FormHeightIndex ofObject: halftoneForm.
		(interpreterProxy isWords: halftoneBits)
			ifFalse: [noHalftone := true]]
		ifFalse:
		["New spec accepts, basically, a word array"
		((interpreterProxy isPointers: halftoneForm) not
			and: [interpreterProxy isWords: halftoneForm])
			ifFalse: [^ false].
		halftoneBits := halftoneForm.
		halftoneHeight := interpreterProxy slotSizeOf: halftoneBits].
	halftoneBase := self oopForPointer: (interpreterProxy firstIndexableField: halftoneBits).
	^true! !
!BitBltSimulation methodsFor: 'surface support' stamp: 'ar 4/18/2001 21:23'!
loadSurfacePlugin
	"Load the surface support plugin"
	querySurfaceFn := interpreterProxy ioLoadFunction:'ioGetSurfaceFormat' From:'SurfacePlugin'.
	lockSurfaceFn := interpreterProxy ioLoadFunction:'ioLockSurface' From:'SurfacePlugin'.
	unlockSurfaceFn := interpreterProxy ioLoadFunction:'ioUnlockSurface' From:'SurfacePlugin'.
	^querySurfaceFn ~= 0 and:[lockSurfaceFn ~= 0 and:[unlockSurfaceFn ~= 0]]! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 10/27/1999 16:03'!
loadWarpBltFrom: bbObj
	^self loadBitBltFrom: bbObj warping: true! !
!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp (auto pragmas dtl 2010-09-26) 6/9/2004 22:51'!
lockSurfaces
	"Get a pointer to the bits of any OS surfaces."
	"Notes: 
	* For equal source/dest handles only one locking operation is performed.
	This is to prevent locking of overlapping areas which does not work with
	certain APIs (as an example, DirectDraw prevents locking of overlapping areas). 
	A special case for non-overlapping but equal source/dest handle would 
	be possible but we would have to transfer this information over to 
	unlockSurfaces somehow (currently, only one unlock operation is 
	performed for equal source and dest handles). Also, this would require
	a change in the notion of ioLockSurface() which is right now interpreted
	as a hint and not as a requirement to lock only the specific portion of
	the surface.

	* The arguments in ioLockSurface() provide the implementation with
	an explicit hint what area is affected. It can be very useful to
	know the max. affected area beforehand if getting the bits requires expensive
	copy operations (e.g., like a roundtrip to the X server or a glReadPixel op).
	However, the returned pointer *MUST* point to the virtual origin of the surface
	and not to the beginning of the rectangle. The promise made by BitBlt
	is to never access data outside the given rectangle (aligned to 4byte boundaries!!)
	so it is okay to return a pointer to the virtual origin that is actually outside
	the valid memory area.

	* The area provided in ioLockSurface() is already clipped (e.g., it will always
	be inside the source and dest boundingBox) but it is not aligned to word boundaries
	yet. It is up to the support code to compute accurate alignment if necessary.

	* Warping always requires the entire source surface to be locked because
	there is no beforehand knowledge about what area will actually be traversed.

	"
	| sourceHandle destHandle l r t b fn |
	<inline: true>
	<var: #fn declareC: 'sqInt (*fn)(sqInt, sqInt*, sqInt, sqInt, sqInt, sqInt)'>
	hasSurfaceLock := false.
	destBits = 0 ifTrue:["Blitting *to* OS surface"
		lockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn := self cCoerce: lockSurfaceFn to: 'sqInt (*)(sqInt, sqInt*, sqInt, sqInt, sqInt, sqInt)'.
		destHandle := interpreterProxy fetchInteger: FormBitsIndex ofObject: destForm.
		(sourceBits = 0 and:[noSource not]) ifTrue:[
			sourceHandle := interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
			"Handle the special case of equal source and dest handles"
			(sourceHandle = destHandle) ifTrue:[
				"If we have overlapping source/dest we lock the entire area
				so that there is only one area transmitted"
				isWarping ifFalse:[
					"When warping we always need the entire surface for the source"
					sourceBits := self cCode:'fn(sourceHandle, &sourcePitch, 0,0, sourceWidth, sourceHeight)'.
				] ifTrue:[
					"Otherwise use overlapping area"
					l := sx min: dx. r := (sx max: dx) + bbW.
					t := sy min: dy. b := (sy max: sy) + bbH.
					sourceBits := self cCode:'fn(sourceHandle, &sourcePitch, l, t, r-l, b-t)'.
				].
				destBits := sourceBits.
				destPitch := sourcePitch.
				hasSurfaceLock := true.
				^destBits ~~ 0
			].
			"Fall through - if not equal it'll be handled below"
		].
		destBits := self cCode:'fn(destHandle, &destPitch, dx, dy, bbW, bbH)'.
		hasSurfaceLock := true.
	].
	(sourceBits == 0 and:[noSource not]) ifTrue:["Blitting *from* OS surface"
		sourceHandle := interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
		lockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn := self cCoerce: lockSurfaceFn to: 'sqInt (*)(sqInt, sqInt*, sqInt, sqInt, sqInt, sqInt)'.
		"Warping requiring the entire surface"
		isWarping ifTrue:[
			sourceBits := self cCode:'fn(sourceHandle, &sourcePitch, 0, 0, sourceWidth, sourceHeight)'.
		] ifFalse:[
			sourceBits := self cCode:'fn(sourceHandle, &sourcePitch, sx, sy, bbW, bbH)'.
		].
		hasSurfaceLock := true.
	].
	^destBits ~~ 0 and:[sourceBits ~~ 0 or:[noSource]].! !
!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar (auto pragmas 12/08) 4/26/2001 21:57'!
mapPixel: sourcePixel flags: mapperFlags
	"Color map the given source pixel."
	| pv |
	<inline: true>
	pv := sourcePixel.
	(mapperFlags bitAnd: ColorMapPresent) ~= 0 ifTrue:[
		(mapperFlags bitAnd: ColorMapFixedPart) ~= 0 ifTrue:[
			pv := self rgbMapPixel: sourcePixel flags: mapperFlags.
			"avoid introducing transparency by color reduction"
			(pv = 0 and:[sourcePixel ~= 0]) ifTrue:[pv := 1]].
		(mapperFlags bitAnd: ColorMapIndexedPart) ~= 0
			ifTrue:[pv := cmLookupTable at: (pv bitAnd: cmMask)].
	].
	^pv! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ikp (auto pragmas 12/08) 6/11/2004 16:38'!
merge: sourceWord with: destinationWord
	| mergeFnwith |
	"Sender warpLoop is too big to include this in-line"
	<var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'>
	mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	^ self mergeFn: sourceWord with: destinationWord! !
!BitBltSimulation methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/4/2001 14:46'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	<export: true>
	<var: #aModuleName type: 'char *'>
	(aModuleName strcmp: 'SurfacePlugin') = 0 ifTrue:[
		"The surface plugin just shut down. How nasty."
		querySurfaceFn := lockSurfaceFn := unlockSurfaceFn := 0.
	].! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:18'!
partitionedAND: word1 to: word2 nBits: nBits nPartitions: nParts
	"AND word1 to word2 as nParts partitions of nBits each.
	Any field of word1 not all-ones is treated as all-zeroes.
	Used for erasing, eg, brush shapes prior to ORing in a color"
	| mask result |
	mask := maskTable at: nBits.  "partition mask starts at the right"
	result := 0.
	1 to: nParts do:
		[:i |
		(word1 bitAnd: mask) = mask
			ifTrue: [result := result bitOr: (word2 bitAnd: mask)].
		mask := mask << nBits  "slide left to next partition"].
	^ result
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 10/26/2009 08:58'!
partitionedAdd: word1 to: word2 nBits: nBits nPartitions: nParts
	"Add word1 to word2 as nParts partitions of nBits each.
	This is useful for packed pixels, or packed colors"
	| mask sum result maskedWord1 |
	"In C, most arithmetic operations answer the same bit pattern regardless of the operands being signed or unsigned ints
	(this is due to the way 2's complement numbers work). However, comparisions might fail. Add the proper declaration of
	words as unsigned int in those cases where comparisions are done (jmv)"
	<var: #word1 type: 'unsigned int'>
	<var: #word2 type: 'unsigned int'>
	<var: #mask type: 'unsigned int'>
	<var: #sum type: 'unsigned int'>
	<var: #result type: 'unsigned int'>
	<var: #maskedWord1 type: 'unsigned int'>
	mask := maskTable at: nBits.  "partition mask starts at the right"
	result := 0.
	1 to: nParts do:
		[:i |
		maskedWord1 := word1 bitAnd: mask.
		sum := maskedWord1 + (word2 bitAnd: mask).
		(sum <= mask "result must not carry out of partition"
				and: [ sum >= maskedWord1 ])	"This is needed because in C, integer arithmetic overflows silently!! (jmv)"
			ifTrue: [result := result bitOr: sum]
			ifFalse: [result := result bitOr: mask].
		mask := mask << nBits  "slide left to next partition"].
	^ result
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 10/26/2009 08:59'!
partitionedMax: word1 with: word2 nBits: nBits nPartitions: nParts
	"Max word1 to word2 as nParts partitions of nBits each"
	| mask result |
	"In C, most arithmetic operations answer the same bit pattern regardless of the operands being signed or unsigned ints
	(this is due to the way 2's complement numbers work). However, comparisions might fail. Add the proper declaration of
	words as unsigned int in those cases where comparisions are done (jmv)"
	<var: #word1 type: 'unsigned int'>
	<var: #word2 type: 'unsigned int'>
	<var: #mask type: 'unsigned int'>
	<var: #result type: 'unsigned int'>
	mask := maskTable at: nBits.  "partition mask starts at the right"
	result := 0.
	1 to: nParts do:
		[:i |
		result := result bitOr: ((word2 bitAnd: mask) max: (word1 bitAnd: mask)).
		mask := mask << nBits  "slide left to next partition"].
	^ result
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 10/26/2009 08:59'!
partitionedMin: word1 with: word2 nBits: nBits nPartitions: nParts
	"Min word1 to word2 as nParts partitions of nBits each"
	| mask result |
	"In C, most arithmetic operations answer the same bit pattern regardless of the operands being signed or unsigned ints
	(this is due to the way 2's complement numbers work). However, comparisions might fail. Add the proper declaration of
	words as unsigned int in those cases where comparisions are done (jmv)"
	<var: #word1 type: 'unsigned int'>
	<var: #word2 type: 'unsigned int'>
	<var: #mask type: 'unsigned int'>
	<var: #result type: 'unsigned int'>
	mask := maskTable at: nBits.  "partition mask starts at the right"
	result := 0.
	1 to: nParts do:
		[:i |
		result := result bitOr: ((word2 bitAnd: mask) min: (word1 bitAnd: mask)).
		mask := mask << nBits  "slide left to next partition"].
	^ result
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 10/26/2009 09:01'!
partitionedMul: word1 with: word2 nBits: nBits nPartitions: nParts
	"Multiply word1 with word2 as nParts partitions of nBits each.
	This is useful for packed pixels, or packed colors.
	Bug in loop version when non-white background"

	| sMask product result dMask |
	"In C, integer multiplication might answer a wrong value if the unsigned values are declared as signed.
	This problem does not affect this method, because the most significant bit (i.e. the sign bit) will
	always be zero (jmv)"
	sMask := maskTable at: nBits.  "partition mask starts at the right"
	dMask :=  sMask << nBits.
	result := (((word1 bitAnd: sMask)+1) * ((word2 bitAnd: sMask)+1) - 1 
				bitAnd: dMask) >> nBits.	"optimized first step"
	nParts = 1
		ifTrue: [ ^result ].
	product := (((word1>>nBits bitAnd: sMask)+1) * ((word2>>nBits bitAnd: sMask)+1) - 1 bitAnd: dMask).
	result := result bitOr: product.
	nParts = 2
		ifTrue: [ ^result ].
	product := (((word1>>(2*nBits) bitAnd: sMask)+1) * ((word2>>(2*nBits) bitAnd: sMask)+1) - 1 bitAnd: dMask).
	result := result bitOr: product << nBits.
	nParts = 3
		ifTrue: [ ^result ].
	product := (((word1>>(3*nBits) bitAnd: sMask)+1) * ((word2>>(3*nBits) bitAnd: sMask)+1) - 1 bitAnd: dMask).
	result := result bitOr: product << (2*nBits).
	^ result

"	| sMask product result dMask |
	sMask := maskTable at: nBits.  'partition mask starts at the right'
	dMask :=  sMask << nBits.
	result := (((word1 bitAnd: sMask)+1) * ((word2 bitAnd: sMask)+1) - 1 
				bitAnd: dMask) >> nBits.	'optimized first step'
	nBits to: nBits * (nParts-1) by: nBits do: [:ofs |
		product := (((word1>>ofs bitAnd: sMask)+1) * ((word2>>ofs bitAnd: sMask)+1) - 1 bitAnd: dMask).
		result := result bitOr: (product bitAnd: dMask) << (ofs-nBits)].
	^ result"! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 10/26/2009 08:59'!
partitionedSub: word1 from: word2 nBits: nBits nPartitions: nParts
	"Subtract word1 from word2 as nParts partitions of nBits each.
	This is useful for packed pixels, or packed colors"
	| mask result p1 p2 |
	"In C, most arithmetic operations answer the same bit pattern regardless of the operands being signed or unsigned ints
	(this is due to the way 2's complement numbers work). However, comparisions might fail. Add the proper declaration of
	words as unsigned int in those cases where comparisions are done (jmv)"
	<var: #word1 type: 'unsigned int'>
	<var: #word2 type: 'unsigned int'>
	<var: #p1 type: 'unsigned int'>
	<var: #p2 type: 'unsigned int'>
	<var: #mask type: 'unsigned int'>
	<var: #result type: 'unsigned int'>
	mask := maskTable at: nBits.  "partition mask starts at the right"
	result := 0.
	1 to: nParts do:
		[:i |
		p1 := word1 bitAnd: mask.
		p2 := word2 bitAnd: mask.
		p1 < p2  "result is really abs value of thedifference"
			ifTrue: [result := result bitOr: p2 - p1]
			ifFalse: [result := result bitOr: p1 - p2].
		mask := mask << nBits  "slide left to next partition"].
	^ result
! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 4/26/2001 19:42'!
performCopyLoop
	"Based on the values provided during setup choose and
	perform the appropriate inner loop function."
	<inline: true> "Should be inlined into caller for speed"
	self destMaskAndPointerInit.
	noSource ifTrue: ["Simple fill loop"
		self copyLoopNoSource.
	] ifFalse: ["Loop using source and dest"
		self checkSourceOverlap.
		(sourceDepth ~= destDepth or: [(cmFlags ~= 0) or:[sourceMSB ~= destMSB]]) ifTrue: [
			"If we must convert between pixel depths or use
			color lookups or swap pixels use the general version"
			self copyLoopPixMap.
		] ifFalse: [
			"Otherwise we simple copy pixels and can use a faster version"
			self sourceSkewAndPointerInit.
			self copyLoop.
		]
	].! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'di (auto pragmas 12/08) 9/23/2001 10:26'!
pickSourcePixels: nPixels flags: mapperFlags srcMask: srcMask destMask: dstMask srcShiftInc: srcShiftInc dstShiftInc: dstShiftInc
	"Pick nPix pixels starting at srcBitIndex from the source, map by the
	color map, and justify them according to dstBitIndex in the resulting destWord."
	| sourceWord destWord sourcePix destPix srcShift dstShift nPix |
	<inline: true> "oh please"
	sourceWord := self srcLongAt: sourceIndex.
	destWord := 0.
	srcShift := srcBitShift. "Hint: Keep in register"
	dstShift := dstBitShift. "Hint: Keep in register"
	nPix := nPixels. "always > 0 so we can use do { } while(--nPix);"
	(mapperFlags = (ColorMapPresent bitOr: ColorMapIndexedPart)) ifTrue:[
		"a little optimization for (pretty crucial) blits using indexed lookups only"
		[	"grab, colormap and mix in pixel"
			sourcePix := sourceWord >> srcShift bitAnd: srcMask.
			destPix := self tableLookup: cmLookupTable at: (sourcePix bitAnd: cmMask).
			destWord := destWord bitOr: (destPix bitAnd: dstMask) << dstShift.
			"adjust dest pix index"
			dstShift := dstShift + dstShiftInc.
			"adjust source pix index"
			((srcShift := srcShift + srcShiftInc) bitAnd: 16rFFFFFFE0) = 0 ifFalse:[
				sourceMSB ifTrue:[srcShift := srcShift + 32] ifFalse:[srcShift := srcShift - 32].
				sourceWord := self srcLongAt: (sourceIndex := sourceIndex + 4)].
		(nPix := nPix - 1) = 0] whileFalse.
	] ifFalse:[
		[	"grab, colormap and mix in pixel"
			sourcePix := sourceWord >> srcShift bitAnd: srcMask.
			destPix := self mapPixel: sourcePix flags: mapperFlags.
			destWord := destWord bitOr: (destPix bitAnd: dstMask) << dstShift.
			"adjust dest pix index"
			dstShift := dstShift + dstShiftInc.
			"adjust source pix index"
			((srcShift := srcShift + srcShiftInc) bitAnd: 16rFFFFFFE0) = 0 ifFalse:[
				sourceMSB ifTrue:[srcShift := srcShift + 32] ifFalse:[srcShift := srcShift - 32].
				sourceWord := self srcLongAt: (sourceIndex := sourceIndex + 4)].
		(nPix := nPix - 1) = 0] whileFalse.
	].
	srcBitShift := srcShift. "Store back"
	^destWord
! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar (auto pragmas 12/08) 4/18/2001 21:15'!
pickWarpPixelAtX: xx y: yy
	"Pick a single pixel from the source for WarpBlt.
	Note: This method is crucial for WarpBlt speed w/o smoothing
	and still relatively important when smoothing is used."
	| x y srcIndex sourceWord sourcePix |
	<inline: true> "*please*"

	"note: it would be much faster if we could just
	avoid these stupid tests for being inside sourceForm."
	(xx < 0 or:[yy < 0 or:[
		(x := xx >> BinaryPoint) >= sourceWidth or:[
			(y := yy >> BinaryPoint) >= sourceHeight]]]) ifTrue:[^0]. "out of bounds"

	"Fetch source word.
	Note: We should really update srcIndex with sx and sy so that
	we don't have to do the computation below. We might even be
	able to simplify the out of bounds test from above."
	srcIndex := sourceBits + (y * sourcePitch) + (x >> warpAlignShift * 4).
	sourceWord := self srcLongAt: srcIndex.

	"Extract pixel from word"
	srcBitShift := warpBitShiftTable at: (x bitAnd: warpAlignMask).
	sourcePix := sourceWord >> srcBitShift bitAnd: warpSrcMask.
	^sourcePix! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 6/16/2002 19:53'!
pixClear: sourceWord with: destinationWord
	"Clear all pixels in destinationWord for which the pixels of sourceWord have the same values. Used to clear areas of some constant color to zero."
	| mask result nBits pv |
	<inline: false>
	destDepth = 32 ifTrue:[
		sourceWord = destinationWord ifTrue:[^0] ifFalse:[^destinationWord].
	].
	nBits := destDepth.
	mask := maskTable at: nBits.  "partition mask starts at the right"
	result := 0.
	1 to: destPPW do:[:i |
		pv := destinationWord bitAnd: mask.
		(sourceWord bitAnd: mask) = pv ifTrue:[pv := 0].
		result := result bitOr: pv.
		mask := mask << nBits "slide left to next partition"].
	^ result! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 4/18/2001 20:39'!
pixMask: sourceWord with: destinationWord
	<inline: false>
	^ self partitionedAND: sourceWord bitInvert32 to: destinationWord
					nBits: destDepth nPartitions: destPPW! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 4/18/2001 20:39'!
pixPaint: sourceWord with: destinationWord
	<inline: false>
	sourceWord = 0 ifTrue: [^ destinationWord].
	^ sourceWord bitOr:
		(self partitionedAND: sourceWord bitInvert32 to: destinationWord
						nBits: destDepth nPartitions: destPPW)! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 4/19/2001 15:38'!
pixSwap: sourceWord with: destWord
	"Swap the pixels in destWord"
	| result shift lowMask highMask |
	<inline: false>
	destPPW = 1 ifTrue:[^destWord]. "a single pixel per word"
	result := 0.
	lowMask := (1 << destDepth) - 1. "mask low pixel"
	highMask := lowMask << (destPPW-1 * destDepth). "mask high pixel"
	shift := 32 - destDepth.
	result := result bitOr: (
				(destWord bitAnd: lowMask) << shift bitOr:
					(destWord bitAnd: highMask) >> shift).
	destPPW <= 2 ifTrue:[^result].
	2 to: destPPW // 2 do:[:i|
		lowMask := lowMask << destDepth.
		highMask := highMask >> destDepth.
		shift := shift - (destDepth * 2).
		result := result bitOr: (
					(destWord bitAnd: lowMask) << shift bitOr:
						(destWord bitAnd: highMask) >> shift)].
	^result! !
!BitBltSimulation methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 13:06'!
primitiveCopyBits
	"Invoke the copyBits primitive. If the destination is the display, then copy it to the screen."
	| rcvr |
	<export: true>
	rcvr := interpreterProxy stackValue: interpreterProxy methodArgumentCount.
	(self loadBitBltFrom: rcvr)  ifFalse:[^interpreterProxy primitiveFail].
	self copyBits.
	interpreterProxy failed ifTrue:[^nil].
	self showDisplayBits.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: interpreterProxy methodArgumentCount.
	(combinationRule = 22) | (combinationRule = 32) ifTrue:[
		interpreterProxy pop: 1.
		^ interpreterProxy pushInteger: bitCount].! !
!BitBltSimulation methodsFor: 'primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/31/2008 18:18'!
primitiveDisplayString

	| kernDelta xTable glyphMap stopIndex startIndex sourceString bbObj maxGlyph ascii glyphIndex sourcePtr left quickBlt |
	<export: true>
	<var: #sourcePtr type: 'char *'>
	interpreterProxy methodArgumentCount = 6 
		ifFalse:[^interpreterProxy primitiveFail].
	kernDelta := interpreterProxy stackIntegerValue: 0.
	xTable := interpreterProxy stackObjectValue: 1.
	glyphMap := interpreterProxy stackObjectValue: 2.
	((interpreterProxy fetchClassOf: xTable) = interpreterProxy classArray and:[
		(interpreterProxy fetchClassOf: glyphMap) = interpreterProxy classArray])
			ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: glyphMap) = 256 ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifTrue:[^nil].
	maxGlyph := (interpreterProxy slotSizeOf: xTable) - 2.

	stopIndex := interpreterProxy stackIntegerValue: 3.
	startIndex := interpreterProxy stackIntegerValue: 4.
	sourceString := interpreterProxy stackObjectValue: 5.
	(interpreterProxy isBytes: sourceString) ifFalse:[^interpreterProxy primitiveFail].
	(startIndex > 0 and:[stopIndex > 0 and:[
		stopIndex <= (interpreterProxy byteSizeOf: sourceString)]])
			ifFalse:[^interpreterProxy primitiveFail].

	bbObj := interpreterProxy stackObjectValue: 6.
	(self loadBitBltFrom: bbObj) ifFalse:[^interpreterProxy primitiveFail].
	(combinationRule = 30 or:[combinationRule = 31]) "needs extra source alpha"
		ifTrue:[^interpreterProxy primitiveFail].
	"See if we can go directly into copyLoopPixMap (usually we can)"
	quickBlt := destBits ~= 0 "no OS surfaces please"
				and:[sourceBits ~= 0 "and again"
				and:[noSource = false "needs a source"
				and:[sourceForm ~= destForm "no blits onto self"
				and:[(cmFlags ~= 0 
						or:[sourceMSB ~= destMSB 
						or:[sourceDepth ~= destDepth]]) "no point using slower version"
				]]]].
	left := destX.
	sourcePtr := interpreterProxy firstIndexableField: sourceString.
	startIndex to: stopIndex do:[:charIndex|
		ascii := self byteAtPointer: sourcePtr + charIndex - 1.
		glyphIndex := interpreterProxy fetchInteger: ascii ofObject: glyphMap.
		(glyphIndex < 0 or:[glyphIndex > maxGlyph]) 
			ifTrue:[^interpreterProxy primitiveFail].
		sourceX := interpreterProxy fetchInteger: glyphIndex ofObject: xTable.
		width := (interpreterProxy fetchInteger: glyphIndex+1 ofObject: xTable) - sourceX.
		interpreterProxy failed ifTrue:[^nil].
		self clipRange.	"Must clip here"
		(bbW > 0 and:[bbH > 0]) ifTrue: [
			quickBlt ifTrue:[
				self destMaskAndPointerInit.
				self copyLoopPixMap.
				"both, hDir and vDir are known to be > 0"
				affectedL := dx.
				affectedR := dx + bbW.
				affectedT := dy.
				affectedB := dy + bbH.
			] ifFalse:[self copyBits]].
		interpreterProxy failed ifTrue:[^nil].
		destX := destX + width + kernDelta.
	 ].
	affectedL := left.
	self showDisplayBits.
	interpreterProxy pop: 6. "pop args, return rcvr"! !
!BitBltSimulation methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 13:56'!
primitiveDrawLoop
	"Invoke the line drawing primitive."
	| rcvr xDelta yDelta |
	<export: true>
	rcvr := interpreterProxy stackValue: 2.
	xDelta := interpreterProxy stackIntegerValue: 1.
	yDelta := interpreterProxy stackIntegerValue: 0.
	(self loadBitBltFrom: rcvr) ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifFalse:[
		self drawLoopX: xDelta Y: yDelta.
		self showDisplayBits].
	interpreterProxy failed ifFalse:[interpreterProxy pop: 2].! !
!BitBltSimulation methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 2/20/2001 21:10'!
primitiveWarpBits
	"Invoke the warpBits primitive. If the destination is the display, then copy it to the screen."
	| rcvr |
	<export: true>
	rcvr := interpreterProxy stackValue: interpreterProxy methodArgumentCount.
	(self loadWarpBltFrom: rcvr) 
		ifFalse:[^interpreterProxy primitiveFail].
	self warpBits.
	interpreterProxy failed ifTrue:[^nil].
	self showDisplayBits.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: interpreterProxy methodArgumentCount.! !
!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp 6/9/2004 22:52'!
queryDestSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	querySurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^false]].
	^(self cCode:' ((sqInt (*) (sqInt, sqInt*, sqInt*, sqInt*, sqInt*))querySurfaceFn)
		(handle, &destWidth, &destHeight, &destDepth, &destMSB)'
			 inSmalltalk:[false])! !
!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp 6/9/2004 22:57'!
querySourceSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	querySurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^false]].
	^(self cCode:' ((sqInt (*) (sqInt, sqInt*, sqInt*, sqInt*, sqInt*))querySurfaceFn)
		(handle, &sourceWidth, &sourceHeight, &sourceDepth, &sourceMSB)'
			inSmalltalk:[false])! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 4/1/2009 08:39'!
rgbAdd: sourceWord with: destinationWord
	<inline: false>
	destDepth < 16 ifTrue:
		["Add each pixel separately"
		^ self partitionedAdd: sourceWord to: destinationWord
						nBits: destDepth nPartitions: destPPW].
	destDepth = 16 ifTrue:
		["Add RGB components of each pixel separately"
		^ (self partitionedAdd: sourceWord to: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedAdd: sourceWord>>16 to: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Add RGBA components of the pixel separately"
		^ self partitionedAdd: sourceWord to: destinationWord
						nBits: 8 nPartitions: 4]! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 4/18/2001 20:38'!
rgbDiff: sourceWord with: destinationWord
	"Subract the pixels in the source and destination, color by color,
	and return the sum of the absolute value of all the differences.
	For non-rgb, return the number of differing pixels."
	| pixMask destShifted sourceShifted destPixVal bitsPerColor rgbMask sourcePixVal diff maskShifted |
	<inline: false>
	pixMask := maskTable at: destDepth.
	destDepth = 16
		ifTrue: [bitsPerColor := 5.  rgbMask := 16r1F]
		ifFalse: [bitsPerColor := 8.  rgbMask := 16rFF].
	maskShifted := destMask.
	destShifted := destinationWord.
	sourceShifted := sourceWord.
	1 to: destPPW do:
		[:i |
		(maskShifted bitAnd: pixMask) > 0 ifTrue:
			["Only tally pixels within the destination rectangle"
			destPixVal := destShifted bitAnd: pixMask.
			sourcePixVal := sourceShifted bitAnd: pixMask.
			destDepth < 16
				ifTrue: [sourcePixVal = destPixVal
							ifTrue: [diff := 0]
							ifFalse: [diff := 1]]
				ifFalse: [diff := (self partitionedSub: sourcePixVal from: destPixVal
								nBits: bitsPerColor nPartitions: 3).
						diff := (diff bitAnd: rgbMask)
							+ (diff>>bitsPerColor bitAnd: rgbMask)
							+ ((diff>>bitsPerColor)>>bitsPerColor bitAnd: rgbMask)].
			bitCount := bitCount + diff].
		maskShifted := maskShifted >> destDepth.
		sourceShifted := sourceShifted >> destDepth.
		destShifted := destShifted >> destDepth].
	^ destinationWord  "For no effect on dest"
! !
!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 10/28/1999 16:02'!
rgbMap16To32: sourcePixel
	"Convert the given 16bit pixel value to a 32bit RGBA value.
 	Note: This method is intended to deal with different source formats."
	^(((sourcePixel bitAnd: 31) << 3) bitOr:
		((sourcePixel bitAnd: 16r3E0) << 6)) bitOr:
			((sourcePixel bitAnd: 16r7C00) << 9)! !
!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 10/27/1999 14:28'!
rgbMap32To32: sourcePixel
	"Convert the given 32bit pixel value to a 32bit RGBA value.
 	Note: This method is intended to deal with different source formats."
	^sourcePixel "For now do it simple"! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di (auto pragmas 12/08) 4/10/1999 17:27'!
rgbMap: sourcePixel from: nBitsIn to: nBitsOut
	"Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."
	| mask d srcPix destPix |
	<inline: true>
	(d := nBitsOut - nBitsIn) > 0
		ifTrue:
			["Expand to more bits by zero-fill"
			mask := (1 << nBitsIn) - 1.  "Transfer mask"
			srcPix := sourcePixel << d.
			mask := mask << d.
			destPix := srcPix bitAnd: mask.
			mask := mask << nBitsOut.
			srcPix := srcPix << d.
			^ destPix + (srcPix bitAnd: mask)
				 	+ (srcPix << d bitAnd: mask << nBitsOut)]
		ifFalse:
			["Compress to fewer bits by truncation"
			d = 0 ifTrue:
				[nBitsIn = 5 ifTrue:
					["Sometimes called with 16 bits, though pixel is 15,
					but we must never return more than 15."
					^ sourcePixel bitAnd: 16r7FFF].
				nBitsIn = 8 ifTrue:
					["Sometimes called with 32 bits, though pixel is 24,
					but we must never return more than 24."
					^ sourcePixel bitAnd: 16rFFFFFF].
				^ sourcePixel].  "no compression"
			sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"
			d := nBitsIn - nBitsOut.
			mask := (1 << nBitsOut) - 1.  "Transfer mask"
			srcPix := sourcePixel >> d.
			destPix := srcPix bitAnd: mask.
			mask := mask << nBitsOut.
			srcPix := srcPix >> d.
			destPix := destPix + (srcPix bitAnd: mask)
					+ (srcPix >> d bitAnd: mask << nBitsOut).
			destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"
			^ destPix]! !
!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar (auto pragmas 12/08) 4/26/2001 18:37'!
rgbMapPixel: sourcePixel flags: mapperFlags
	"Perform the RGBA conversion for the given source pixel"
	| val |
	<inline: true>
	val := 			((sourcePixel bitAnd: (cmMaskTable at: 0)) bitShift: (cmShiftTable at: 0)).
	val := val bitOr: ((sourcePixel bitAnd: (cmMaskTable at: 1)) bitShift: (cmShiftTable at: 1)).
	val := val bitOr: ((sourcePixel bitAnd: (cmMaskTable at: 2)) bitShift: (cmShiftTable at: 2)).
		  ^val bitOr: ((sourcePixel bitAnd: (cmMaskTable at: 3)) bitShift: (cmShiftTable at: 3)).
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 4/1/2009 08:39'!
rgbMax: sourceWord with: destinationWord
	<inline: false>
	destDepth < 16 ifTrue:
		["Max each pixel separately"
		^ self partitionedMax: sourceWord with: destinationWord
						nBits: destDepth nPartitions: destPPW].
	destDepth = 16 ifTrue:
		["Max RGB components of each pixel separately"
		^ (self partitionedMax: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMax: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Max RGBA components of the pixel separately"
		^ self partitionedMax: sourceWord with: destinationWord
						nBits: 8 nPartitions: 4]! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 4/1/2009 08:39'!
rgbMin: sourceWord with: destinationWord
	<inline: false>
	destDepth < 16 ifTrue:
		["Min each pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: destDepth nPartitions: destPPW].
	destDepth = 16 ifTrue:
		["Min RGB components of each pixel separately"
		^ (self partitionedMin: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Min RGBA components of the pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: 8 nPartitions: 4]! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 4/1/2009 08:39'!
rgbMinInvert: wordToInvert with: destinationWord
	| sourceWord |
	<inline: false>
	sourceWord := wordToInvert bitInvert32.
	destDepth < 16 ifTrue:
		["Min each pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: destDepth nPartitions: destPPW].
	destDepth = 16 ifTrue:
		["Min RGB components of each pixel separately"
		^ (self partitionedMin: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Min RGBA components of the pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: 8 nPartitions: 4]! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv (auto pragmas dtl 2010-09-26) 4/1/2009 08:39'!
rgbMul: sourceWord with: destinationWord
	<inline: false>
	destDepth < 16 ifTrue:
		["Mul each pixel separately"
		^ self partitionedMul: sourceWord with: destinationWord
						nBits: destDepth nPartitions: destPPW].
	destDepth = 16 ifTrue:
		["Mul RGB components of each pixel separately"
		^ (self partitionedMul: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMul: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Mul RGBA components of the pixel separately"
		^ self partitionedMul: sourceWord with: destinationWord
						nBits: 8 nPartitions: 4]

"	| scanner |
	Display repaintMorphicDisplay.
	scanner := DisplayScanner quickPrintOn: Display.
	MessageTally time: [0 to: 760 by: 4 do:  [:y |scanner drawString: 'qwrepoiuasfd=)(/&()=#!!lkjzxv.,mn124+09857907QROIYTOAFDJZXNBNB,M-.,Mqwrepoiuasfd=)(/&()=#!!lkjzxv.,mn124+09857907QROIYTOAFDJZXNBNB,M-.,M1234124356785678' at: 0@y]]. "! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'jmv 4/1/2009 08:39'!
rgbSub: sourceWord with: destinationWord
	<inline: false>
	destDepth < 16 ifTrue:
		["Sub each pixel separately"
		^ self partitionedSub: sourceWord from: destinationWord
						nBits: destDepth nPartitions: destPPW].
	destDepth = 16 ifTrue:
		["Sub RGB components of each pixel separately"
		^ (self partitionedSub: sourceWord from: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedSub: sourceWord>>16 from: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Sub RGBA components of the pixel separately"
		^ self partitionedSub: sourceWord from: destinationWord
						nBits: 8 nPartitions: 4]! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 4/26/2001 19:43'!
setupColorMasks
	"WARNING: For WarpBlt w/ smoothing the source depth is wrong here!!"
	| bits targetBits |
	bits := targetBits := 0.
	sourceDepth <= 8 ifTrue:[^nil].
	sourceDepth = 16 ifTrue:[bits := 5].
	sourceDepth = 32 ifTrue:[bits := 8].

	cmBitsPerColor = 0
		ifTrue:["Convert to destDepth"
				destDepth <= 8 ifTrue:[^nil].
				destDepth = 16 ifTrue:[targetBits := 5].
				destDepth = 32 ifTrue:[targetBits := 8]]
		ifFalse:[targetBits := cmBitsPerColor].

	self setupColorMasksFrom: bits to: targetBits! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar (auto pragmas dtl 2010-09-26) 5/4/2001 14:53'!
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]
		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).
! !
!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 20:46'!
showDisplayBits
	interpreterProxy 
		showDisplayBits: destForm
		Left: affectedL
		Top: affectedT
		Right: affectedR
		Bottom: affectedB! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 4/18/2001 23:05'!
sourceSkewAndPointerInit
	"This is only used when source and dest are same depth,
	ie, when the barrel-shift copy loop is used."
	| dWid sxLowBits dxLowBits pixPerM1 |
	<inline: true>
	pixPerM1 := destPPW - 1.  "A mask, assuming power of two"
	sxLowBits := sx bitAnd: pixPerM1.
	dxLowBits := dx bitAnd: pixPerM1.
	"check if need to preload buffer
	(i.e., two words of source needed for first word of destination)"
	hDir > 0 ifTrue:
		["n Bits stored in 1st word of dest"
		dWid := bbW min: destPPW - dxLowBits.
		preload := (sxLowBits + dWid) > pixPerM1]
	ifFalse:
		[dWid := bbW min: dxLowBits + 1.
		preload := (sxLowBits - dWid + 1) < 0].

	"calculate right-shift skew from source to dest"
	sourceMSB
		ifTrue:[skew := (sxLowBits - dxLowBits) * destDepth] 
		ifFalse:[skew := (dxLowBits - sxLowBits) * destDepth].  " -32..32 "
	preload ifTrue: 
		[skew < 0
			ifTrue: [skew := skew+32]
			ifFalse: [skew := skew-32]].

	"Calc byte addr and delta from longWord info"
	sourceIndex := sourceBits + (sy * sourcePitch) + ((sx // (32//sourceDepth)) *4).
	"calculate increments from end of 1 line to start of next"
	sourceDelta := (sourcePitch * vDir) - (4 * (nWords * hDir)).

	preload ifTrue:
		["Compensate for extra source word fetched"
		sourceDelta := sourceDelta - (4*hDir)].! !
!BitBltSimulation methodsFor: 'combination rules'!
sourceWord: sourceWord with: destinationWord
	^sourceWord! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:25'!
srcLongAt: idx

	^self long32At: idx! !
!BitBltSimulation methodsFor: 'combination rules'!
subWord: sourceWord with: destinationWord
	^sourceWord - destinationWord! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'tpr (auto pragmas 12/08) 7/28/2003 18:08'!
tableLookup: table at: index
	"Note: Nasty coercion only necessary for the non-inlined version of this method in C. Duh? Oh well, here's the full story. The code below will definitely be inlined so everything that calls this method is fine. But... the translator doesn't quite prune this method so it generates a C function that tries to attempt an array access on an int - and most compilers don't like this. If you don't know what I'm talking about try to remove the C coercion and you'll see what happens when you try to compile a new VM..."
	<var: #table type: 'unsigned int *'>
	^table at: index
! !
!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar (auto pragmas 12/08) 5/17/2001 15:16'!
tallyIntoMap: sourceWord with: destinationWord
	"Tally pixels into the color map.  Those tallied are exactly those
	in the destination rectangle.  Note that the source should be 
	specified == destination, in order for the proper color map checks 
	to be performed at setup."
	| mapIndex pixMask destShifted maskShifted pixVal |
	<inline: false>
	(cmFlags bitAnd: (ColorMapPresent bitOr: ColorMapIndexedPart)) = 
		(ColorMapPresent bitOr: ColorMapIndexedPart)
			ifFalse: [^ destinationWord "no op"].
	pixMask := maskTable at: destDepth.
	destShifted := destinationWord.
	maskShifted := destMask.
	1 to: destPPW do:
		[:i |
		(maskShifted bitAnd: pixMask) = 0 ifFalse:
			["Only tally pixels within the destination rectangle"
			pixVal := destShifted bitAnd: pixMask.
			destDepth < 16
				ifTrue: [mapIndex := pixVal]
				ifFalse: [destDepth = 16
					ifTrue: [mapIndex := self rgbMap: pixVal from: 5 to: cmBitsPerColor]
					ifFalse: [mapIndex := self rgbMap: pixVal from: 8 to: cmBitsPerColor]].
			self tallyMapAt: mapIndex put: (self tallyMapAt: mapIndex) + 1].
		maskShifted := maskShifted >> destDepth.
		destShifted := destShifted >> destDepth].
	^ destinationWord  "For no effect on dest"! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 4/26/2001 19:45'!
tallyMapAt: idx
	"Return the word at position idx from the colorMap"
	^cmLookupTable at: (idx bitAnd: cmMask)! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 4/26/2001 19:45'!
tallyMapAt: idx put: value
	"Store the word at position idx in the colorMap"
	^cmLookupTable at: (idx bitAnd: cmMask) put: value! !
!BitBltSimulation methodsFor: 'setup' stamp: 'ar (auto pragmas 12/08) 4/26/2001 19:44'!
tryCopyingBitsQuickly
	"Shortcut for stuff that's being run from the balloon engine.
	Since we do this at each scan line we should avoid the expensive 
	setup for source and destination."
	<inline: true>
	"We need a source."
	noSource ifTrue:[^false].
	"We handle only combinationRule 34"
	(combinationRule = 34) ifFalse:[^false].
	"We handle only sourceDepth 32"
	(sourceDepth = 32) ifFalse:[^false].
	"We don't handle overlaps"
	(sourceForm = destForm) ifTrue:[^false].
	"We need at least 8bit deep dest forms"
	(destDepth < 8) ifTrue:[^false].
	"If 8bit, then we want a color map"
	(destDepth = 8 and:[(cmFlags bitAnd: ColorMapPresent) = 0]) ifTrue:[^false].
	destDepth = 32 
		ifTrue:[self alphaSourceBlendBits32].
	destDepth = 16
		ifTrue:[self alphaSourceBlendBits16].
	destDepth = 8
		ifTrue:[self alphaSourceBlendBits8].
	affectedL := dx.
	affectedR := dx + bbW.
	affectedT := dy.
	affectedB := dy + bbH.
	^true! !
!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp (auto pragmas dtl 2010-09-26) 6/11/2004 16:54'!
unlockSurfaces
	"Unlock the bits of any OS surfaces."
	"See the comment in lockSurfaces. Similar rules apply. That is, the area provided in ioUnlockSurface can be used to determine the dirty region after drawing. If a source is unlocked, then the area will be (0,0,0,0) to indicate that no portion is dirty."
	| sourceHandle destHandle destLocked fn |
	<var: #fn declareC: 'sqInt (*fn)(sqInt, sqInt, sqInt, sqInt, sqInt)'>
	hasSurfaceLock ifTrue:[
		unlockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn := self cCoerce: unlockSurfaceFn to: 'sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt)'.
		destLocked := false.
		destHandle := interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
		(interpreterProxy isIntegerObject: destHandle) ifTrue:[
			destHandle := interpreterProxy integerValueOf: destHandle.
			"The destBits are always assumed to be dirty"
			self cCode:'fn(destHandle, affectedL, affectedT, affectedR-affectedL, affectedB-affectedT)'.
			destBits := destPitch := 0.
			destLocked := true.
		].
		noSource ifFalse:[
			sourceHandle := interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
			(interpreterProxy isIntegerObject: sourceHandle) ifTrue:[
				sourceHandle := interpreterProxy integerValueOf: sourceHandle.
				"Only unlock sourceHandle if different from destHandle"
				(destLocked and:[sourceHandle = destHandle]) 
					ifFalse:[self cCode: 'fn(sourceHandle, 0, 0, 0, 0)'].
				sourceBits := sourcePitch := 0.
			].
		].
		hasSurfaceLock := false.
	].! !
!BitBltSimulation methodsFor: 'setup' stamp: 'jcg 6/14/2010 14:12'!
warpBits
	| ns |
	<inline: true>
	ns := noSource.  noSource := true.
		self clipRange.  "noSource suppresses sourceRect clipping"
		noSource := ns.
	(noSource or: [bbW <= 0 or: [bbH <= 0]]) ifTrue:
		["zero width or height; noop"
		affectedL := affectedR := affectedT := affectedB := 0.
		^ nil].

	self lockSurfaces ifFalse:[^interpreterProxy primitiveFail].
	self destMaskAndPointerInit.
	self warpLoop.
 
	hDir > 0
		ifTrue: [affectedL := dx.
				affectedR := dx + bbW]
		ifFalse: [affectedL := dx - bbW + 1.
				affectedR := dx + 1].
	vDir > 0
		ifTrue: [affectedT := dy.
				affectedB := dy + bbH]
		ifFalse: [affectedT := dy - bbH + 1.
				affectedB := dy + 1].
	self unlockSurfaces.! !
!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 19:49'!
warpLoop
	"This version of the inner loop traverses an arbirary quadrilateral
	source, thus producing a general affine transformation."
	| skewWord halftoneWord mergeWord startBits
	  deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy pBx pBy
	  xDelta yDelta smoothingCount sourceMapOop
	  nSteps nPix words destWord endBits mergeFnwith dstShiftInc dstShiftLeft mapperFlags |
	<inline: false>
	<var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'>
	mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	(interpreterProxy slotSizeOf: bitBltOop) >= (BBWarpBase+12)
		ifFalse: [^ interpreterProxy primitiveFail].
	nSteps := height-1.  nSteps <= 0 ifTrue: [nSteps := 1].

	pAx := self fetchIntOrFloat: BBWarpBase ofObject: bitBltOop.
	words := self fetchIntOrFloat: BBWarpBase+3 ofObject: bitBltOop.
	deltaP12x := self deltaFrom: pAx to: words nSteps: nSteps.
	deltaP12x < 0 ifTrue: [pAx := words - (nSteps*deltaP12x)].

	pAy := self fetchIntOrFloat: BBWarpBase+1 ofObject: bitBltOop.
	words := self fetchIntOrFloat: BBWarpBase+4 ofObject: bitBltOop.
	deltaP12y := self deltaFrom: pAy to: words nSteps: nSteps.
	deltaP12y < 0 ifTrue: [pAy := words - (nSteps*deltaP12y)].

	pBx := self fetchIntOrFloat: BBWarpBase+9 ofObject: bitBltOop.
	words := self fetchIntOrFloat: BBWarpBase+6 ofObject: bitBltOop.
	deltaP43x := self deltaFrom: pBx to: words nSteps: nSteps.
	deltaP43x < 0 ifTrue: [pBx := words - (nSteps*deltaP43x)].

	pBy := self fetchIntOrFloat: BBWarpBase+10 ofObject: bitBltOop.
	words := self fetchIntOrFloat: BBWarpBase+7 ofObject: bitBltOop.
	deltaP43y := self deltaFrom: pBy to: words nSteps: nSteps.
	deltaP43y < 0 ifTrue: [pBy := words - (nSteps*deltaP43y)].

	interpreterProxy failed ifTrue: [^ false].  "ie if non-integers above"
	interpreterProxy methodArgumentCount = 2
		ifTrue: [smoothingCount := interpreterProxy stackIntegerValue: 1.
				sourceMapOop := interpreterProxy stackValue: 0.
				sourceMapOop = interpreterProxy nilObject
				ifTrue: [sourceDepth < 16 ifTrue:
					["color map is required to smooth non-RGB dest"
					^ interpreterProxy primitiveFail]]
				ifFalse: [(interpreterProxy slotSizeOf: sourceMapOop)
							< (1 << sourceDepth) ifTrue:
					["sourceMap must be long enough for sourceDepth"
					^ interpreterProxy primitiveFail].
					sourceMapOop := self oopForPointer: (interpreterProxy firstIndexableField: sourceMapOop)]]
		ifFalse: [smoothingCount := 1.
				sourceMapOop := interpreterProxy nilObject].
	nSteps := width-1.  nSteps <= 0 ifTrue: [nSteps := 1].
	startBits := destPPW - (dx bitAnd: destPPW-1).
	endBits := ((dx + bbW - 1) bitAnd: destPPW-1) + 1.
 	bbW < startBits ifTrue:[startBits := bbW].

	destY < clipY ifTrue:[
		"Advance increments if there was clipping in y"
		pAx := pAx + (clipY - destY * deltaP12x).
		pAy := pAy + (clipY - destY * deltaP12y).
		pBx := pBx + (clipY - destY * deltaP43x).
		pBy := pBy + (clipY - destY * deltaP43y)].

	"Setup values for faster pixel fetching."
	self warpLoopSetup.
	"Setup color mapping if not provided"
	(smoothingCount > 1 and:[(cmFlags bitAnd: ColorMapNewStyle) = 0]) ifTrue:[
		cmLookupTable == nil ifTrue:[
			destDepth = 16 ifTrue:[self setupColorMasksFrom: 8 to: 5].
		] ifFalse:[
			self setupColorMasksFrom: 8 to: cmBitsPerColor.
		].
	].
	mapperFlags := cmFlags bitAnd: ColorMapNewStyle bitInvert32.

	destMSB
		ifTrue:[	dstShiftInc := 0 - destDepth.
				dstShiftLeft := 32 - destDepth]
		ifFalse:[	dstShiftInc := destDepth.
				dstShiftLeft := 0].
	1 to: bbH do:
		[ :i | "here is the vertical loop..."
		xDelta := self deltaFrom: pAx to: pBx nSteps: nSteps.
 		xDelta >= 0 ifTrue: [sx := pAx] ifFalse: [sx := pBx - (nSteps*xDelta)].
		yDelta := self deltaFrom: pAy to: pBy nSteps: nSteps.
 		yDelta >= 0 ifTrue: [sy := pAy] ifFalse: [sy := pBy - (nSteps*yDelta)].

		destMSB
			ifTrue:[dstBitShift := 32 - ((dx bitAnd: destPPW - 1) + 1 * destDepth)]
			ifFalse:[dstBitShift := (dx bitAnd: destPPW - 1) * destDepth].

		(destX < clipX) ifTrue:[
			"Advance increments if there was clipping in x"
			sx := sx + (clipX - destX * xDelta).
			sy := sy + (clipX - destX * yDelta).
		].

		noHalftone
			ifTrue: [halftoneWord := AllOnes]
			ifFalse: [halftoneWord := self halftoneAt: dy+i-1].
		destMask := mask1.
		nPix := startBits.
		"Here is the inner loop..."
		words := nWords.
			["pick up word"
			smoothingCount = 1 ifTrue:["Faster if not smoothing"
				skewWord := self warpPickSourcePixels: nPix
								xDeltah: xDelta yDeltah: yDelta
								xDeltav: deltaP12x yDeltav: deltaP12y
								dstShiftInc: dstShiftInc flags: mapperFlags.
			] ifFalse:["more difficult with smoothing"
				skewWord := self warpPickSmoothPixels: nPix
						xDeltah: xDelta yDeltah: yDelta
						xDeltav: deltaP12x yDeltav: deltaP12y
						sourceMap: sourceMapOop
						smoothing: smoothingCount
						dstShiftInc: dstShiftInc.
			].
			"align next word access to left most pixel"
			dstBitShift := dstShiftLeft.
			destMask = AllOnes ifTrue:["avoid read-modify-write"
				mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (self dstLongAt: destIndex).
				self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
			] ifFalse:[ "General version using dest masking"
				destWord := self dstLongAt: destIndex.
				mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (destWord bitAnd: destMask).
				destWord := (destMask bitAnd: mergeWord) bitOr:
								(destWord bitAnd: destMask bitInvert32).
				self dstLongAt: destIndex put: destWord.
			].
			destIndex := destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask := mask2.
						nPix := endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask := AllOnes.
						nPix := destPPW].
			(words := words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		pAx := pAx + deltaP12x.
		pAy := pAy + deltaP12y.
		pBx := pBx + deltaP43x.
		pBy := pBy + deltaP43y.
		destIndex := destIndex + destDelta]! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar (auto pragmas 12/08) 4/19/2001 12:42'!
warpLoopSetup
	"Setup values for faster pixel fetching."
	| words |
	<inline: true>

	"warpSrcShift = log2(sourceDepth)"
	warpSrcShift := 0.
	words := sourceDepth. "recycle temp"
	[words = 1] whileFalse:[
		warpSrcShift := warpSrcShift + 1.
		words := words >> 1].

	"warpSrcMask = mask for extracting one pixel from source word"
	warpSrcMask := maskTable at: sourceDepth.

	"warpAlignShift: Shift for aligning x position to word boundary"
	warpAlignShift := 5 - warpSrcShift.

	"warpAlignMask: Mask for extracting the pixel position from an x position"
	warpAlignMask := 1 << warpAlignShift - 1.

	"Setup the lookup table for source bit shifts"
	"warpBitShiftTable: given an sub-word x value what's the bit shift?"
	0 to: warpAlignMask do:[:i|
		sourceMSB
			ifTrue:[warpBitShiftTable at: i put: 32 - ( i + 1 << warpSrcShift )]
			ifFalse:[warpBitShiftTable at: i put: (i << warpSrcShift)]].
! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 20:25'!
warpPickSmoothPixels: nPixels
	xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	sourceMap: sourceMap
	smoothing: n
	dstShiftInc: dstShiftInc
	"Pick n (sub-) pixels from the source form, mapped by sourceMap,
	average the RGB values, map by colorMap and return the new word.
	This version is only called from WarpBlt with smoothingCount > 1"
	| rgb x y a r g b xx yy xdh ydh xdv ydv dstMask destWord i j k nPix |
	<inline: false> "nope - too much stuff in here"
	dstMask := maskTable at: destDepth.
	destWord := 0.
	n = 2 "Try avoiding divides for most common n (divide by 2 is generated as shift)"
		ifTrue:[xdh := xDeltah // 2. ydh := yDeltah // 2. 
				xdv := xDeltav // 2. ydv := yDeltav // 2]
		ifFalse:[xdh := xDeltah // n. ydh := yDeltah // n. 
				xdv := xDeltav // n. ydv := yDeltav // n].
	i := nPixels.
	[
		x := sx. y := sy.
		a := r := g := b := 0.
		"Pick and average n*n subpixels"
		nPix := 0.  "actual number of pixels (not clipped and not transparent)"
		j := n.
		[
			xx := x. yy := y.
			k := n.
			[
				"get a single subpixel"
				rgb := self pickWarpPixelAtX: xx y: yy.
				(combinationRule=25 "PAINT" and: [rgb = 0]) ifFalse:[
					"If not clipped and not transparent, then tally rgb values"
					nPix := nPix + 1.
					sourceDepth < 16 ifTrue:[
						"Get RGBA values from sourcemap table"
						rgb := self long32At: sourceMap + (rgb << 2).
					] ifFalse:["Already in RGB format"
						sourceDepth = 16 
								ifTrue:[rgb := self rgbMap16To32: rgb]
								ifFalse:[rgb := self rgbMap32To32: rgb]].
					b := b + (rgb bitAnd: 255).
					g := g + (rgb >> 8 bitAnd: 255).
					r := r + (rgb >> 16 bitAnd: 255).
					a := a + (rgb >> 24)].
				xx := xx + xdh.
				yy := yy + ydh.
			(k := k - 1) = 0] whileFalse.
			x := x + xdv.
			y := y + ydv.
		(j := j - 1) = 0] whileFalse.

		(nPix = 0 or: [combinationRule=25 "PAINT" and: [nPix < (n * n // 2)]]) ifTrue:[
			rgb := 0  "All pixels were 0, or most were transparent"
		] ifFalse:[
			"normalize rgba sums"
			nPix = 4 "Try to avoid divides for most common n"
				ifTrue:[r := r >> 2.	g := g >> 2.	b := b >> 2.	a := a >> 2]
				ifFalse:[	r := r // nPix.	g := g // nPix.	b := b // nPix.	a := a // nPix].
			rgb := (a << 24) + (r << 16) + (g << 8) + b.

			"map the pixel"
			rgb = 0 ifTrue: [
				"only generate zero if pixel is really transparent"
				(r + g + b + a) > 0 ifTrue: [rgb := 1]].
			rgb := self mapPixel: rgb flags: cmFlags.
		].
		"Mix it in"
		destWord := destWord bitOr: (rgb bitAnd: dstMask) << dstBitShift.
		dstBitShift := dstBitShift + dstShiftInc.
		sx := sx + xDeltah.
		sy := sy + yDeltah.
	(i := i - 1) = 0] whileFalse.

	^destWord
! !
!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar (auto pragmas 12/08) 4/26/2001 00:58'!
warpPickSourcePixels: nPixels
	xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	dstShiftInc: dstShiftInc
	flags: mapperFlags
	"Pick n pixels from the source form,
	map by colorMap and return aligned by dstBitShift.
	This version is only called from WarpBlt with smoothingCount = 1"
	| dstMask destWord nPix sourcePix destPix |
	<inline: true> "Yepp - this should go into warpLoop"
	dstMask := maskTable at: destDepth.
	destWord := 0.
	nPix := nPixels.
	(mapperFlags = (ColorMapPresent bitOr: ColorMapIndexedPart)) ifTrue:[
		"a little optimization for (pretty crucial) blits using indexed lookups only"
		[	"grab, colormap and mix in pixel"
			sourcePix := self pickWarpPixelAtX: sx y: sy.
			destPix := cmLookupTable at: (sourcePix bitAnd: cmMask).
			destWord := destWord bitOr: (destPix bitAnd: dstMask) << dstBitShift.
			dstBitShift := dstBitShift + dstShiftInc.
			sx := sx + xDeltah.
			sy := sy + yDeltah.
		(nPix := nPix - 1) = 0] whileFalse.
	] ifFalse:[
		[	"grab, colormap and mix in pixel"
			sourcePix := self pickWarpPixelAtX: sx y: sy.
			destPix := self mapPixel: sourcePix flags: mapperFlags.
			destWord := destWord bitOr: (destPix bitAnd: dstMask) << dstBitShift.
			dstBitShift := dstBitShift + dstShiftInc.
			sx := sx + xDeltah.
			sy := sy + yDeltah.
		(nPix := nPix - 1) = 0] whileFalse.
	].
	^destWord
! !

BitBltSimulation subclass: #BitBltSimulator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!BitBltSimulator commentStamp: 'tpr 5/5/2003 12:22' prior: 0!
Provide bitblt support for the vm simulator!
!BitBltSimulator class methodsFor: 'instance creation' stamp: 'ar 5/11/2000 22:06'!
new
	^super new! !
!BitBltSimulator class methodsFor: 'translation' stamp: 'tpr 5/14/2001 12:19'!
shouldBeTranslated
"This class should not be translated "
	^false! !
!BitBltSimulator methodsFor: 'debug support' stamp: 'ikp 8/2/2004 20:25'!
dstLongAt: dstIndex

	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex long32At: 0].
	((dstIndex anyMask: 3) or:[dstIndex + 4 < destBits or:[
		dstIndex > (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^self long32At: dstIndex! !
!BitBltSimulator methodsFor: 'debug support' stamp: 'ikp 8/2/2004 20:29'!
dstLongAt: dstIndex put: value

	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex long32At: 0 put: value].
	((dstIndex anyMask: 3) or:[dstIndex < destBits or:[
		dstIndex >= (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^self long32At: dstIndex put: value! !
!BitBltSimulator methodsFor: 'simulation' stamp: 'tpr 4/3/2004 23:16'!
initBBOpTable
	opTable := OpTable.
	maskTable := Array new: 32.
	#(1 2 4 5 8 16 32) do:[:i| maskTable at: i put: (1 << i)-1].
	self initializeDitherTables.
	warpBitShiftTable := CArrayAccessor on: (Array new: 32).! !
!BitBltSimulator methodsFor: 'simulation' stamp: 'JMM 7/4/2003 11:16'!
initializeDitherTables
	ditherMatrix4x4 := CArrayAccessor on:
		#(	0	8	2	10
			12	4	14	6
			3	11	1	9
			15	7	13	5).
	ditherThresholds16 := CArrayAccessor on:#(0 2 4 6 8 10 12 14 16).
	ditherValues16 := CArrayAccessor on: 
		#(0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
		15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30).
	dither8Lookup := CArrayAccessor on: (Array new: 4096).
	self initDither8Lookup.! !
!BitBltSimulator methodsFor: 'simulation' stamp: 'di 12/30/97 11:07'!
mergeFn: arg1 with: arg2
	^ self perform: (opTable at: combinationRule+1) with: arg1 with: arg2! !
!BitBltSimulator methodsFor: 'simulation' stamp: 'jmv 10/23/2009 09:45'!
oopForPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	oop is the width of a machine word, and pointer is a raw address."

	^ pointer! !
!BitBltSimulator methodsFor: 'debug support' stamp: 'ikp 8/2/2004 20:25'!
srcLongAt: srcIndex

	interpreterProxy isInterpreterProxy
		ifTrue:[^srcIndex long32At: 0].
	((srcIndex anyMask: 3) or:[srcIndex + 4 < sourceBits or:[
		srcIndex > (sourceBits + (sourcePitch * sourceHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^self long32At: srcIndex! !
!BitBltSimulator methodsFor: 'simulation' stamp: 'ikp 8/2/2004 20:25'!
tableLookup: table at: index

	^ self long32At: (table + (index * 4))! !

InterpreterPlugin subclass: #CroquetPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!CroquetPlugin commentStamp: '<historical>' prior: 0!
An assorted list of useful primitives for Croquet.!
!CroquetPlugin class methodsFor: 'as yet unclassified' stamp: 'ar 3/26/2006 19:37'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!CroquetPlugin class methodsFor: 'as yet unclassified' stamp: 'ar 3/26/2006 19:37'!
requiresCrossPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^true! !
!CroquetPlugin methodsFor: 'cryptography' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/28/2006 12:07'!
primitiveARC4Transform
	"Perform an ARC4 transform of input.
	Arguments:
		buffer		<ByteArray> transformed data
		startIndex 	<Integer>	start of transform
		stopIndex	<Integer>	end of transform
		m			<ByteArray>	key stream data
		x			<Integer>	key state value
		y			<Integer>	key state value
	Return value:
		x@y - updated key state value
	"

	| y x mOop stopIndex startIndex bufOop bufSize buffer a m b mask ptOop xOop yOop |
	<export: true>
	<var: 'buffer' type: 'unsigned char *'>
	<var: 'm' type: 'unsigned char *'>

	interpreterProxy methodArgumentCount = 6
		ifFalse:[^interpreterProxy primitiveFail].
	"pick up arguments"
	y := interpreterProxy stackIntegerValue: 0.
	x := interpreterProxy stackIntegerValue: 1.
	mOop := interpreterProxy stackObjectValue: 2.
	stopIndex := interpreterProxy stackIntegerValue: 3.
	startIndex := interpreterProxy stackIntegerValue: 4.
	bufOop := interpreterProxy stackObjectValue: 5.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isBytes: mOop) and:[interpreterProxy isBytes: bufOop])
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy byteSizeOf: mOop) = 256
		ifFalse:[^interpreterProxy primitiveFail].
	bufSize := interpreterProxy byteSizeOf: bufOop.
	(startIndex > 0 and:[startIndex <= bufSize])
		ifFalse:[^interpreterProxy primitiveFail].
	(stopIndex > startIndex and:[stopIndex <= bufSize])
		ifFalse:[^interpreterProxy primitiveFail].
	m := interpreterProxy firstIndexableField: mOop.
	buffer := interpreterProxy firstIndexableField: bufOop.
	startIndex-1 to: stopIndex-1 do:[:i|
		x := (x + 1) bitAnd: 255.
		a := m at: x.
		y := (y + a) bitAnd: 255.
		b := m at: y.
		m at: x put: b.
		m at: y put: a.
		mask := m at: ((a + b) bitAnd: 255).
		buffer at: i put: ((buffer at: i) bitXor: mask).
	].
	ptOop := interpreterProxy instantiateClass: interpreterProxy classPoint indexableSize: 0.
	interpreterProxy pushRemappableOop: ptOop.
	xOop := interpreterProxy positive32BitIntegerFor: x.
	interpreterProxy pushRemappableOop: xOop.
	yOop := interpreterProxy positive32BitIntegerFor: y.
	xOop := interpreterProxy popRemappableOop.
	ptOop := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: ptOop withValue: xOop.
	interpreterProxy storePointer: 1 ofObject: ptOop withValue: yOop.
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy push: ptOop.
! !
!CroquetPlugin methodsFor: 'cryptography' stamp: 'ar (auto pragmas 12/08) 3/29/2006 12:13'!
primitiveGatherEntropy
	"Primitive. Gather good random entropy from a system source."
	| bufOop bufSize bufPtr okay |
	<export: true>
	<var: 'bufPtr' type: 'void *'>
	(interpreterProxy methodArgumentCount = 1)
		ifFalse:[^interpreterProxy primitiveFail].
	bufOop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isBytes: bufOop)
		ifFalse:[^interpreterProxy primitiveFail].
	bufSize := interpreterProxy byteSizeOf: bufOop.
	bufPtr := interpreterProxy firstIndexableField: bufOop.
	okay := self cCode: 'ioGatherEntropy(bufPtr, bufSize)' inSmalltalk:[bufPtr. bufSize. false].
	okay ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushBool: true.! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:32'!
primitiveInplaceHouseHolderInvert
	"Primitive. Perform an inplace house holder matrix inversion"
	| rcvr d x sigma beta sum s m |
	<export: true>
	<var: #rcvr declareC: 'float *rcvr'>
	<var: #m declareC: 'double m[4][4]'>
	<var: #x declareC: 'double x[4][4] = { {1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1} }'>
	<var: #d declareC: 'double d[4][4]'>
	<var: #sigma declareC: 'double sigma'>
	<var: #beta declareC: 'double beta'>
	<var: #sum declareC: 'double sum'>
	<var: #s declareC: 'double s'>

	self cCode:'' inSmalltalk:[
		m := CArrayAccessor on: 
				((1 to: 4) collect:[:i| CArrayAccessor on: (Array new: 4)]).
		x := CArrayAccessor on: (Array
				with: (CArrayAccessor on: #(1.0 0.0 0.0 0.0) copy)
				with: (CArrayAccessor on: #(0.0 1.0 0.0 0.0) copy)
				with: (CArrayAccessor on: #(0.0 0.0 1.0 0.0) copy)
				with: (CArrayAccessor on: #(0.0 0.0 0.0 1.0) copy)).
		d := CArrayAccessor on: 
				((1 to: 4) collect:[:i| CArrayAccessor on: (Array new: 4)]).
	].
	rcvr := self stackMatrix: 0.
	0 to: 3 do:[:i| 0 to: 3 do:[:j|
		(m at: i) at: j put: (rcvr at: i*4+j)]].
	0 to: 3 do:[:j|
		sigma := 0.0.
		j to: 3 do:[:i| sigma := sigma + (((m at: i) at: j)  * ((m at: i) at: j))].
		sigma < 1.0e-10 ifTrue:[^interpreterProxy primitiveFail]. "matrix is singular"
		(((m at: j) at: j) < 0.0) 
			ifTrue:[ s:= sigma sqrt]
			ifFalse:[ s:= 0.0 - sigma sqrt].
		0 to: 3 do:[:r| (d at: j) at: r put: s].
		beta := 1.0 / ( s * ((m at: j) at: j) - sigma).
		(m at: j) at: j put: (((m at: j) at: j) - s).
		"update remaining columns"
		j+1 to: 3 do:[:k|
			sum := 0.0.
			j to: 3 do:[:i| sum := sum + (((m at: i) at: j) * ((m at: i) at: k))].
			sum := sum * beta.
			j to: 3 do:[:i| 
				(m at: i) at: k put: (((m at: i) at: k) + (((m at: i) at: j) * sum))]].
		"update vector"
		0 to: 3 do:[:r|
			sum := 0.0.
			j to: 3 do:[:i| 
				sum := sum + (((x at: i) at: r) * ((m at: i) at: j))].
			sum := sum * beta.
			j to: 3 do:[:i| 
				(x at: i) at: r put:(((x at: i) at: r) + (sum * ((m at: i) at: j)))].
		].
	].
	"Now calculate result"
	0 to: 3 do:[:r|
		3 to: 0 by: -1 do:[:i|
			i+1 to: 3 do:[:j|
				(x at: i) at: r put: (((x at: i) at: r) - (((x at: j) at: r) * ((m at: i) at: j))) ].
			(x at: i) at: r put: (((x at: i) at: r) / ((d at: i) at: r))].
	].
	0 to: 3 do:[:i| 0 to: 3 do:[:j|
		rcvr at: i*4+j put: (self cCoerce: ((x at: i) at: j) to:'float')]].
	"Return receiver"! !
!CroquetPlugin methodsFor: 'cryptography' stamp: 'ar (auto pragmas 12/08) 3/26/2006 19:45'!
primitiveMD5Transform
	"Perform an MD5 transform of input"
	| bufOop hashOop hash buffer |
	<export: true>
	<var: 'hash' type: 'unsigned int *'>
	<var: 'buffer' type: 'unsigned int *'>
	interpreterProxy methodArgumentCount = 2 
		ifFalse:[^interpreterProxy primitiveFail].

	hashOop := interpreterProxy stackObjectValue: 0.
	((interpreterProxy isWords: hashOop) and:[(interpreterProxy slotSizeOf: hashOop) = 4])
		ifFalse:[^interpreterProxy primitiveFail].
	hash := interpreterProxy firstIndexableField: hashOop.

	bufOop := interpreterProxy stackObjectValue: 1.
	((interpreterProxy isWords: bufOop) and:[(interpreterProxy slotSizeOf: bufOop) = 16])
		ifFalse:[^interpreterProxy primitiveFail].
	buffer := interpreterProxy firstIndexableField: bufOop.


	self cCode:'MD5Transform(hash, buffer)' inSmalltalk:[
		hash. buffer. 
		^interpreterProxy primitiveFail].
	"Pop args; return buffer"
	interpreterProxy pop: interpreterProxy methodArgumentCount+1.
	interpreterProxy push: bufOop.! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:33'!
primitiveOrthoNormInverseMatrix
	| srcOop dstOop src dst x y z rx ry rz |
	<export: true>
	<var: #src declareC: 'float *src'>
	<var: #dst declareC: 'float *dst'>
	<var: #x declareC: 'double x'>
	<var: #y declareC: 'double y'>
	<var: #z declareC: 'double z'>
	<var: #rx declareC: 'double rx'>
	<var: #ry declareC: 'double ry'>
	<var: #rz declareC: 'double rz'>

	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	srcOop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: srcOop) and:[(interpreterProxy slotSizeOf: srcOop) = 16])
		ifFalse:[^interpreterProxy primitiveFail].
	dstOop := interpreterProxy clone: srcOop.
	"reload srcOop in case of GC"
	srcOop := interpreterProxy stackObjectValue: 0.
	src := interpreterProxy firstIndexableField: srcOop.
	dst := interpreterProxy firstIndexableField: dstOop.

	"Transpose upper 3x3 matrix"
	"dst at: 0 put: (src at: 0)."	dst at: 1 put: (src at: 4). 	dst at: 2 put: (src at: 8). 
	dst at: 4 put: (src at: 1). 	"dst at: 5 put: (src at: 5)."	dst at: 6 put: (src at: 9). 
	dst at: 8 put: (src at: 2). 	dst at: 9 put: (src at: 6). 	"dst at: 10 put: (src at: 10)."

	"Compute inverse translation vector"
	x := src at: 3..
	y := src at: 7.
	z := src at: 11.
	rx := (x * (dst at: 0)) + (y * (dst at: 1)) + (z * (dst at: 2)).
	ry := (x * (dst at: 4)) + (y * (dst at: 5)) + (z * (dst at: 6)).
	rz := (x * (dst at: 8)) + (y * (dst at: 9)) + (z * (dst at: 10)).

	dst at: 3 put: (self cCoerce: 0.0-rx to: 'float').
	dst at: 7 put: (self cCoerce: 0.0-ry to: 'float').
	dst at: 11 put: (self cCoerce: 0.0-rz to: 'float').

	interpreterProxy pop: 1.
	interpreterProxy push: dstOop.
! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:33'!
primitiveTransformDirection
	| x y z rx ry rz matrix vertex v3Oop |
	<export: true>
	<var: #vertex declareC: 'float *vertex'>
	<var: #matrix declareC: 'float *matrix'>
	<var: #x declareC: 'double x'>
	<var: #y declareC: 'double y'>
	<var: #z declareC: 'double z'>
	<var: #rx declareC: 'double rx'>
	<var: #ry declareC: 'double ry'>
	<var: #rz declareC: 'double rz'>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	v3Oop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: v3Oop) and:[(interpreterProxy slotSizeOf: v3Oop) = 3])
		ifFalse:[^interpreterProxy primitiveFail].
	vertex := interpreterProxy firstIndexableField: v3Oop.
	matrix := self stackMatrix: 1.
	(matrix == nil) ifTrue:[^interpreterProxy primitiveFail].

	x := vertex at: 0.
	y := vertex at: 1.
	z := vertex at: 2.

	rx := (x * (matrix at: 0)) + (y * (matrix at: 1)) + (z * (matrix at: 2)).
	ry := (x * (matrix at: 4)) + (y * (matrix at: 5)) + (z * (matrix at: 6)).
	rz := (x * (matrix at: 8)) + (y * (matrix at: 9)) + (z * (matrix at: 10)).

	v3Oop := interpreterProxy clone: v3Oop.
	vertex := interpreterProxy firstIndexableField: v3Oop.

	vertex at: 0 put: (self cCoerce: rx to: 'float').
	vertex at: 1 put: (self cCoerce: ry to:'float').
	vertex at: 2 put: (self cCoerce: rz to: 'float').

	interpreterProxy pop: 2.
	interpreterProxy push: v3Oop.
! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:34'!
primitiveTransformMatrixWithInto
	"Transform two matrices into the third"
	| m1 m2 m3 |
	<export: true>
	<inline: false>
	<var: #m1 declareC: 'float *m1'>
	<var: #m2 declareC: 'float *m2'>
	<var: #m3 declareC: 'float *m3'>

	m3 := self stackMatrix: 0.
	m2 := self stackMatrix: 1.
	m1 := self stackMatrix: 2.
	(m1 = nil) | (m2 = nil) | (m3 = nil) 
		ifTrue:[^interpreterProxy primitiveFail].
	m2 == m3 ifTrue:[^interpreterProxy primitiveFail].
	self transformMatrix: m1 with: m2 into: m3.
	interpreterProxy pop: 3. "Leave rcvr on stack"! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:43'!
primitiveTransformVector3
	| x y z rx ry rz rw matrix vertex v3Oop |
	<export: true>
	<var: #vertex declareC: 'float *vertex'>
	<var: #matrix declareC: 'float *matrix'>
	<var: #x declareC: 'double x'>
	<var: #y declareC: 'double y'>
	<var: #z declareC: 'double z'>
	<var: #rx declareC: 'double rx'>
	<var: #ry declareC: 'double ry'>
	<var: #rz declareC: 'double rz'>
	<var: #rw declareC: 'double rw'>

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	v3Oop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: v3Oop) and:[(interpreterProxy slotSizeOf: v3Oop) = 3])
		ifFalse:[^interpreterProxy primitiveFail].
	vertex := interpreterProxy firstIndexableField: v3Oop.
	matrix := self stackMatrix: 1.
	(matrix == nil) ifTrue:[^interpreterProxy primitiveFail].

	x := vertex at: 0.
	y := vertex at: 1.
	z := vertex at: 2.

	rx := (x * (matrix at: 0)) + (y * (matrix at: 1)) + (z * (matrix at: 2)) + (matrix at: 3).
	ry := (x * (matrix at: 4)) + (y * (matrix at: 5)) + (z * (matrix at: 6)) + (matrix at: 7).
	rz := (x * (matrix at: 8)) + (y * (matrix at: 9)) + (z * (matrix at: 10)) + (matrix at: 11).
	rw := (x * (matrix at: 12)) + (y * (matrix at: 13)) + (z * (matrix at: 14)) + (matrix at: 15).

	v3Oop := interpreterProxy clone: v3Oop.
	vertex := interpreterProxy firstIndexableField: v3Oop.

	rw = 1.0 ifTrue:[
		vertex at: 0 put: (self cCoerce: rx to: 'float').
		vertex at: 1 put: (self cCoerce: ry to:'float').
		vertex at: 2 put: (self cCoerce: rz to: 'float').
	] ifFalse:[
		rw = 0.0 
			ifTrue:[rw := 0.0]
			ifFalse:[rw := 1.0 / rw].
		vertex at: 0 put: (self cCoerce: rx*rw to:'float').
		vertex at: 1 put: (self cCoerce: ry*rw to:'float').
		vertex at: 2 put: (self cCoerce: rz*rw to: 'float').
	].
	interpreterProxy pop: 2.
	interpreterProxy push: v3Oop.
! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:34'!
primitiveTransposeMatrix
	| srcOop dstOop src dst |
	<export: true>
	<var: #src declareC: 'float *src'>
	<var: #dst declareC: 'float *dst'>

	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	srcOop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: srcOop) and:[(interpreterProxy slotSizeOf: srcOop) = 16])
		ifFalse:[^interpreterProxy primitiveFail].
	dstOop := interpreterProxy clone: srcOop.
	"reload srcOop in case of GC"
	srcOop := interpreterProxy stackObjectValue: 0.
	src := interpreterProxy firstIndexableField: srcOop.
	dst := interpreterProxy firstIndexableField: dstOop.

	"dst at: 0 put: (src at: 0)."
	dst at: 1 put: (src at: 4). 
	dst at: 2 put: (src at: 8). 
	dst at: 3 put: (src at: 12).

	dst at: 4 put: (src at: 1). 
	"dst at: 5 put: (src at: 5)."
	dst at: 6 put: (src at: 9). 
	dst at: 7 put: (src at: 13).

	dst at: 8 put: (src at: 2). 
	dst at: 9 put: (src at: 6). 
	"dst at: 10 put: (src at: 10)."
	dst at: 11 put: (src at: 14).

	dst at: 12 put: (src at: 3). 
	dst at: 13 put: (src at: 7). 
	dst at: 14 put: (src at: 11). 
	"dst at: 15 put: (src at: 15)."

	interpreterProxy pop: 1.
	interpreterProxy push: dstOop.
! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/18/2007 01:25'!
primitiveTriBoxIntersects
	"Primitive. Answer whether an AABB intersects with a given triangle"
	| minCorner maxCorner v0 v1 v2 result |
	<export: true>
	<var: #minCorner type: 'float*'>
	<var: #maxCorner type: 'float*'>
	<var: #v0 type: 'float*'>
	<var: #v1 type: 'float*'>
	<var: #v2 type: 'float*'>

	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	v2 := self stackVector3: 0.
	v1 := self stackVector3: 1.
	v0 := self stackVector3: 2.
	maxCorner := self stackVector3: 3.
	minCorner := self stackVector3: 4.

	result := self cCode:'triBoxOverlap(minCorner, maxCorner, v0, v1, v2)' 
				inSmalltalk:[minCorner. maxCorner. v0. v1. v2. -1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy pop: 6. "args+rcvr"
	interpreterProxy pushBool: result.! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:32'!
stackMatrix: index
	"Load a 4x4 transformation matrix from the interpreter stack.
	Return a pointer to the matrix data if successful, nil otherwise."
	| oop |
	<inline: false>
	<returnTypeC: 'void*'>
	oop := interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = 16])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/18/2007 01:08'!
stackVector3: index
	"Load a Vector3 from the interpreter stack.
	Return a pointer to the float data if successful, nil otherwise."
	| oop |
	<inline: false>
	<returnTypeC: 'void*'>
	oop := interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = 3])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !
!CroquetPlugin methodsFor: 'transforms' stamp: 'ar (auto pragmas dtl 2010-09-27) 3/26/2006 22:34'!
transformMatrix: src with: arg into: dst
	"Transform src with arg into dst.
	It is allowed that src == dst but not arg == dst"
	| m1 m2 m3 c1 c2 c3 c4 |
	<var: #src declareC: 'float *src'>
	<var: #arg declareC: 'float *arg'>
	<var: #dst declareC: 'float *dst'>
	<var: #m1 declareC: 'float *m1'>
	<var: #m2 declareC: 'float *m2'>
	<var: #m3 declareC: 'float *m3'>
	<var: #c1 declareC: 'float c1'>
	<var: #c2 declareC: 'float c2'>
	<var: #c3 declareC: 'float c3'>
	<var: #c4 declareC: 'float c4'>

	m1 := self cCoerce: src to:'float *'.
	m2 := self cCoerce: arg to: 'float *'.
	m3 := self cCoerce: dst to: 'float *'.

	0 to: 3 do:[:i|

		"Compute next row"
		c1 := ((m1 at: 0) * (m2 at: 0)) + ((m1 at: 1) * (m2 at: 4)) +
				((m1 at: 2) * (m2 at: 8)) + ((m1 at: 3) * (m2 at: 12)).

		c2 := ((m1 at: 0) * (m2 at: 1)) + ((m1 at: 1) * (m2 at: 5)) +
				((m1 at: 2) * (m2 at: 9)) + ((m1 at: 3) * (m2 at: 13)).

		c3 := ((m1 at: 0) * (m2 at: 2)) + ((m1 at: 1) * (m2 at: 6)) +
				((m1 at: 2) * (m2 at: 10)) + ((m1 at: 3) * (m2 at: 14)).

		c4 := ((m1 at: 0) * (m2 at: 3)) + ((m1 at: 1) * (m2 at: 7)) +
				((m1 at: 2) * (m2 at: 11)) + ((m1 at: 3) * (m2 at: 15)).

		"Store result"
		m3 at: 0 put: c1.
		m3 at: 1 put: c2.
		m3 at: 2 put: c3.
		m3 at: 3 put: c4.

		"Skip src and dst to next row"
		m1 := m1 + 4.
		m3 := m3 + 4.
	].
! !

InterpreterPlugin subclass: #DSAPlugin
	instanceVariableNames: 'dsaRemainder dsaDivisor dsaQuotient remainderDigitCount divisorDigitCount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!DSAPlugin commentStamp: '<historical>' prior: 0!
This plugin defines primitives that support the DigitalSignatureAlgorithm class. Three of these primitives support fast multiplication and division of very large integers, three others support the SecureHashAlgorithm.
!
!DSAPlugin class methodsFor: 'plugin translation' stamp: 'sma 3/3/2000 12:44'!
declareCVarsIn: cg
	cg var: #dsaRemainder type: #'unsigned char*'.
	cg var: #dsaDivisor type:  #'unsigned char*'.
	cg var: #dsaQuotient type: #'unsigned char*'! !
!DSAPlugin class methodsFor: 'plugin translation' stamp: 'ar 5/15/2000 22:51'!
moduleName
	"Time millisecondsToRun: [
		DSAPlugin translateDoInlining: true]"

	^ 'DSAPrims' "Yes - it needs to be named this way or else we'll not find it"
! !
!DSAPlugin methodsFor: 'private' stamp: 'jm 12/21/1999 08:10'!
addBackDivisorDigitShift: digitShift
	"Add back the divisor shifted left by the given number of digits. This is done only when the estimate of quotient digit was one larger than the correct value."

	| carry rIndex sum |
	carry := 0.
	rIndex := digitShift + 1.
	1 to: divisorDigitCount do: [:i |
		sum := (dsaRemainder at: rIndex) + (dsaDivisor at: i) + carry.
		dsaRemainder at: rIndex put: (sum bitAnd: 16rFF).
		carry := sum bitShift: -8.
		rIndex := rIndex + 1].

	"do final carry"
	sum := (dsaRemainder at: rIndex) + carry.
	dsaRemainder at: rIndex put: (sum bitAnd: 16rFF).

	"Note: There should be a final carry that cancels out the excess borrow."
	"Assert: (sum bitShift: -8) ~= 1 ifTrue: [self halt: 'no carry!!']."
! !
!DSAPlugin methodsFor: 'private' stamp: 'jm 12/21/1999 18:48'!
bigDivideLoop
	"This is the core of the divide algorithm. This loop steps through the digit positions of the quotient, each time estimating the right quotient digit, subtracting from the remainder the divisor times the quotient digit shifted left by the appropriate number of digits. When the loop terminates, all digits of the quotient have been filled in and the remainder contains a value less than the divisor. The tricky bit is estimating the next quotient digit. Knuth shows that the digit estimate computed here will never be less than it should be and cannot be more than one over what it should be. Furthermore, the case where the estimate is one too large is extremely rare. For example, in a typical test of 100000 random 60-bit division problems, the rare case only occured five times. See Knuth, volume 2 ('Semi-Numerical Algorithms') 2nd edition, pp. 257-260"

	| d1 d2 firstDigit firstTwoDigits thirdDigit q digitShift qTooBig |
	"extract the top two digits of the divisor"
	d1 := dsaDivisor at: divisorDigitCount.
	d2 := dsaDivisor at: divisorDigitCount - 1.

	remainderDigitCount to: divisorDigitCount + 1 by: -1 do: [:j |
		"extract the top several digits of remainder."
		firstDigit := dsaRemainder at: j.
		firstTwoDigits := (firstDigit bitShift: 8) + (dsaRemainder at: j - 1).
		thirdDigit := dsaRemainder at: j - 2.

		"estimate q, the next digit of the quotient"
		firstDigit = d1
			ifTrue: [q := 255]
			ifFalse: [q := firstTwoDigits // d1].

		"adjust the estimate of q if necessary"
		(d2 * q) > (((firstTwoDigits - (q * d1)) bitShift: 8) + thirdDigit) ifTrue: [	
			q := q - 1.
			(d2 * q) > (((firstTwoDigits - (q * d1)) bitShift: 8) + thirdDigit) ifTrue: [
				q := q - 1]].

		digitShift := j - divisorDigitCount - 1.
		q > 0 ifTrue: [
			qTooBig := self subtractDivisorMultipliedByDigit: q digitShift: digitShift.
			qTooBig ifTrue: [  "this case is extremely rare"
				self addBackDivisorDigitShift: digitShift.
				q := q - 1]].

		"record this digit of the quotient"
		dsaQuotient at: digitShift + 1 put: q].
! !
!DSAPlugin methodsFor: 'private' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:01'!
leftRotate: anInteger by: bits
	"Rotate the given 32-bit integer left by the given number of bits and answer the result."

	<var: #anInteger type: 'unsigned int '>
	^ (anInteger << bits) bitOr: (anInteger >> (32 - bits))
! !
!DSAPlugin methodsFor: 'primitives-integers' stamp: 'jm (auto pragmas 12/08) 12/21/1999 18:48'!
primitiveBigDivide
	"Called with three LargePositiveInteger arguments, rem, div, quo. Divide div into rem and store the quotient into quo, leaving the remainder in rem."
	"Assume: quo starts out filled with zeros."

	| rem div quo |
	<export: true>
	quo := interpreterProxy stackObjectValue: 0.
	div := interpreterProxy stackObjectValue: 1.
	rem := interpreterProxy stackObjectValue: 2.

	interpreterProxy success:
		(interpreterProxy fetchClassOf: rem) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: div) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: quo) = interpreterProxy classLargePositiveInteger.
	interpreterProxy failed ifTrue:[^ nil].

	dsaRemainder := interpreterProxy firstIndexableField: rem.
	dsaDivisor := interpreterProxy firstIndexableField: div.
	dsaQuotient := interpreterProxy firstIndexableField: quo.

	divisorDigitCount := interpreterProxy stSizeOf: div.
	remainderDigitCount := interpreterProxy stSizeOf: rem.

	"adjust pointers for base-1 indexing"
	dsaRemainder := dsaRemainder - 1.
	dsaDivisor := dsaDivisor - 1.
	dsaQuotient := dsaQuotient - 1.

	self bigDivideLoop.
	interpreterProxy pop: 3.
! !
!DSAPlugin methodsFor: 'primitives-integers' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:02'!
primitiveBigMultiply
	"Multiple f1 by f2, placing the result into prod. f1, f2, and prod must be LargePositiveIntegers, and the length of prod must be the sum of the lengths of f1 and f2."
	"Assume: prod starts out filled with zeros"

	| prod f2 f1 prodLen f1Len f2Len prodPtr f2Ptr f1Ptr digit carry k sum |
	<export: true>
	<var: #prodPtr type: 'unsigned char *'>
	<var: #f2Ptr type: 'unsigned char *'>
	<var: #f1Ptr type: 'unsigned char *'>

	prod := interpreterProxy stackObjectValue: 0.
	f2 := interpreterProxy stackObjectValue: 1.
	f1 := interpreterProxy stackObjectValue: 2.
	interpreterProxy success: (interpreterProxy isBytes: prod).
	interpreterProxy success: (interpreterProxy isBytes: f2).
	interpreterProxy success: (interpreterProxy isBytes: f1).
	interpreterProxy success:
		(interpreterProxy fetchClassOf: prod) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: f2) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: f1) = interpreterProxy classLargePositiveInteger.
	interpreterProxy failed ifTrue:[^ nil].

	prodLen := interpreterProxy stSizeOf: prod.
	f1Len := interpreterProxy stSizeOf: f1.
	f2Len := interpreterProxy stSizeOf: f2.
	interpreterProxy success: (prodLen = (f1Len + f2Len)).
	interpreterProxy failed ifTrue:[^ nil].

	prodPtr := interpreterProxy firstIndexableField: prod.
	f2Ptr := interpreterProxy firstIndexableField: f2.
	f1Ptr := interpreterProxy firstIndexableField: f1.

	0 to: f1Len-1 do: [:i | 
		(digit := f1Ptr at: i) ~= 0 ifTrue: [
			carry := 0.
			k := i.
			"Loop invariants: 0 <= carry <= 16rFF, k = i + j - 1"
			0 to: f2Len-1 do: [:j | 
				sum := ((f2Ptr at: j) * digit) + (prodPtr at: k) + carry.
				carry := sum bitShift: -8.
				prodPtr at: k put: (sum bitAnd: 255).
				k := k + 1].
			prodPtr at: k put: carry]].

	interpreterProxy pop: 3.
! !
!DSAPlugin methodsFor: 'primitives-SHA' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:02'!
primitiveExpandBlock
	"Expand a 64 byte ByteArray (the first argument) into and an Bitmap of 80 32-bit words (the second argument). When reading a 32-bit integer from the ByteArray, consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)."

	| expanded buf wordPtr bytePtr src v |
	<export: true>
	<var: #wordPtr type: 'unsigned int *'>
	<var: #bytePtr type: 'unsigned char *'>

	expanded := interpreterProxy stackObjectValue: 0.
	buf := interpreterProxy stackObjectValue: 1.
	interpreterProxy success: (interpreterProxy isWords: expanded).
	interpreterProxy success: (interpreterProxy isBytes: buf).
	interpreterProxy failed ifTrue: [^ nil].

	interpreterProxy success: ((interpreterProxy stSizeOf: expanded) = 80).
	interpreterProxy success: ((interpreterProxy stSizeOf: buf) = 64).
	interpreterProxy failed ifTrue: [^ nil].

	wordPtr := interpreterProxy firstIndexableField: expanded.
	bytePtr := interpreterProxy firstIndexableField: buf.

	src := 0.
	0 to: 15 do: [:i |
		v := ((bytePtr at: src) << 24) +
			((bytePtr at: src + 1) << 16) +
			((bytePtr at: src + 2) << 8) +
			(bytePtr at: src + 3).
		wordPtr at: i put: v.
		src := src + 4].

	16 to: 79 do: [:i |
		v := (((wordPtr at: i - 3) bitXor:
			 (wordPtr at: i - 8)) bitXor:
			 (wordPtr at: i - 14)) bitXor:
			 (wordPtr at: i - 16).
		v := self leftRotate: v by: 1.
		wordPtr at: i put: v].

	interpreterProxy pop: 2.
! !
!DSAPlugin methodsFor: 'primitives-SHA' stamp: 'jm (auto pragmas 12/08) 12/21/1999 20:43'!
primitiveHasSecureHashPrimitive
	"Answer true if the secure hash primitive is implemented."

	<export: true>
	interpreterProxy pop: 1.
	interpreterProxy pushBool: true.
! !
!DSAPlugin methodsFor: 'primitives-SHA' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:02'!
primitiveHashBlock
	"Hash a Bitmap of 80 32-bit words (the first argument), using the given state (the second argument)."

	| state buf statePtr bufPtr a b c d e tmp |
	<export: true>
	<var: #statePtr type: 'unsigned int *'>
	<var: #bufPtr type: 'unsigned int *'>

	state := interpreterProxy stackObjectValue: 0.
	buf := interpreterProxy stackObjectValue: 1.
	interpreterProxy success: (interpreterProxy isWords: state).
	interpreterProxy success: (interpreterProxy isWords: buf).
	interpreterProxy failed ifTrue: [^ nil].

	interpreterProxy success: ((interpreterProxy stSizeOf: state) = 5).
	interpreterProxy success: ((interpreterProxy stSizeOf: buf) = 80).
	interpreterProxy failed ifTrue: [^ nil].

	statePtr := interpreterProxy firstIndexableField: state.
	bufPtr := interpreterProxy firstIndexableField: buf.

	a := statePtr at: 0.
	b := statePtr at: 1.
	c := statePtr at: 2.
	d := statePtr at: 3.
	e := statePtr at: 4.
 
	0 to: 19 do: [:i |
		tmp := 16r5A827999 + ((b bitAnd: c) bitOr: (b bitInvert32 bitAnd: d)) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e := d.  d := c.  c := self leftRotate: b by: 30.  b := a.  a := tmp].

	20 to: 39 do: [:i |
		tmp := 16r6ED9EBA1 + ((b bitXor: c) bitXor: d) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e := d.  d := c.  c := self leftRotate: b by: 30.  b := a.  a := tmp].

	40 to: 59 do: [:i |
		tmp := 16r8F1BBCDC + (((b bitAnd: c) bitOr: (b bitAnd: d)) bitOr: (c bitAnd: d)) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e := d.  d := c.  c := self leftRotate: b by: 30.  b := a.  a := tmp].

	60 to: 79 do: [:i |
		tmp := 16rCA62C1D6 + ((b bitXor: c) bitXor: d) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e := d.  d := c.  c := self leftRotate: b by: 30.  b := a.  a := tmp].

	statePtr at: 0 put: (statePtr at: 0) + a.
	statePtr at: 1 put: (statePtr at: 1) + b.
	statePtr at: 2 put: (statePtr at: 2) + c.
	statePtr at: 3 put: (statePtr at: 3) + d.
	statePtr at: 4 put: (statePtr at: 4) + e.

	interpreterProxy pop: 2.
! !
!DSAPlugin methodsFor: 'primitives-integers' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:02'!
primitiveHighestNonZeroDigitIndex
	"Called with one LargePositiveInteger argument. Answer the index of the top-most non-zero digit."

	| arg bigIntPtr i |
	<export: true>
	<var: #bigIntPtr type: 'unsigned char *'>

	arg := interpreterProxy stackObjectValue: 0.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: arg) = interpreterProxy classLargePositiveInteger.
	interpreterProxy failed ifTrue: [^ nil].

	bigIntPtr := interpreterProxy firstIndexableField: arg.
	i := interpreterProxy stSizeOf: arg.
	[(i > 0) and: [(bigIntPtr at: (i := i - 1)) = 0]]
		whileTrue: ["scan down from end to first non-zero digit"].

	interpreterProxy pop: 1.
	interpreterProxy pushInteger: i + 1.
! !
!DSAPlugin methodsFor: 'private' stamp: 'jm 12/21/1999 08:13'!
subtractDivisorMultipliedByDigit: digit digitShift: digitShift
	"Multiply the divisor by the given digit (an integer in the range 0..255), shift it left by the given number of digits, and subtract the result from the current remainder. Answer true if there is an excess borrow, indicating that digit was one too large. (This case is quite rare.)"

	| borrow rIndex prod resultDigit |
	borrow := 0.
	rIndex := digitShift + 1.
	1 to: divisorDigitCount do: [:i |
		prod := ((dsaDivisor at: i) * digit) + borrow.
		borrow := prod bitShift: -8.
		resultDigit := (dsaRemainder at: rIndex) - (prod bitAnd: 16rFF).
		resultDigit < 0 ifTrue: [  "borrow from the next digit"
			resultDigit := resultDigit + 256.
			borrow := borrow + 1].
		dsaRemainder at: rIndex put: resultDigit.
		rIndex := rIndex + 1].

	"propagate the final borrow if necessary"
	borrow = 0 ifTrue: [^ false].
	resultDigit := (dsaRemainder at: rIndex) - borrow.
	resultDigit < 0
		ifTrue: [  "digit was too large (this case is quite rare)"
			dsaRemainder at: rIndex put: resultDigit + 256.
			^ true]
		ifFalse: [
			dsaRemainder at: rIndex put: resultDigit.
			^ false].
! !

InterpreterPlugin subclass: #DropPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!DropPlugin commentStamp: '<historical>' prior: 0!
This class defines the necessary primitives for dropping files from the OS onto Squeak.

Implementation notes:
The drop support is really a two phase process. The first thing the OS code needs to do is to signal an event of type EventTypeDragDropFiles to Squeak. This event needs to include the following information (see sq.h for the definition of sqDragDropFilesEvent):
* dragType:
		DragEnter - dragging mouse entered Squeak window
		DragMove - dragging mouse moved within Squeak window
		DragLeave - dragging mouse left Squeak window
		DragDrop - dropped files onto Squeak window
* numFiles:
		The number of files in the drop operation.
* x, y, modifiers:
		Associated mouse state.

When these events are received, the primitives implemented by this plugin come into play. The two primitives can be used to either receive a list of file names or to receive a list of (read-only) file handles. Because drag and drop operations are intended to work in a restricted (plugin) environment, certain security precautions need to be taken:
* Access to the contents of the files (e.g., the file streams) must only be granted after a drop occured. Simply dragging the file over the Squeak window is not enough to grant access.
* Access to the contents of the files after a drop is allowed to bypass the file sandbox and create a read-only file stream directly.
* Access to the names of files can be granted even if the files are only dragged over Squeak (but not dropped). This is so that appropriate user feedback can be given.

If somehow possible, the support code should track the location of the drag-and-drop operation and generate appropriate DragMove type events. While not important right now, it will allow us to integrate OS DnD operations with Morphic DnD operation in a seemless manner.
!
!DropPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:09'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!DropPlugin class methodsFor: 'translation' stamp: 'tpr 3/20/2001 12:15'!
requiresPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^true! !
!DropPlugin methodsFor: 'initialize' stamp: 'ar (auto pragmas 12/08) 1/10/2001 19:57'!
initialiseModule
	<export: true>
	^self cCode: 'dropInit()' inSmalltalk:[true]! !
!DropPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 1/10/2001 20:46'!
primitiveDropRequestFileHandle
	"Note: File handle creation needs to be handled by specific support code explicitly bypassing the plugin file sand box."
	| dropIndex handleOop |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 1 
		ifFalse:[^interpreterProxy primitiveFail].
	dropIndex := interpreterProxy stackIntegerValue: 0.
	handleOop := self dropRequestFileHandle: dropIndex.
	"dropRequestFileHandle needs to return the actual oop returned"
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 2.
		interpreterProxy push: handleOop.
	].! !
!DropPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 1/10/2001 20:46'!
primitiveDropRequestFileName
	"Note: File handle creation needs to be handled by specific support code explicitly bypassing the plugin file sand box."
	| dropIndex dropName nameLength nameOop namePtr |
	<export: true>
	<inline: false>
	<var: #dropName type: 'char *'>
	<var: #namePtr type: 'char *'>
	interpreterProxy methodArgumentCount = 1 
		ifFalse:[^interpreterProxy primitiveFail].
	dropIndex := interpreterProxy stackIntegerValue: 0.
	dropName := self dropRequestFileName: dropIndex.
	"dropRequestFileName returns name or NULL on error"
	dropName == nil 
		ifTrue:[^interpreterProxy primitiveFail].
	nameLength := self strlen: dropName.
	nameOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: nameLength.
	namePtr := interpreterProxy firstIndexableField: nameOop.
	0 to: nameLength-1 do:[:i| namePtr at: i put: (dropName at: i)].
	interpreterProxy pop: 2.
	interpreterProxy push: nameOop.
! !
!DropPlugin methodsFor: 'primitives' stamp: 'JMM (auto pragmas 12/08) 9/15/2001 21:14'!
setFileAccessCallback: address
	<export: true>
	<var: #address type: 'int'>
	^self cCode: 'sqSecFileAccessCallback((void *) address)'.! !
!DropPlugin methodsFor: 'initialize' stamp: 'ar (auto pragmas 12/08) 1/10/2001 19:57'!
shutdownModule
	<export: true>
	^self cCode: 'dropShutdown()' inSmalltalk:[true]! !

InterpreterPlugin subclass: #FFTPlugin
	instanceVariableNames: 'nu fftSize sinTable sinTableSize permTable permTableSize realData realDataSize imagData imagDataSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!FFTPlugin commentStamp: '<historical>' prior: 0!
FFTPlugin is an example  of how plugins are written. It shows the use of FloatArray for heavy numerical stuff as well as the simulation of plugins from Squeak.

See also:
		FFT pluginTransformData:
!
!FFTPlugin class methodsFor: 'translation to C' stamp: 'eem 3/5/2009 13:18'!
declareCVarsIn: cg
	cg var: #sinTable type: #'float *'.
	cg var: #realData type:  #'float *'.
	cg var: #imagData type: #'float *'.
	cg var: #permTable type: #'unsigned int *'! !
!FFTPlugin methodsFor: 'private' stamp: 'ar (auto pragmas dtl 2010-09-27) 9/16/1998 21:40'!
checkedFloatPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	<returnTypeC: 'float *'>
	interpreterProxy success: (interpreterProxy isWords: oop).
	interpreterProxy failed ifTrue:[^0].
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to:'float *'! !
!FFTPlugin methodsFor: 'private' stamp: 'ar (auto pragmas dtl 2010-09-27) 9/16/1998 21:40'!
checkedWordPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	<returnTypeC: 'unsigned int *'>
	interpreterProxy success: (interpreterProxy isWords: oop).
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'unsigned int *'! !
!FFTPlugin methodsFor: 'private' stamp: 'ar 10/10/1998 21:43'!
loadFFTFrom: fftOop
	| oop |
	interpreterProxy success: (interpreterProxy slotSizeOf: fftOop) >= 6.
	interpreterProxy failed ifTrue:[^false].
	nu := interpreterProxy fetchInteger: 0 ofObject: fftOop.
	fftSize := interpreterProxy fetchInteger: 1 ofObject: fftOop.

	oop := interpreterProxy fetchPointer: 2 ofObject: fftOop.
	sinTableSize := interpreterProxy stSizeOf: oop.
	sinTable := self checkedFloatPtrOf: oop.

	oop := interpreterProxy fetchPointer: 3 ofObject: fftOop.
	permTableSize := interpreterProxy stSizeOf: oop.
	permTable := self checkedWordPtrOf: oop.

	oop := interpreterProxy fetchPointer: 4 ofObject: fftOop.
	realDataSize := interpreterProxy stSizeOf: oop.
	realData := self checkedFloatPtrOf: oop.

	oop := interpreterProxy fetchPointer: 5 ofObject: fftOop.
	imagDataSize := interpreterProxy stSizeOf: oop.
	imagData := self checkedFloatPtrOf: oop.

	"Check assumptions about sizes"
	interpreterProxy success:
		(1 << nu = fftSize) & 
		(fftSize // 4 + 1 = sinTableSize) & 
		(fftSize = realDataSize) & 
		(fftSize = imagDataSize) &
		(realDataSize = imagDataSize).

	^interpreterProxy failed == false! !
!FFTPlugin methodsFor: 'transforming' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:05'!
permuteData
	| i end a b tmp |
	<var: #tmp type: 'float '>
	i := 0.
	end := permTableSize.
	[i < end] whileTrue:
		[a := (permTable at: i) - 1.
		b := (permTable at: i+1) - 1.

		(a < realDataSize and:[b < realDataSize]) ifFalse:[^interpreterProxy success: false].

		tmp := realData at: a.
		realData at: a put: (realData at: b).
		realData at: b put: tmp.

		tmp := imagData at: a.
		imagData at: a put: (imagData at: b).
		imagData at: b put: tmp.

		i := i + 2]! !
!FFTPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 10/11/1998 01:59'!
primitiveFFTPermuteData
	| rcvr |
	<export: true>
	rcvr := interpreterProxy stackObjectValue: 0.
	(self loadFFTFrom: rcvr) ifFalse:[^nil].
	self permuteData.
	interpreterProxy failed ifTrue:[
		"permuteData went wrong. Do the permutation again -- this will restore the original order"
		self permuteData].! !
!FFTPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 10/11/1998 01:59'!
primitiveFFTScaleData
	| rcvr |
	<export: true>
	rcvr := interpreterProxy stackObjectValue: 0.
	(self loadFFTFrom: rcvr) ifFalse:[^nil].
	self scaleData.! !
!FFTPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 10/11/1998 01:59'!
primitiveFFTTransformData
	| rcvr forward |
	<export: true>
	forward := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	rcvr := interpreterProxy stackObjectValue: 1.
	(self loadFFTFrom: rcvr) ifFalse:[^nil].
	self transformData: forward.
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !
!FFTPlugin methodsFor: 'transforming' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:05'!
scaleData
	"Scale all elements by 1/n when doing inverse"
	| realN |
	<var: #realN type: 'float '>
	fftSize <= 1 ifTrue:[^nil].
	realN := self cCoerce: (1.0 / (self cCoerce: fftSize to: 'double')) to: 'float'.
	0 to: fftSize-1 do:
		[:i |
		realData at: i put: (realData at: i) * realN.
		imagData at: i put: (imagData at: i) * realN]! !
!FFTPlugin methodsFor: 'transforming' stamp: 'ar 9/16/1998 20:21'!
transformData: forward
	self permuteData.
	interpreterProxy failed ifTrue:[
		"permuteData went wrong. Do the permutation again -- this will restore the original order"
		self permuteData.
		^nil].
	self transformForward: forward.
	forward ifFalse: [self scaleData]  "Reverse transform must scale to be an inverse"! !
!FFTPlugin methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:06'!
transformForward: forward
	| lev lev1 ip theta realU imagU realT imagT i fftSize2 fftSize4 fftScale ii |
	<var: #realU type: 'float '>
	<var: #realT type: 'float '>
	<var: #imagU type: 'float '>
	<var: #imagT type: 'float '>
	fftSize2 := fftSize // 2.
	fftSize4 := fftSize // 4.
	1 to: nu do:
		[:level |
		lev := 1 bitShift: level.
		lev1 := lev // 2.
		fftScale := fftSize // lev.
		1 to: lev1 do:
			[:j |
			theta := j-1 * fftScale.   "pi * (j-1) / lev1 mapped onto 0..n/2"
			theta < fftSize4  "Compute U, the complex multiplier for each level"
				ifTrue:
					[realU := sinTable at: sinTableSize - theta - 1.
					imagU := sinTable at: theta]
				ifFalse:
					[realU := 0.0 - (sinTable at: theta - fftSize4).
					imagU := sinTable at: fftSize2 - theta].
			forward ifFalse: [imagU := 0.0 - imagU].
"
			Here is the inner loop...
			j to: n by: lev do:
				[:i |   hand-transformed to whileTrue...
"
			i := j.
			[i <= fftSize] whileTrue:
				[ip := i + lev1 - 1.
				ii := i-1.
				realT := ((realData at: ip) * realU) - ((imagData at: ip) * imagU).
				imagT := ((realData at: ip) * imagU) + ((imagData at: ip) * realU).
				realData at: ip put: (realData at: ii) - realT.
				imagData at: ip put: (imagData at: ii) - imagT.
				realData at: ii put: (realData at: ii) + realT.
				imagData at: ii put: (imagData at: ii) + imagT.
				i := i + lev]]].! !

InterpreterPlugin subclass: #FilePlugin
	instanceVariableNames: 'sCCPfn sCDPfn sCGFTfn sCLPfn sCSFTfn sDFAfn sCDFfn sCOFfn sCRFfn sHFAfn'
	classVariableNames: 'DirBadPath DirEntryFound DirNoMoreEntries'
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!FilePlugin commentStamp: 'tpr 5/5/2003 12:01' prior: 0!
Provide access to the host machine file system. Requires both the Cross platform support files from platforms - Cross - plugins - FilePlugin (or some suitable replacement) and the platform specific fils from platforms - {your platform} - plugins - FilePlugin.!
!FilePlugin class methodsFor: 'translation' stamp: 'ikp 6/14/2004 13:52'!
declareCVarsIn: aCCodeGenerator

	aCCodeGenerator var: 'sCCPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCDPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCGFTfn'	type: 'void *'.
	aCCodeGenerator var: 'sCLPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCSFTfn'	type: 'void *'.
	aCCodeGenerator var: 'sDFAfn'	type: 'void *'.
	aCCodeGenerator var: 'sCDFfn'	type: 'void *'.
	aCCodeGenerator var: 'sCOFfn'	type: 'void *'.
	aCCodeGenerator var: 'sCRFfn'	type: 'void *'.
	aCCodeGenerator var: 'sHFAfn'	type: 'void *'.
	aCCodeGenerator addHeaderFile: '"FilePlugin.h"'! !
!FilePlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:09'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!FilePlugin class methodsFor: 'class initialization' stamp: 'ar 5/12/2000 16:04'!
initialize
	"FilePlugin initialize"
	DirEntryFound := 0.
	DirNoMoreEntries := 1.
	DirBadPath := 2.! !
!FilePlugin class methodsFor: 'translation' stamp: 'tpr 7/4/2001 15:12'!
requiresCrossPlatformFiles
	"this plugin requires cross platform files in order to work"
	^true! !
!FilePlugin class methodsFor: 'translation' stamp: 'tpr 11/29/2000 22:37'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!FilePlugin class methodsFor: 'instance creation' stamp: 'ar 5/11/2000 22:13'!
simulatorClass
	^FilePluginSimulator! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/11/2000 21:31'!
asciiDirectoryDelimiter
	^ self cCode: 'dir_Delimitor()' inSmalltalk: [FileDirectory pathNameDelimiter asciiValue]! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:23'!
fileOpenName: nameIndex size: nameSize write: writeFlag secure: secureFlag
	"Open the named file, possibly checking security. Answer the file oop."
	| file fileOop okToOpen |
	<var: #file type: 'SQFile *'>
	<var: 'nameIndex' type: 'char *'>
	<export: true>
	fileOop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self fileRecordSize.
	file := self fileValueOf: fileOop.
	interpreterProxy failed
		ifFalse: [ secureFlag ifTrue: [
				"If the security plugin can be loaded, use it to check for permission.
				If not, assume it's ok"
				sCOFfn ~= 0 
					ifTrue: [okToOpen := self cCode: '((sqInt (*) (char *, sqInt, sqInt)) sCOFfn)(nameIndex, nameSize, writeFlag)' inSmalltalk:[true].
						okToOpen
							ifFalse: [interpreterProxy primitiveFail]]]].
	interpreterProxy failed
		ifFalse: [self cCode: 'sqFileOpen(file, nameIndex, nameSize, writeFlag)' inSmalltalk: [file]].
	^ fileOop! !
!FilePlugin methodsFor: 'file primitives' stamp: 'eem 2/10/2009 13:42'!
fileRecordSize
	"Return the size of a Smalltalk file record in bytes."
	<static: false>
	^ self cCode: 'sizeof(SQFile)'.! !
!FilePlugin methodsFor: 'file primitives' stamp: 'eem 2/10/2009 13:42'!
fileValueOf: objectPointer
	"Return a pointer to the first byte of of the file record within the given Smalltalk object, or nil if objectPointer is not a file record."
	<returnTypeC: 'SQFile *'>
	<static: false>
	(((interpreterProxy isBytes: objectPointer) and:
		 [(interpreterProxy byteSizeOf: objectPointer) = self fileRecordSize]))
			ifFalse:[interpreterProxy primitiveFail. ^nil].
	^interpreterProxy firstIndexableField: objectPointer! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/21/2005 19:06'!
getThisSession
	"Exported entry point for the VM. Only used by AsynchFilePlugin and needs to be reowrked now we have a VM global session Id capability"
	<export: true> 
	^self cCode: 'sqFileThisSession()'.! !
!FilePlugin methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 1/21/2002 11:02'!
initialiseModule
	<export: true>
	sCCPfn := interpreterProxy ioLoadFunction: 'secCanCreatePathOfSize' From: 'SecurityPlugin'.
	sCDPfn := interpreterProxy ioLoadFunction: 'secCanDeletePathOfSize' From: 'SecurityPlugin'.
	sCGFTfn := interpreterProxy ioLoadFunction: 'secCanGetFileTypeOfSize' From: 'SecurityPlugin'.
	sCLPfn := interpreterProxy ioLoadFunction: 'secCanListPathOfSize' From: 'SecurityPlugin'.
	sCSFTfn := interpreterProxy ioLoadFunction: 'secCanSetFileTypeOfSize' From: 'SecurityPlugin'.
	sDFAfn := interpreterProxy ioLoadFunction: 'secDisableFileAccess' From: 'SecurityPlugin'.
	sCDFfn := interpreterProxy ioLoadFunction: 'secCanDeleteFileOfSize' From: 'SecurityPlugin'.
	sCOFfn := interpreterProxy ioLoadFunction: 'secCanOpenFileOfSizeWritable' From: 'SecurityPlugin'.
	sCRFfn := interpreterProxy ioLoadFunction: 'secCanRenameFileOfSize' From: 'SecurityPlugin'.
	sHFAfn := interpreterProxy ioLoadFunction: 'secHasFileAccess' From: 'SecurityPlugin'.
	^self cCode: 'sqFileInit()' inSmalltalk:[true]! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:06'!
makeDirEntryName: entryName size: entryNameSize
	createDate: createDate modDate: modifiedDate
	isDir: dirFlag fileSize: fileSize

	| modDateOop createDateOop nameString results stringPtr fileSizeOop |
	<var: 'entryName' type: 'char *'>
	<var: 'stringPtr' type: 'char *'>
	<var: 'fileSize' type: 'squeakFileOffsetType '>

	"allocate storage for results, remapping newly allocated
	 oops in case GC happens during allocation"
	interpreterProxy pushRemappableOop:
		(interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 5).
	interpreterProxy pushRemappableOop:
		(interpreterProxy instantiateClass: (interpreterProxy classString) indexableSize: entryNameSize)..
	interpreterProxy pushRemappableOop: 
		(interpreterProxy positive32BitIntegerFor: createDate).
	interpreterProxy pushRemappableOop: 
		(interpreterProxy positive32BitIntegerFor: modifiedDate).
	interpreterProxy pushRemappableOop:
		(interpreterProxy positive64BitIntegerFor: fileSize).

	fileSizeOop   := interpreterProxy popRemappableOop.
	modDateOop   := interpreterProxy popRemappableOop.
	createDateOop := interpreterProxy popRemappableOop.
	nameString    := interpreterProxy popRemappableOop.
	results         := interpreterProxy popRemappableOop.

	"copy name into Smalltalk string"
	stringPtr := interpreterProxy firstIndexableField: nameString.
	0 to: entryNameSize - 1 do: [ :i |
		stringPtr at: i put: (entryName at: i).
	].

	interpreterProxy storePointer: 0 ofObject: results withValue: nameString.
	interpreterProxy storePointer: 1 ofObject: results withValue: createDateOop.
	interpreterProxy storePointer: 2 ofObject: results withValue: modDateOop.
	dirFlag
		ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ]
		ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ].
	interpreterProxy storePointer: 4 ofObject: results withValue: fileSizeOop.
	^ results! !
!FilePlugin methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 1/21/2002 11:03'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	<export: true>
	<var: #aModuleName type: 'char *'>
	(aModuleName strcmp: 'SecurityPlugin') = 0 ifTrue:[
		"The security plugin just shut down. How odd."
		sCCPfn := sCDPfn := sCGFTfn := sCLPfn := sCSFTfn := sDFAfn := sCDFfn := sCOFfn := sCRFfn := sHFAfn := 0.
	].! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:50'!
primitiveDirectoryCreate

	| dirName dirNameIndex dirNameSize okToCreate |
	<var: #dirNameIndex type: 'char *'>
	<export: true>

	dirName := interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: dirName)
		ifFalse: [^interpreterProxy primitiveFail].
	dirNameIndex := interpreterProxy firstIndexableField: dirName.
	dirNameSize := interpreterProxy byteSizeOf: dirName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCCPfn ~= 0
		ifTrue: [okToCreate := self cCode: ' ((sqInt (*)(char *, sqInt))sCCPfn)(dirNameIndex, dirNameSize)'.
			okToCreate
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_Create(dirNameIndex, dirNameSize)'
			inSmalltalk: [false])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 1! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:49'!
primitiveDirectoryDelete

	| dirName dirNameIndex dirNameSize okToDelete |
	<var: #dirNameIndex type: 'char *'>
	<export: true>

	dirName := interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: dirName)
		ifFalse: [^interpreterProxy primitiveFail].
	dirNameIndex := interpreterProxy firstIndexableField: dirName.
	dirNameSize := interpreterProxy byteSizeOf: dirName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCDPfn ~= 0
		ifTrue: [okToDelete := self cCode: ' ((sqInt (*)(char *, sqInt))sCDPfn)(dirNameIndex, dirNameSize)'.
			okToDelete
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_Delete(dirNameIndex, dirNameSize)'
			inSmalltalk: [false])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 1! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'eem 6/22/2010 11:11'!
primitiveDirectoryDelimitor
	| ascii |
	<export: true>
	ascii := self asciiDirectoryDelimiter.
	((ascii >= 0) and: [ascii <= 255]) ifFalse:
		[^interpreterProxy primitiveFail].
	interpreterProxy
		pop: 1
		thenPush: (interpreterProxy fetchPointer: ascii ofObject: (interpreterProxy characterTable))! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:50'!
primitiveDirectoryGetMacTypeAndCreator

	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize okToGet |
	<var: 'creatorStringIndex' type: 'char *'>
	<var: 'typeStringIndex' type: 'char *'>
	<var: 'fileNameIndex' type: 'char *'>
	<export: true>

	creatorString := interpreterProxy stackValue: 0.
	typeString := interpreterProxy stackValue: 1.
	fileName := interpreterProxy stackValue: 2.
	((interpreterProxy isBytes: creatorString)
			and: [(interpreterProxy byteSizeOf: creatorString) = 4])
		ifFalse: [^interpreterProxy primitiveFail].
	((interpreterProxy isBytes: typeString)
			and: [(interpreterProxy byteSizeOf: typeString) = 4])
		ifFalse: [^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: fileName)
		ifFalse: [^interpreterProxy primitiveFail].
	creatorStringIndex := interpreterProxy firstIndexableField: creatorString.
	typeStringIndex := interpreterProxy firstIndexableField: typeString.
	fileNameIndex := interpreterProxy firstIndexableField: fileName.
	fileNameSize := interpreterProxy byteSizeOf: fileName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCGFTfn ~= 0
		ifTrue: [okToGet := self cCode: ' ((sqInt (*)(char *, sqInt))sCGFTfn)(fileNameIndex, fileNameSize)'.
			okToGet
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_GetMacFileTypeAndCreator(fileNameIndex, fileNameSize, typeStringIndex, creatorStringIndex)'
			inSmalltalk: [true])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 3! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:50'!
primitiveDirectoryLookup

	| index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag fileSize okToList |
	<var: 'entryName' declareC: 'char entryName[256]'>
	<var: 'pathNameIndex' type: 'char *'>
	<var: 'fileSize' type: 'squeakFileOffsetType'>
	<export: true>

	index := interpreterProxy stackIntegerValue: 0.
	pathName := interpreterProxy stackValue: 1.
	(interpreterProxy isBytes: pathName)
		ifFalse: [^interpreterProxy primitiveFail].
	pathNameIndex := interpreterProxy firstIndexableField: pathName.
	pathNameSize := interpreterProxy byteSizeOf: pathName.
	"If the security plugin can be loaded, use it to check for permission. 
	If not, assume it's ok"
	sCLPfn ~= 0
		ifTrue: [okToList := self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)']
		ifFalse: [okToList := true].
	okToList
		ifTrue: [status := self cCode: 'dir_Lookup(pathNameIndex, pathNameSize, index,
												entryName, &entryNameSize, &createDate,
												&modifiedDate, &dirFlag, &fileSize)']
		ifFalse: [status := DirNoMoreEntries].
	interpreterProxy failed
		ifTrue: [^nil].
	status = DirNoMoreEntries
		ifTrue: ["no more entries; return nil"
			interpreterProxy pop: 3 "pop pathName, index, rcvr"
				thenPush: interpreterProxy nilObject.
			^nil].
	status = DirBadPath
		ifTrue: [^interpreterProxy primitiveFail]."bad path"

	interpreterProxy pop: 3	"pop pathName, index, rcvr" 
		thenPush: (self
				makeDirEntryName: entryName
				size: entryNameSize
				createDate: createDate
				modDate: modifiedDate
				isDir: dirFlag
				fileSize: fileSize)! !
!FilePlugin methodsFor: 'directory primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:51'!
primitiveDirectorySetMacTypeAndCreator

	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize  okToSet |
	<var: 'creatorStringIndex' type: 'char *'>
	<var: 'typeStringIndex' type: 'char *'>
	<var: 'fileNameIndex' type: 'char *'>
	<export: true>

	creatorString := interpreterProxy stackValue: 0.
	typeString := interpreterProxy stackValue: 1.
	fileName := interpreterProxy stackValue: 2.
	((interpreterProxy isBytes: creatorString)
			and: [(interpreterProxy byteSizeOf: creatorString)
					= 4])
		ifFalse: [^interpreterProxy primitiveFail].
	((interpreterProxy isBytes: typeString)
			and: [(interpreterProxy byteSizeOf: typeString)
					= 4])
		ifFalse: [^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: fileName)
		ifFalse: [^interpreterProxy primitiveFail].
	creatorStringIndex := interpreterProxy firstIndexableField: creatorString.
	typeStringIndex := interpreterProxy firstIndexableField: typeString.
	fileNameIndex := interpreterProxy firstIndexableField: fileName.
	fileNameSize := interpreterProxy byteSizeOf: fileName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCSFTfn ~= 0
		ifTrue: [okToSet := self cCode: ' ((sqInt (*)(char *, sqInt))sCSFTfn)(fileNameIndex, fileNameSize)'.
			okToSet
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_SetMacFileTypeAndCreator(fileNameIndex, fileNameSize,typeStringIndex, creatorStringIndex)'
			inSmalltalk: [true])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 3! !
!FilePlugin methodsFor: 'security primitives' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-27) 5/5/2009 10:56'!
primitiveDisableFileAccess
	<export: true>
	"If the security plugin can be loaded, use it to turn off file access
	If not, assume it's ok"
	sDFAfn ~= 0
		ifTrue: [self cCode: ' ((sqInt (*)(void))sDFAfn)()'].
! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:07'!
primitiveFileAtEnd
	| file atEnd |
	<export: true>
	<var: 'file' type: 'SQFile *'>
	file := self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed
		ifFalse: [atEnd := self sqFileAtEnd: file].
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 2. "rcvr, file"
			interpreterProxy pushBool: atEnd]! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:08'!
primitiveFileClose

	| file |
	<export: true>
	<var: 'file' type: 'SQFile *'>
	file := self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse: [ self sqFileClose: file ].
	interpreterProxy failed ifFalse: [ interpreterProxy pop: 1  "pop file; leave rcvr on stack" ].! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 16:42'!
primitiveFileDelete

	| namePointer nameIndex nameSize  okToDelete |
	<var: 'nameIndex' type: 'char *'>
	<export: true>

	namePointer := interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: namePointer)
		ifFalse: [^ interpreterProxy primitiveFail].
	nameIndex := interpreterProxy firstIndexableField: namePointer.
	nameSize := interpreterProxy byteSizeOf: namePointer.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCDFfn ~= 0
		ifTrue: [okToDelete := self cCode: ' ((sqInt (*)(char *, sqInt))sCDFfn)(nameIndex, nameSize)'.
			okToDelete
				ifFalse: [^ interpreterProxy primitiveFail]].
	self
		sqFileDeleteName: nameIndex
		Size: nameSize.
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 1]! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:08'!
primitiveFileFlush
	| file |
	<var: 'file' type: 'SQFile *'>
	<export: true>
	file := self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse:[self sqFileFlush: file].
	interpreterProxy failed ifFalse: [interpreterProxy pop: 1].! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:14'!
primitiveFileGetPosition
	| file position |
	<var: 'file' type: 'SQFile *'>
	<var: 'position' type: 'squeakFileOffsetType'>
	<export: true>
	file := self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse: [position := self sqFileGetPosition: file].
	interpreterProxy failed ifFalse: [
		interpreterProxy pop: 2 thenPush: (interpreterProxy positive64BitIntegerFor: position)].! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:22'!
primitiveFileOpen
	| writeFlag namePointer filePointer nameIndex nameSize |
	<var: 'nameIndex' type: 'char *'>
	<export: true>
	writeFlag := interpreterProxy
				booleanValueOf: (interpreterProxy stackValue: 0).
	namePointer := interpreterProxy stackValue: 1.
	(interpreterProxy isBytes: namePointer)
		ifFalse: [^ interpreterProxy primitiveFail].
	nameIndex := interpreterProxy firstIndexableField: namePointer.
	nameSize := interpreterProxy byteSizeOf: namePointer.
	filePointer := self fileOpenName: nameIndex size: nameSize write: writeFlag secure: true.
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 3 "rcvr, name, writeFlag"
			thenPush: filePointer]
! !
!FilePlugin methodsFor: 'file primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:49'!
primitiveFileRead

	| count startIndex array file byteSize arrayIndex bytesRead |
	<var: 'file' type: 'SQFile *'>
	<var: 'arrayIndex' type: 'char *'>
	<var: 'count' type: 'size_t'>
	<var: 'startIndex' type: 'size_t'>
	<var: 'byteSize' type: 'size_t'>
	<export: true>

	count		:= interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	startIndex	:= interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	array		:= interpreterProxy stackValue: 2.
	file			:= self fileValueOf: (interpreterProxy stackValue: 3).

	"buffer can be any indexable words or bytes object except CompiledMethod"
	(interpreterProxy isWordsOrBytes: array) 
		ifFalse: [^interpreterProxy primitiveFail].

	(interpreterProxy isWords: array)
		ifTrue: [byteSize := 4]
		ifFalse: [byteSize := 1].
	((startIndex >= 1) and:
		[(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)])
			ifFalse: [^interpreterProxy primitiveFail].

	arrayIndex := interpreterProxy firstIndexableField: array.
	"Note: adjust startIndex for zero-origin indexing"
	bytesRead := self
		sqFile: file Read: (count * byteSize)
		Into: arrayIndex
		At: ((startIndex - 1) * byteSize).
	interpreterProxy failed ifFalse: [
		interpreterProxy pop: 5 "pop rcvr, file, array, startIndex, count"
			thenPush:(interpreterProxy integerObjectOf: bytesRead // byteSize).  "push # of elements read"].! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:31'!
primitiveFileRename

	| oldNamePointer newNamePointer oldNameIndex oldNameSize newNameIndex newNameSize  okToRename |
	<var: 'oldNameIndex' type: 'char *'>
	<var: 'newNameIndex' type: 'char *'>
	<export: true>

	newNamePointer := interpreterProxy stackValue: 0.
	oldNamePointer := interpreterProxy stackValue: 1.
	((interpreterProxy isBytes: newNamePointer)
			and: [interpreterProxy isBytes: oldNamePointer])
		ifFalse: [^interpreterProxy primitiveFail].
	newNameIndex := interpreterProxy firstIndexableField: newNamePointer.
	newNameSize := interpreterProxy byteSizeOf: newNamePointer.
	oldNameIndex := interpreterProxy firstIndexableField: oldNamePointer.
	oldNameSize := interpreterProxy byteSizeOf: oldNamePointer.
	"If the security plugin can be loaded, use it to check for rename permission.
	If not, assume it's ok"
	sCRFfn ~= 0
		ifTrue: [okToRename := self cCode: ' ((sqInt (*)(char *, sqInt))sCRFfn)(oldNameIndex, oldNameSize)'.
			okToRename
				ifFalse: [^interpreterProxy primitiveFail]].
	self
		sqFileRenameOld: oldNameIndex Size: oldNameSize
		New: newNameIndex Size: newNameSize.
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 2]! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:09'!
primitiveFileSetPosition
	| newPosition file sz |
	<var: 'file' type: 'SQFile *'>
	<var: 'newPosition' type: 'squeakFileOffsetType'>
	<export: true>
	(interpreterProxy isIntegerObject: (interpreterProxy stackValue: 0)) ifFalse:
		[sz := self cCode: 'sizeof(squeakFileOffsetType)'.
		(interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > sz 
			ifTrue: [^interpreterProxy primitiveFail]].
	newPosition := interpreterProxy positive64BitValueOf: (interpreterProxy stackValue: 0).
	file := self fileValueOf: (interpreterProxy stackValue: 1).
	interpreterProxy failed ifFalse:[
		self sqFile: file SetPosition: newPosition ].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 2 "pop position, file; leave rcvr on stack" ].! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:15'!
primitiveFileSize
	| file size |
	<var: 'file' type: 'SQFile *'>
	<var: 'size' type: 'squeakFileOffsetType'>
	<export: true>
	file := self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse:[size := self sqFileSize: file].
	interpreterProxy failed ifFalse: [
		interpreterProxy pop: 2 thenPush: (interpreterProxy positive64BitIntegerFor: size)].! !
!FilePlugin methodsFor: 'file primitives' stamp: 'dtl 12/26/2010 17:31'!
primitiveFileStdioHandles
	"Answer an Array of file handles for standard in, standard out and standard error,
	 with nil in entries that are unvailable, e.g. because the platform does not provide
	 standard error, etc.  Fail if there are no standard i/o facilities on the platform or
	 if the security plugin denies access or if memory runs out."
	| fileRecords result validMask |
	<export: true>
	<var: 'fileRecords' declareC: 'SQFile fileRecords[3]'>
	sHFAfn ~= 0 ifTrue:
		[(self cCode: ' ((sqInt (*)(void))sHFAfn)()' inSmalltalk: [true]) ifFalse:
			[^interpreterProxy primitiveFail]].
	validMask := self sqFileStdioHandlesInto: (self addressOf: fileRecords).
	validMask = 0 ifTrue:
		[^interpreterProxy primitiveFail].
	result := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 3.
	result = nil ifTrue:
		[^interpreterProxy primitiveFail].
	interpreterProxy pushRemappableOop: result.
	0 to: 2 do:
		[:index| | r |
		(validMask bitAnd: (1 << index)) ~= 0 ifTrue:
			[result := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self fileRecordSize.
			 result = nil ifTrue:
				[interpreterProxy popRemappableOop.
				^interpreterProxy primitiveFail].
			r := interpreterProxy popRemappableOop.
			interpreterProxy storePointer: index ofObject: r withValue: result.
			interpreterProxy pushRemappableOop: r.
			self mem: (interpreterProxy firstIndexableField: result)
				cp: (self addressOf: (fileRecords at: index))
				y: self fileRecordSize]].
	result := interpreterProxy popRemappableOop.
	interpreterProxy pop: 1 thenPush: result! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:16'!
primitiveFileTruncate
"ftruncate is not an ansi function so we have a macro to point to a suitable platform implementation" 
	| truncatePosition file sz |
	<var: 'file' type: 'SQFile *'>
	<var: 'truncatePosition' type: 'squeakFileOffsetType'>
	<export: true>
	(interpreterProxy isIntegerObject: (interpreterProxy stackValue: 0))
		ifFalse: [sz := self cCode: 'sizeof(squeakFileOffsetType)'.
			(interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > sz
				ifTrue: [^ interpreterProxy primitiveFail]].
	truncatePosition := interpreterProxy
				positive64BitValueOf: (interpreterProxy stackValue: 0).
	file := self fileValueOf: (interpreterProxy stackValue: 1).
	interpreterProxy failed
		ifFalse: [self sqFile: file Truncate: truncatePosition].
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 2 "pop position, file; leave rcvr on stack"]! !
!FilePlugin methodsFor: 'file primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:34'!
primitiveFileWrite
	| count startIndex array file byteSize arrayIndex bytesWritten |
	<var: 'file' type: 'SQFile *'>
	<var: 'arrayIndex' type: 'char *'>
	<var: 'count' type: 'size_t'>
	<var: 'startIndex' type: 'size_t'>
	<var: 'byteSize' type: 'size_t'>
	<export: true>
	count := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	startIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	array := interpreterProxy stackValue: 2.
	file := self fileValueOf: (interpreterProxy stackValue: 3).
	"buffer can be any indexable words or bytes object except CompiledMethod "
	(interpreterProxy isWordsOrBytes: array)
		ifFalse: [^ interpreterProxy primitiveFail].
	(interpreterProxy isWords: array)
		ifTrue: [byteSize := 4]
		ifFalse: [byteSize := 1].
	(startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)])
		ifFalse: [^ interpreterProxy primitiveFail].
	interpreterProxy failed
		ifFalse: [arrayIndex := interpreterProxy firstIndexableField: array.
			"Note: adjust startIndex for zero-origin indexing"
			bytesWritten := self
						sqFile: file
						Write: count * byteSize
						From: arrayIndex
						At: startIndex - 1 * byteSize].
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 5 thenPush:( interpreterProxy integerObjectOf: bytesWritten // byteSize)]! !
!FilePlugin methodsFor: 'security primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:41'!
primitiveHasFileAccess
	|  hasAccess |
	<export: true>
	"If the security plugin can be loaded, use it to check . 
	If not, assume it's ok"
	sHFAfn ~= 0
		ifTrue: [hasAccess := self cCode: ' ((sqInt (*)(void))sHFAfn)()' inSmalltalk: [true]]
		ifFalse: [hasAccess := true].
	interpreterProxy pop: 1.
	interpreterProxy pushBool: hasAccess! !
!FilePlugin methodsFor: 'file primitives' stamp: 'ar (auto pragmas 12/08) 5/13/2000 14:51'!
setMacFile: fileName Type: typeString AndCreator: creatorString
	"Exported entry point for the VM. Needed for image saving only and no-op on anything but Macs."
	<export: true>
	<var: #fileName type: 'char *'>
	<var: #typeString type: 'char *'>
	<var: #creatorString type: 'char *'>
	^self cCode: 'dir_SetMacFileTypeAndCreator(fileName, strlen(fileName), typeString, creatorString)'.! !
!FilePlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:54'!
shutdownModule
	<export: true>
	^self cCode: 'sqFileShutdown()' inSmalltalk:[true]! !

FilePlugin subclass: #FilePluginSimulator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!FilePluginSimulator commentStamp: 'tpr 5/5/2003 12:02' prior: 0!
File plugin simulation for the VM simulator!
!FilePluginSimulator class methodsFor: 'translation' stamp: 'tpr 5/14/2001 12:34'!
shouldBeTranslated
"This class should not be translated"
	^false! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:10'!
fileValueOf: objectPointer
	^interpreterProxy fileValueOf: objectPointer! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 19:23'!
ioCanCreatePath: dirNameIndex OfSize: dirNameSize
	"Return true if we're allowed to create a directory with the given name"
	^true! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 18:16'!
ioCanDeleteFile: nameIndex OfSize: nameSize
	"Return true if we're allowed to delete the file with the given name"
	^true! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 18:16'!
ioCanDeletePath: dirNameIndex OfSize: dirNameSize
	"Return true if we're allowed to delete the directory with the given name"
	^true! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 18:16'!
ioCanGetFileType: fileNameIndex OfSize: fileNameSize
	"Return true if we're allowed to retrieve the (mac) file type of the given file."
	^true! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 18:17'!
ioCanListPath: pathNameIndex OfSize: pathNameSize
	"Return true if we're allowed to list the contents of the given directory"
	^true! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 18:17'!
ioCanOpenFile: nameIndex OfSize: nameSize Writable: writeFlag
	"Return true if we're allowed to open the given file (possibly in write mode)"
	^true! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 18:17'!
ioCanRenameFile: oldNameIndex OfSize: oldNameSize
	"Return true if we're allowed to rename the given file"
	^true! !
!FilePluginSimulator methodsFor: 'file security' stamp: 'ar 2/5/2001 18:18'!
ioCanSetFileType: fileNameIndex OfSize: fileNameSize
	"Return true if we're allowed to set the (mac) file type and creator on the given file"
	^true! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:11'!
makeDirEntryName: entryName size: entryNameSize
	createDate: createDate modDate: modifiedDate
	isDir: dirFlag fileSize: fileSize

	^interpreterProxy
		makeDirEntryName: entryName size: entryNameSize
		createDate: createDate modDate: modifiedDate
		isDir: dirFlag fileSize: fileSize
! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'di 6/23/2004 14:18'!
oopForPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	oop is the width of a machine word, and pointer is a raw address."

	^ pointer! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:11'!
primitiveDirectoryLookup
	^interpreterProxy primitiveDirectoryLookup! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:12'!
primitiveFileDelete 
	^interpreterProxy primitiveFileDelete ! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:12'!
primitiveFileOpen
	^interpreterProxy primitiveFileOpen! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:12'!
primitiveFileRename
	^interpreterProxy primitiveFileRename! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:09'!
sqFile: file Read: count Into: byteArrayIndex At: startIndex
	^interpreterProxy sqFile: file Read: count Into: byteArrayIndex At: startIndex! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:09'!
sqFile: file SetPosition: newPosition
	^interpreterProxy sqFile: file SetPosition: newPosition! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'JMM 5/24/2001 21:58'!
sqFile: file Truncate: truncatePosition
	^interpreterProxy sqFile: file Truncate: truncatePosition! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:09'!
sqFile: file Write: count From: byteArrayIndex At: startIndex
	^interpreterProxy sqFile: file Write: count From: byteArrayIndex At: startIndex! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:09'!
sqFileAtEnd: file
	^interpreterProxy sqFileAtEnd: file! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:09'!
sqFileClose: file
	^interpreterProxy sqFileClose: file! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 2/6/2001 17:54'!
sqFileFlush: file
	^interpreterProxy sqFileFlush: file! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:10'!
sqFileGetPosition: file
	^interpreterProxy sqFileGetPosition: file! !
!FilePluginSimulator methodsFor: 'simulation' stamp: 'ar 5/11/2000 22:10'!
sqFileSize: file
	^interpreterProxy sqFileSize: file! !

InterpreterPlugin subclass: #FloatArrayPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!FloatArrayPlugin commentStamp: 'tpr 5/2/2003 15:42' prior: 0!
FloatArrayPlugin provides fast access to FloatArrays for batch processing of float numbers!
!FloatArrayPlugin class methodsFor: 'translation to C' stamp: 'ar 9/15/1998 00:30'!
declareCVarsIn: cg
	"Nothing to declare..."! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:18'!
primitiveAddFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	<export: true>
	<var: #rcvrPtr type: 'float *'>
	<var: #argPtr type: 'float *'>
	arg := interpreterProxy stackObjectValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr := self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) + (argPtr at: i)].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:18'!
primitiveAddScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value length |
	<export: true>
	<var: #value type: 'double '>
	<var: #rcvrPtr type: 'float *'>
	value := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: rcvr.
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) + value].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:19'!
primitiveAt

	| index rcvr floatValue floatPtr |
	<export: true>
	<var: #floatValue type: 'double '>
	<var: #floatPtr type: 'float *'>
	index := interpreterProxy stackIntegerValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy success: (index > 0 and:[index <= (interpreterProxy slotSizeOf: rcvr)]).
	interpreterProxy failed ifTrue:[^nil].
	floatPtr := interpreterProxy firstIndexableField: rcvr.
	floatValue := (floatPtr at: index-1) asFloat.
	interpreterProxy pop: 2.
	interpreterProxy pushFloat: floatValue.! !
!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:19'!
primitiveAtPut

	| value floatValue index rcvr floatPtr |
	<export: true>
	<var: #floatValue type: 'double '>
	<var: #floatPtr type: 'float *'>
	value := interpreterProxy stackValue: 0.
	(interpreterProxy isIntegerObject: value)
		ifTrue:[floatValue := (interpreterProxy integerValueOf: value) asFloat]
		ifFalse:[floatValue := interpreterProxy floatValueOf: value].
	index := interpreterProxy stackIntegerValue: 1.
	rcvr := interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy success: (index > 0 and:[index <= (interpreterProxy slotSizeOf: rcvr)]).
	interpreterProxy failed ifTrue:[^nil].
	floatPtr := interpreterProxy firstIndexableField: rcvr.
	floatPtr at: index-1 put: (self cCoerce: floatValue to:'float').
	interpreterProxy failed ifFalse: [interpreterProxy pop: 3 thenPush: value].! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'dtl (auto pragmas dtl 2010-09-27) 5/31/2008 18:20'!
primitiveDivFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	<export: true>
	<var: #rcvrPtr type: 'float *'>
	<var: #argPtr type: 'float *'>
	arg := interpreterProxy stackObjectValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr := self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	"Check if any of the argument's values is zero"
	0 to: length-1 do:[:i|
		( self intAtPointer:(self cCoerce: (argPtr + i) to: 'char*')) = 0 ifTrue:[^interpreterProxy primitiveFail]].
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) / (argPtr at: i).
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:19'!
primitiveDivScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value inverse length |
	<export: true>
	<var: #value type: 'double '>
	<var: #inverse type: 'double '>
	<var: #rcvrPtr type: 'float *'>
	value := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	value = 0.0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: rcvr.
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	inverse := 1.0 / value.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) * inverse.
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:20'!
primitiveDotProduct
	"Primitive. Compute the dot product of the receiver and the argument.
	The dot product is defined as the sum of the products of the individual elements."
	| rcvr arg rcvrPtr argPtr length result |
	<export: true>
	<var: #rcvrPtr type: 'float *'>
	<var: #argPtr type: 'float *'>
	<var: #result type: 'double '>
	arg := interpreterProxy stackObjectValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr := self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	result := 0.0.
	0 to: length-1 do:[:i|
		result := result + ((rcvrPtr at: i) * (argPtr at: i)).
	].
	interpreterProxy pop: 2. "Pop args + rcvr"
	interpreterProxy pushFloat: result. "Return result"! !
!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:20'!
primitiveEqual

	| rcvr arg rcvrPtr argPtr length |
	<export: true>
	<var: #rcvrPtr type: 'float *'>
	<var: #argPtr type: 'float *'>
	arg := interpreterProxy stackObjectValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: 2.
	length := interpreterProxy stSizeOf: arg.
	length = (interpreterProxy stSizeOf: rcvr) ifFalse:[^interpreterProxy pushBool: false].

	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr := self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		(rcvrPtr at: i) = (argPtr at: i) ifFalse:[^interpreterProxy pushBool: false].
	].
	^interpreterProxy pushBool: true! !
!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:20'!
primitiveHashArray

	| rcvr rcvrPtr length result |
	<export: true>
	<var: #rcvrPtr type: 'int *'>
	rcvr := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: rcvr.
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'int *'.
	result := 0.
	0 to: length-1 do:[:i|
		result := result + (rcvrPtr at: i).
	].
	interpreterProxy pop: 1.
	^interpreterProxy pushInteger: (result bitAnd: 16r1FFFFFFF)! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:20'!
primitiveMulFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	<export: true>
	<var: #rcvrPtr type: 'float *'>
	<var: #argPtr type: 'float *'>
	arg := interpreterProxy stackObjectValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr := self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) * (argPtr at: i).
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:20'!
primitiveMulScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value length |
	<export: true>
	<var: #value type: 'double '>
	<var: #rcvrPtr type: 'float *'>
	value := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: rcvr.
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) * value.
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:21'!
primitiveSubFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	<export: true>
	<var: #rcvrPtr type: 'float *'>
	<var: #argPtr type: 'float *'>
	arg := interpreterProxy stackObjectValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr := self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) - (argPtr at: i).
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:21'!
primitiveSubScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value length |
	<export: true>
	<var: #value type: 'double '>
	<var: #rcvrPtr type: 'float *'>
	value := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: rcvr.
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) - value.
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !
!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:21'!
primitiveSum
	"Primitive. Find the sum of each float in the receiver, a FloatArray, and stash the result into the argument Float."
	| rcvr rcvrPtr length sum |
	<export: true>
	<var: #sum type: 'double '>
	<var: #rcvrPtr type: 'float *'>
	rcvr := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length := interpreterProxy stSizeOf: rcvr.
	rcvrPtr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	sum := 0.0.
	0 to: length-1 do:[:i|
		sum := sum + (rcvrPtr at: i).
	].
	interpreterProxy pop: 1 thenPush: (interpreterProxy floatObjectOf: sum)! !

InterpreterPlugin subclass: #FloatMathPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!FloatMathPlugin class methodsFor: 'translation' stamp: 'ar 11/6/2005 02:48'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!FloatMathPlugin class methodsFor: 'translation' stamp: 'ar 11/6/2005 16:20'!
requiresCrossPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^true! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:33'!
primitiveArcCos
	"Computes acos(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_acos(rcvr)' inSmalltalk: [rcvr arcCos].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:33'!
primitiveArcCosH
	"Computes acosh(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_acosh(rcvr)' inSmalltalk: [rcvr arcCosH].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:33'!
primitiveArcSin
	"Computes asin(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_asin(rcvr)' inSmalltalk: [rcvr arcSin].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:31'!
primitiveArcSinH
	"Computes asinh(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_asinh(rcvr)' inSmalltalk: [rcvr arcSinH].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:31'!
primitiveArcTan
	"Computes atan(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_atan(rcvr)' inSmalltalk: [rcvr arcTan].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:31'!
primitiveArcTan2
	"Computes atan2(receiver, arg)"
	| rcvr arg result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #arg type: 'double'>
	<var: #result type: 'double'>
	arg := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackFloatValue: 1.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_atan2(rcvr, arg)' inSmalltalk: [rcvr arcTan: arg].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:31'!
primitiveArcTanH
	"Computes atanh(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_atanh(rcvr)' inSmalltalk: [rcvr arcTanH].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveCos
	"Computes cos(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_cos(rcvr)' inSmalltalk: [rcvr cos].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveCosH
	"Computes cosh(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_cosh(rcvr)' inSmalltalk: [rcvr cosH].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveExp
	"Computes E raised to the receiver power."
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := (self cCode: '__ieee754_exp(rcvr)' inSmalltalk: [rcvr exp]).
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveFMod
	"Computes receiver \\ arg"
	| rcvr arg result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #arg type: 'double'>
	<var: #result type: 'double'>
	arg := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackFloatValue: 1.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_fmod(rcvr, arg)' inSmalltalk: [rcvr \\ arg].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 22:51'!
primitiveFractionalPart
	"Computes receiver \\ 1.0"
	| rcvr result trunc |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	<var: #trunc type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_modf(rcvr, &trunc)' inSmalltalk: [rcvr fractionPart].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveHypot
	"hypot(x,y) returns sqrt(x^2+y^2) with error less  than 1 ulps"
	| rcvr arg result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #arg type: 'double'>
	<var: #result type: 'double'>
	arg := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackFloatValue: 1.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_hypot(rcvr, arg)' inSmalltalk: [rcvr hypot: arg].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveLog10
	"Computes log10(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	rcvr < 0.0 ifTrue:[^interpreterProxy primitiveFail].
	result := self cCode: '__ieee754_log10(rcvr)' inSmalltalk: [rcvr log: 10].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveLogN
	"Computes log(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	rcvr < 0.0 ifTrue:[^interpreterProxy primitiveFail].
	result := self cCode: '__ieee754_log(rcvr)' inSmalltalk: [rcvr ln].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveRaisedToPower
	"Computes receiver**arg"
	| rcvr arg result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #arg type: 'double'>
	<var: #result type: 'double'>
	arg := interpreterProxy stackFloatValue: 0.
	rcvr := interpreterProxy stackFloatValue: 1.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_pow(rcvr, arg)' inSmalltalk: [rcvr raisedTo: arg].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveSin
	"Computes sin(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_sin(rcvr)' inSmalltalk: [rcvr sin].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:32'!
primitiveSinH
	"Computes sinh(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_sinh(rcvr)' inSmalltalk: [rcvr sinH].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:33'!
primitiveSqrt
	"Computes sqrt(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	rcvr < 0.0 ifTrue:[^interpreterProxy primitiveFail].
	result := self cCode: '__ieee754_sqrt(rcvr)' inSmalltalk: [rcvr sqrt].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:33'!
primitiveTan
	"Computes tan(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_tan(rcvr)' inSmalltalk: [rcvr tan].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:33'!
primitiveTanH
	"Computes tanh(receiver)"
	| rcvr result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	rcvr := interpreterProxy stackFloatValue: 0.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_tanh(rcvr)' inSmalltalk: [rcvr tanH].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !
!FloatMathPlugin methodsFor: 'float primitives' stamp: 'ar (auto pragmas 12/08) 4/17/2006 21:33'!
primitiveTimesTwoPower
	"Computes E raised to the receiver power."
	| rcvr arg result |
	<export: true>
	<var: #rcvr type: 'double'>
	<var: #result type: 'double'>
	arg := interpreterProxy stackIntegerValue: 0.
	rcvr := interpreterProxy stackFloatValue: 1.
	(interpreterProxy failed) ifTrue:[^nil].
	result := self cCode: '__ieee754_ldexp(rcvr, arg)' inSmalltalk: [rcvr timesTwoPower: arg].
	(self isnan: result) ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
	interpreterProxy pushFloat: result.! !

InterpreterPlugin subclass: #InflatePlugin
	instanceVariableNames: 'zipCollection zipReadLimit zipPosition zipState zipBitBuf zipBitPos zipSource zipSourcePos zipSourceLimit zipLitTable zipDistTable zipCollectionSize zipLitTableSize zipDistTableSize'
	classVariableNames: 'MaxBits StateNoMoreData'
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!InflatePlugin commentStamp: '<historical>' prior: 0!
This plugin implements the one crucial function for efficiently decompressing streams.!

InflatePlugin subclass: #DeflatePlugin
	instanceVariableNames: 'zipHashHead zipHashTail zipHashValue zipBlockPos zipBlockStart zipLiterals zipDistances zipLiteralFreq zipDistanceFreq zipLiteralCount zipLiteralSize zipMatchCount zipMatchLengthCodes zipDistanceCodes zipCrcTable zipExtraLengthBits zipExtraDistanceBits zipBaseLength zipBaseDistance'
	classVariableNames: 'DeflateHashBits DeflateHashMask DeflateHashShift DeflateHashTableSize DeflateMaxDistance DeflateMaxDistanceCodes DeflateMaxLiteralCodes DeflateMaxMatch DeflateMinMatch DeflateWindowMask DeflateWindowSize'
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!DeflatePlugin commentStamp: 'tpr 5/5/2003 11:52' prior: 0!
This adds Zip deflating support.
InflatePlugin should not be translated but this subclass should since it is incorporated within that class's translation process!
!DeflatePlugin class methodsFor: 'translation' stamp: 'sma 3/3/2000 12:33'!
declareCVarsIn: cg
	super declareCVarsIn: cg. "Required since we share some instVars"
	cg var: #zipHashHead type: #'unsigned int*'.
	cg var: #zipHashTail type: #'unsigned int*'.
	cg var: #zipLiterals type: #'unsigned char*'.
	cg var: #zipDistances type: #'unsigned int*'.
	cg var: #zipLiteralFreq type: #'unsigned int*'.
	cg var: #zipDistanceFreq type: #'unsigned int*'.
	cg var: #zipMatchLengthCodes type: #'unsigned int' array: ZipWriteStream matchLengthCodes.
	cg var: #zipDistanceCodes type: #'unsigned int' array: ZipWriteStream distanceCodes.
	cg var: #zipCrcTable type: #'unsigned int' array: GZipWriteStream crcTable.
	cg var: #zipExtraLengthBits type: #'unsigned int' array: ZipWriteStream extraLengthBits.
	cg var: #zipExtraDistanceBits type: #'unsigned int' array: ZipWriteStream extraDistanceBits.
	cg var: #zipBaseLength type: #'unsigned int' array: ZipWriteStream baseLength.
	cg var: #zipBaseDistance type: #'unsigned int' array: ZipWriteStream baseDistance! !
!DeflatePlugin class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 20:54'!
initialize
	"DeflatePlugin initialize"
	DeflateWindowSize := 16r8000.
	DeflateWindowMask := DeflateWindowSize - 1.
	DeflateMinMatch := 3.
	DeflateMaxMatch := 258.
	DeflateMaxDistance := DeflateWindowSize.
	DeflateHashBits := 15.
	DeflateHashTableSize := 1 << DeflateHashBits.
	DeflateHashMask := DeflateHashTableSize - 1.
	DeflateHashShift := (DeflateHashBits + DeflateMinMatch - 1) // DeflateMinMatch.
	DeflateMaxLiteralCodes := ZipWriteStream maxLiteralCodes.
	DeflateMaxDistanceCodes := ZipWriteStream maxDistanceCodes.! !
!DeflatePlugin methodsFor: 'deflating' stamp: 'ar (auto pragmas 12/08) 12/29/1999 21:59'!
compare: here with: matchPos min: minLength
	"Compare the two strings and return the length of matching characters.
	minLength is a lower bound for match lengths that will be accepted.
	Note: here and matchPos are zero based."
	| length |
	<inline: true>
	"First test if we can actually get longer than minLength"
	(zipCollection at: here+minLength) = (zipCollection at: matchPos+minLength)
		ifFalse:[^0].
	(zipCollection at: here+minLength-1) = (zipCollection at: matchPos+minLength-1)
		ifFalse:[^0].
	"Then test if we have an initial match at all"
	(zipCollection at: here) = (zipCollection at: matchPos)
		ifFalse:[^0].
	(zipCollection at: here+1) = (zipCollection at: matchPos+1)
		ifFalse:[^1].
	"Finally do the real comparison"
	length := 2.
	[length < DeflateMaxMatch and:[
		(zipCollection at: here+length) = (zipCollection at: matchPos+length)]]
			whileTrue:[length := length + 1].
	^length! !
!DeflatePlugin methodsFor: 'deflating' stamp: 'ar (auto pragmas 12/08) 12/29/1999 22:00'!
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
	"Continue deflating the receiver's collection from blockPosition to lastIndex.
	Note that lastIndex must be at least MaxMatch away from the end of collection"
	| here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch |
	<inline: false>
	zipBlockPos > lastIndex ifTrue:[^false]. "Nothing to deflate"
	zipLiteralCount >= zipLiteralSize ifTrue:[^true].
	hasMatch := false.
	here := zipBlockPos.
	[here <= lastIndex] whileTrue:[
		hasMatch ifFalse:[
			"Find the first match"
			matchResult := self findMatch: here
								lastLength: DeflateMinMatch-1
								lastMatch: here
								chainLength: chainLength
								goodMatch: goodMatch.
			self insertStringAt: here. "update hash table"
			hereMatch := matchResult bitAnd: 16rFFFF.
			hereLength := matchResult bitShift: -16].

		"Look ahead if there is a better match at the next position"
		matchResult := self findMatch: here+1
							lastLength: hereLength
							lastMatch: hereMatch
							chainLength: chainLength
							goodMatch: goodMatch.
		newMatch := matchResult bitAnd: 16rFFFF.
		newLength := matchResult bitShift: -16.

		"Now check if the next match is better than the current one.
		If not, output the current match (provided that the current match
		is at least MinMatch long)"
		(hereLength >= newLength and:[hereLength >= DeflateMinMatch]) ifTrue:[
			"Encode the current match"
			flushNeeded := self
				encodeMatch: hereLength
				distance: here - hereMatch.
			"Insert all strings up to the end of the current match.
			Note: The first string has already been inserted."
			1 to: hereLength-1 do:[:i| self insertStringAt: (here := here + 1)].
			hasMatch := false.
			here := here + 1.
		] ifFalse:[
			"Either the next match is better than the current one or we didn't
			have a good match after all (e.g., current match length < MinMatch).
			Output a single literal."
			flushNeeded := self encodeLiteral: (zipCollection at: here).
			here := here + 1.
			(here <= lastIndex and:[flushNeeded not]) ifTrue:[
				"Cache the results for the next round"
				self insertStringAt: here.
				hasMatch := true.
				hereMatch := newMatch.
				hereLength := newLength].
		].
		flushNeeded ifTrue:[zipBlockPos := here. ^true].
	].
	zipBlockPos := here.
	^false! !
!DeflatePlugin methodsFor: 'encoding' stamp: 'ar (auto pragmas 12/08) 12/29/1999 20:37'!
encodeLiteral: lit
	"Encode the given literal"
	<inline: true>
	zipLiterals at: zipLiteralCount put: lit.
	zipDistances at: zipLiteralCount put: 0.
	zipLiteralFreq at: lit put: (zipLiteralFreq at: lit) + 1.
	zipLiteralCount := zipLiteralCount + 1.
	^zipLiteralCount = zipLiteralSize "We *must* flush"
		or:[(zipLiteralCount bitAnd: 16rFFF) = 0 "Only check every N kbytes"
			and:[self shouldFlush]]! !
!DeflatePlugin methodsFor: 'encoding' stamp: 'ar (auto pragmas 12/08) 12/29/1999 20:37'!
encodeMatch: length distance: dist
	"Encode the given match of length length starting at dist bytes ahead"
	| literal distance |
	<inline: true>
	zipLiterals at: zipLiteralCount put: length - DeflateMinMatch.
	zipDistances at: zipLiteralCount put: dist.
	literal := (zipMatchLengthCodes at: length - DeflateMinMatch).
	zipLiteralFreq at: literal put: (zipLiteralFreq at: literal) + 1.
	dist < 257
		ifTrue:[distance := zipDistanceCodes at: dist - 1]
		ifFalse:[distance := zipDistanceCodes at: 256 + (dist - 1 bitShift: -7)].
	zipDistanceFreq at: distance put: (zipDistanceFreq at: distance) + 1.
	zipLiteralCount := zipLiteralCount + 1.
	zipMatchCount := zipMatchCount + 1.
	^zipLiteralCount = zipLiteralSize "We *must* flush"
		or:[(zipLiteralCount bitAnd: 16rFFF) = 0 "Only check every N kbytes"
			and:[self shouldFlush]]! !
!DeflatePlugin methodsFor: 'deflating' stamp: 'ar (auto pragmas 12/08) 12/29/1999 22:00'!
findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch
	"Find the longest match for the string starting at here.
	If there is no match longer than lastLength return lastMatch/lastLength.
	Traverse at most maxChainLength entries in the hash table.
	Stop if a match of at least goodMatch size has been found."
	| matchResult matchPos distance chainLength limit bestLength length |
	<inline: false>
	"Compute the default match result"
	matchResult := (lastLength bitShift: 16) bitOr: lastMatch.

	"There is no way to find a better match than MaxMatch"
	lastLength >= DeflateMaxMatch ifTrue:[^matchResult].

	"Start position for searches"
	matchPos := zipHashHead at: (self updateHashAt: here + DeflateMinMatch - 1).

	"Compute the distance to the (possible) match"
	distance := here - matchPos.

	"Note: It is required that 0 < distance < MaxDistance"
	(distance > 0 and:[distance < DeflateMaxDistance]) ifFalse:[^matchResult].

	chainLength := maxChainLength.	"Max. nr of match chain to search"
	here > DeflateMaxDistance	"Limit for matches that are too old"
		ifTrue:[limit := here - DeflateMaxDistance]
		ifFalse:[limit := 0].

	"Best match length so far (current match must be larger to take effect)"
	bestLength := lastLength.

	[true] whileTrue:[
		"Compare the current string with the string at match position"
		length := self compare: here with: matchPos min: bestLength.
		"Truncate accidental matches beyound stream position"
		(here + length > zipPosition) ifTrue:[length := zipPosition - here].
		"Ignore very small matches if they are too far away"
		(length = DeflateMinMatch and:[(here - matchPos) > (DeflateMaxDistance // 4)])
			ifTrue:[length := DeflateMinMatch - 1].
		length > bestLength ifTrue:["We have a new (better) match than before"
			"Compute the new match result"
			matchResult := (length bitShift: 16) bitOr: matchPos.
			bestLength := length.
			"There is no way to find a better match than MaxMatch"
			bestLength >= DeflateMaxMatch ifTrue:[^matchResult].
			"But we may have a good, fast match"
			bestLength > goodMatch ifTrue:[^matchResult].
		].
		(chainLength := chainLength - 1) > 0 ifFalse:[^matchResult].
		"Compare with previous entry in hash chain"
		matchPos := zipHashTail at: (matchPos bitAnd: DeflateWindowMask).
		matchPos <= limit ifTrue:[^matchResult]. "Match position is too old"
	].! !
!DeflatePlugin methodsFor: 'deflating' stamp: 'ar (auto pragmas 12/08) 12/29/1999 21:59'!
insertStringAt: here
	"Insert the string at the given start position into the hash table.
	Note: The hash value is updated starting at MinMatch-1 since
	all strings before have already been inserted into the hash table
	(and the hash value is updated as well)."
	| prevEntry |
	<inline: true>
	zipHashValue := self updateHashAt: (here + DeflateMinMatch - 1).
	prevEntry := zipHashHead at: zipHashValue.
	zipHashHead at: zipHashValue put: here.
	zipHashTail at: (here bitAnd: DeflateWindowMask) put: prevEntry.! !
!DeflatePlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas dtl 2010-09-27) 12/30/1999 15:28'!
loadDeflateStreamFrom: rcvr
	| oop |
	<inline: false>
	((interpreterProxy isPointers: rcvr) and:[
		(interpreterProxy slotSizeOf: rcvr) >= 15]) ifFalse:[^false].
	oop := interpreterProxy fetchPointer: 0 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipCollection := interpreterProxy firstIndexableField: oop.
	zipCollectionSize := interpreterProxy byteSizeOf: oop.

	zipPosition := interpreterProxy fetchInteger: 1 ofObject: rcvr.
	zipReadLimit := interpreterProxy fetchInteger: 2 ofObject: rcvr.
	"zipWriteLimit := interpreterProxy fetchInteger: 3 ofObject: rcvr."

	oop := interpreterProxy fetchPointer: 4 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateHashTableSize ifFalse:[^false].
	zipHashHead := interpreterProxy firstIndexableField: oop.
	oop := interpreterProxy fetchPointer: 5 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateWindowSize ifFalse:[^false].
	zipHashTail := interpreterProxy firstIndexableField: oop.
	zipHashValue := interpreterProxy fetchInteger: 6 ofObject: rcvr.
	zipBlockPos := interpreterProxy fetchInteger: 7 ofObject: rcvr.
	"zipBlockStart := interpreterProxy fetchInteger: 8 ofObject: rcvr."
	oop := interpreterProxy fetchPointer: 9 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isBytes: oop) not]) ifTrue:[^false].
	zipLiteralSize := interpreterProxy slotSizeOf: oop.
	zipLiterals := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 10 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) < zipLiteralSize ifTrue:[^false].
	zipDistances := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 11 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateMaxLiteralCodes ifFalse:[^false].
	zipLiteralFreq := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 12 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateMaxDistanceCodes ifFalse:[^false].
	zipDistanceFreq := interpreterProxy firstIndexableField: oop.

	zipLiteralCount := interpreterProxy fetchInteger: 13 ofObject: rcvr.
	zipMatchCount := interpreterProxy fetchInteger: 14 ofObject: rcvr.

	^interpreterProxy failed not! !
!DeflatePlugin methodsFor: 'primitive support' stamp: 'ar (auto pragmas 12/08) 12/30/1999 15:28'!
loadZipEncoderFrom: rcvr
	| oop |
	<inline: false>
	((interpreterProxy isPointers: rcvr) and:[
		(interpreterProxy slotSizeOf: rcvr) >= 6]) ifFalse:[^false].
	oop := interpreterProxy fetchPointer: 0 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipCollection := interpreterProxy firstIndexableField: oop.
	zipCollectionSize := interpreterProxy byteSizeOf: oop.

	zipPosition := interpreterProxy fetchInteger: 1 ofObject: rcvr.
	zipReadLimit := interpreterProxy fetchInteger: 2 ofObject: rcvr.
	"zipWriteLimit := interpreterProxy fetchInteger: 3 ofObject: rcvr."
	zipBitBuf := interpreterProxy fetchInteger: 4 ofObject: rcvr.
	zipBitPos := interpreterProxy fetchInteger: 5 ofObject: rcvr.

	^interpreterProxy failed not! !
!DeflatePlugin methodsFor: 'encoding' stamp: 'ar (auto pragmas 12/08) 12/30/1999 15:26'!
nextZipBits: nBits put: value
	"Require:
		zipCollection, zipCollectionSize, zipPosition,
		zipBitBuf, zipBitPos.
	"
	<inline: true>
	(value >= 0 and:[(1 << nBits) > value])
		ifFalse:[^interpreterProxy primitiveFail].
	zipBitBuf := zipBitBuf bitOr: (value bitShift: zipBitPos).
	zipBitPos := zipBitPos + nBits.
	[zipBitPos >= 8 and:[zipPosition < zipCollectionSize]] whileTrue:[
		zipCollection at: zipPosition put: (zipBitBuf bitAnd: 255).
		zipPosition := zipPosition + 1.
		zipBitBuf := zipBitBuf >> 8.
		zipBitPos := zipBitPos - 8].
! !
!DeflatePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 12/29/1999 22:21'!
primitiveDeflateBlock
	"Primitive. Deflate the current contents of the receiver."
	| goodMatch chainLength lastIndex rcvr result |
	<export: true>
	<inline: false>
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	goodMatch := interpreterProxy stackIntegerValue: 0.
	chainLength := interpreterProxy stackIntegerValue: 1.
	lastIndex := interpreterProxy stackIntegerValue: 2.
	rcvr := interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	self cCode:'' inSmalltalk:[
		zipMatchLengthCodes := CArrayAccessor on: ZipWriteStream matchLengthCodes.
		zipDistanceCodes := CArrayAccessor on: ZipWriteStream distanceCodes].
	(self loadDeflateStreamFrom: rcvr)
		ifFalse:[^interpreterProxy primitiveFail].
	result := self deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch.
	interpreterProxy failed ifFalse:[
		"Store back modified values"
		interpreterProxy storeInteger: 6 ofObject: rcvr withValue: zipHashValue.
		interpreterProxy storeInteger: 7 ofObject: rcvr withValue: zipBlockPos.
		interpreterProxy storeInteger: 13 ofObject: rcvr withValue: zipLiteralCount.
		interpreterProxy storeInteger: 14 ofObject: rcvr withValue: zipMatchCount].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 4.
		interpreterProxy pushBool: result.
	].! !
!DeflatePlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:00'!
primitiveDeflateUpdateHashTable
	"Primitive. Update the hash tables after data has been moved by delta."
	| delta table tableSize tablePtr entry |
	<export: true>
	<var: #tablePtr type: 'int *'>
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	delta := interpreterProxy stackIntegerValue: 0.
	table := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: table)
		ifFalse:[^interpreterProxy primitiveFail].
	tableSize := interpreterProxy slotSizeOf: table.
	tablePtr := interpreterProxy firstIndexableField: table.
	0 to: tableSize-1 do:[:i|
		entry := tablePtr at: i.
		entry >= delta
			ifTrue:[tablePtr at: i put: entry - delta]
			ifFalse:[tablePtr at: i put: 0]].
	interpreterProxy pop: 2. "Leave rcvr on stack"! !
!DeflatePlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:01'!
primitiveUpdateAdler32
	"Primitive. Update a 32bit CRC value."
	| collection stopIndex startIndex length bytePtr s1 adler32 s2 b |
	<export: true>
	<var: #adler32 type: 'unsigned int '>
	<var: #bytePtr type: 'unsigned char *'>
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	collection := interpreterProxy stackObjectValue: 0.
	stopIndex := interpreterProxy stackIntegerValue: 1.
	startIndex := interpreterProxy stackIntegerValue: 2.
	adler32 := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 3).
	interpreterProxy failed ifTrue:[^0].
	((interpreterProxy isBytes: collection) and:[stopIndex >= startIndex and:[startIndex > 0]])
		ifFalse:[^interpreterProxy primitiveFail].
	length := interpreterProxy byteSizeOf: collection.
	(stopIndex <= length) ifFalse:[^interpreterProxy primitiveFail].
	bytePtr := interpreterProxy firstIndexableField: collection.
	startIndex := startIndex - 1.
	stopIndex := stopIndex - 1.
	s1 := adler32 bitAnd: 16rFFFF.
	s2 := (adler32 >> 16) bitAnd: 16rFFFF.
	startIndex to: stopIndex do:[:i|
		b := bytePtr at: i.
		s1 := (s1 + b) \\ 65521.
		s2 := (s2 + s1) \\ 65521.
	].
	adler32 := (s2 bitShift: 16) + s1.
	interpreterProxy pop: 5. "args + rcvr"
	interpreterProxy push: (interpreterProxy positive32BitIntegerFor: adler32).! !
!DeflatePlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:01'!
primitiveUpdateGZipCrc32
	"Primitive. Update a 32bit CRC value."
	| collection stopIndex startIndex crc length bytePtr |
	<export: true>
	<var: #crc type: 'unsigned int '>
	<var: #bytePtr type: 'unsigned char *'>
	<var: #crcTable type: 'unsigned int *'>
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	collection := interpreterProxy stackObjectValue: 0.
	stopIndex := interpreterProxy stackIntegerValue: 1.
	startIndex := interpreterProxy stackIntegerValue: 2.
	crc := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 3).
	interpreterProxy failed ifTrue:[^0].
	((interpreterProxy isBytes: collection) and:[stopIndex >= startIndex and:[startIndex > 0]])
		ifFalse:[^interpreterProxy primitiveFail].
	length := interpreterProxy byteSizeOf: collection.
	(stopIndex <= length) ifFalse:[^interpreterProxy primitiveFail].
	bytePtr := interpreterProxy firstIndexableField: collection.
	self cCode:'' inSmalltalk:[zipCrcTable := CArrayAccessor on: GZipWriteStream crcTable].
	startIndex := startIndex - 1.
	stopIndex := stopIndex - 1.
	startIndex to: stopIndex do:[:i|
		crc := (zipCrcTable at: ((crc bitXor: (bytePtr at: i)) bitAnd: 255)) bitXor: (crc >> 8).
	].
	interpreterProxy pop: 5. "args + rcvr"
	interpreterProxy push: (interpreterProxy positive32BitIntegerFor: crc).! !
!DeflatePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 12/30/1999 15:54'!
primitiveZipSendBlock
	| distTree litTree distStream litStream rcvr result |
	<export: true>
	interpreterProxy methodArgumentCount = 4 
		ifFalse:[^interpreterProxy primitiveFail].
	distTree := interpreterProxy stackObjectValue: 0.
	litTree := interpreterProxy stackObjectValue: 1.
	distStream := interpreterProxy stackObjectValue: 2.
	litStream := interpreterProxy stackObjectValue: 3.
	rcvr := interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	(self loadZipEncoderFrom: rcvr)
		ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: distTree) and:[
		(interpreterProxy slotSizeOf: distTree) >= 2])
			ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: litTree) and:[
		(interpreterProxy slotSizeOf: litTree) >= 2])
			ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: litStream) and:[
		(interpreterProxy slotSizeOf: litStream) >= 3])
			ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: distStream) and:[
		(interpreterProxy slotSizeOf: distStream) >= 3])
			ifFalse:[^interpreterProxy primitiveFail].
	self cCode:'' inSmalltalk:[
		zipMatchLengthCodes := CArrayAccessor on: ZipWriteStream matchLengthCodes.
		zipDistanceCodes := CArrayAccessor on: ZipWriteStream distanceCodes.
		zipExtraLengthBits := CArrayAccessor on: ZipWriteStream extraLengthBits.
		zipExtraDistanceBits := CArrayAccessor on: ZipWriteStream extraDistanceBits.
		zipBaseLength := CArrayAccessor on: ZipWriteStream baseLength.
		zipBaseDistance := CArrayAccessor on: ZipWriteStream baseDistance].
	result := self sendBlock: litStream with: distStream with: litTree with: distTree.
	interpreterProxy failed ifFalse:[
		interpreterProxy storeInteger: 1 ofObject: rcvr withValue: zipPosition.
		interpreterProxy storeInteger: 4 ofObject: rcvr withValue: zipBitBuf.
		interpreterProxy storeInteger: 5 ofObject: rcvr withValue: zipBitPos.
	].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 5. "rcvr + args"
		interpreterProxy pushInteger: result.
	].! !
!DeflatePlugin methodsFor: 'encoding' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:01'!
sendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Require: 
		zipCollection, zipCollectionSize, zipPosition,
		zipBitBuf, zipBitPos.
	"
	| oop litPos litLimit litArray distArray lit dist sum llBitLengths llCodes distBitLengths distCodes code extra litBlCount distBlCount |
	<var: #litArray type: 'unsigned char *'>
	<var: #distArray type: 'unsigned int *'>
	<var: #llBitLengths type: 'unsigned int *'>
	<var: #llCodes type: 'unsigned int *'>
	<var: #distBitLengths type: 'unsigned int *'>
	<var: #distCodes type: 'unsigned int *'>
	oop := interpreterProxy fetchPointer: 0 ofObject: literalStream.
	litPos := interpreterProxy fetchInteger: 1 ofObject: literalStream.
	litLimit := interpreterProxy fetchInteger: 2 ofObject: literalStream.
	((interpreterProxy isIntegerObject: oop) not and:[litPos <= litLimit and:[
		litLimit <= (interpreterProxy byteSizeOf: oop) and:[interpreterProxy isBytes: oop]]])
			ifFalse:[^interpreterProxy primitiveFail].
	litArray := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 0 ofObject: distanceStream.
	((interpreterProxy isIntegerObject: oop) not and:[
		(interpreterProxy fetchInteger: 1 ofObject: distanceStream) = litPos and:[
			(interpreterProxy fetchInteger: 2 ofObject: distanceStream) = litLimit]])
				ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isWords: oop) and:[
		litLimit <= (interpreterProxy slotSizeOf: oop)])
			ifFalse:[^interpreterProxy primitiveFail].
	distArray := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 0 ofObject: litTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	litBlCount := interpreterProxy slotSizeOf: oop.
	llBitLengths := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 1 ofObject: litTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	(litBlCount = (interpreterProxy slotSizeOf: oop))
		ifFalse:[^interpreterProxy primitiveFail].
	llCodes := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 0 ofObject: distTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	distBlCount := interpreterProxy slotSizeOf: oop.
	distBitLengths := interpreterProxy firstIndexableField: oop.

	oop := interpreterProxy fetchPointer: 1 ofObject: distTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	(distBlCount = (interpreterProxy slotSizeOf: oop))
		ifFalse:[^interpreterProxy primitiveFail].
	distCodes := interpreterProxy firstIndexableField: oop.

	interpreterProxy failed ifTrue:[^nil].

	self nextZipBits: 0 put: 0. "Flush pending bits if necessary"
	sum := 0.
	[litPos < litLimit and:[zipPosition + 4 < zipCollectionSize]] whileTrue:[
		lit := litArray at: litPos.
		dist := distArray at: litPos.
		litPos := litPos + 1.
		dist = 0 ifTrue:["literal"
			sum := sum + 1.
			lit < litBlCount ifFalse:[^interpreterProxy primitiveFail].
			self nextZipBits: (llBitLengths at: lit) put: (llCodes at: lit).
		] ifFalse:["match"
			sum := sum + lit + DeflateMinMatch.
			lit < 256 ifFalse:[^interpreterProxy primitiveFail].
			code := zipMatchLengthCodes at: lit.
			code < litBlCount ifFalse:[^interpreterProxy primitiveFail].
			self nextZipBits: (llBitLengths at: code) put: (llCodes at: code).
			extra := zipExtraLengthBits at: code - 257.
			extra = 0 ifFalse:[
				lit := lit - (zipBaseLength at: code - 257).
				self nextZipBits: extra put: lit].
			dist := dist - 1.
			dist < 16r8000 ifFalse:[^interpreterProxy primitiveFail].
			dist < 256
				ifTrue:[code := zipDistanceCodes at: dist]
				ifFalse:[code := zipDistanceCodes at: 256 + (dist >> 7)].
			code < distBlCount ifFalse:[^interpreterProxy primitiveFail].
			self nextZipBits: (distBitLengths at: code) put: (distCodes at: code).
			extra := zipExtraDistanceBits at: code.
			extra = 0 ifFalse:[
				dist := dist - (zipBaseDistance at: code).
				self nextZipBits: extra put: dist].
		].
	].
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy storeInteger: 1 ofObject: literalStream withValue: litPos.
	interpreterProxy storeInteger: 1 ofObject: distanceStream withValue: litPos.
	^sum! !
!DeflatePlugin methodsFor: 'encoding' stamp: 'ar (auto pragmas 12/08) 12/29/1999 22:00'!
shouldFlush
	"Check if we should flush the current block.
	Flushing can be useful if the input characteristics change."
	| nLits |
	<inline: false>
	zipLiteralCount = zipLiteralSize ifTrue:[^true]. "We *must* flush"
	(zipLiteralCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes"
	zipMatchCount * 10 <= zipLiteralCount ifTrue:[
		"This is basically random data. 
		There is no need to flush early since the overhead
		for encoding the trees will add to the overall size"
		^false].
	"Try to adapt to the input data.
	We flush if the ratio between matches and literals
	changes beyound a certain threshold"
	nLits := zipLiteralCount - zipMatchCount.
	nLits <= zipMatchCount ifTrue:[^false]. "whow!! so many matches"
	^nLits * 4 <= zipMatchCount! !
!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:28'!
updateHash: nextValue
	"Update the running hash value based on the next input byte.
	Return the new updated hash value."
	^((zipHashValue bitShift: DeflateHashShift) bitXor: nextValue) bitAnd: DeflateHashMask.! !
!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:29'!
updateHashAt: here
	"Update the hash value at position here (one based)"
	^self updateHash: (zipCollection at: here)! !
!InflatePlugin class methodsFor: 'translation' stamp: 'sma 3/3/2000 12:31'!
declareCVarsIn: cg
	cg var: #zipCollection type: #'unsigned char*'.
	cg var: #zipSource type: #'unsigned char*'.
	cg var: #zipLitTable type: #'unsigned int*'.
	cg var: #zipDistTable type: #'unsigned int*'! !
!InflatePlugin class methodsFor: 'class initialization' stamp: 'ar 12/21/1999 23:02'!
initialize
	"InflatePlugin initialize"
	MaxBits := 16.
	StateNoMoreData := 1.! !
!InflatePlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 23:58'!
moduleName
	^'ZipPlugin'! !
!InflatePlugin class methodsFor: 'translation' stamp: 'tpr 5/14/2001 12:27'!
shouldBeTranslated
"InflatePlugin should not be translated but its subclass should since it is incorporated within that class's translation process"
	^self ~= InflatePlugin! !
!InflatePlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 12/22/1999 00:04'!
primitiveInflateDecompressBlock
	"Primitive. Inflate a single block."
	| oop rcvr |
	<export: true>
	interpreterProxy methodArgumentCount = 2 ifFalse:[^interpreterProxy primitiveFail].
	"distance table"
	oop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipDistTable := interpreterProxy firstIndexableField: oop.
	zipDistTableSize := interpreterProxy slotSizeOf: oop.

	"literal table"
	oop := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipLitTable := interpreterProxy firstIndexableField: oop.
	zipLitTableSize := interpreterProxy slotSizeOf: oop.


	"Receiver (InflateStream)"
	rcvr := interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isPointers: rcvr)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: rcvr) < 9
		ifTrue:[^interpreterProxy primitiveFail].

	"All the integer instvars"
	zipReadLimit := interpreterProxy fetchInteger: 2 ofObject: rcvr.
	zipState := interpreterProxy fetchInteger: 3 ofObject: rcvr.
	zipBitBuf := interpreterProxy fetchInteger: 4 ofObject: rcvr.
	zipBitPos := interpreterProxy fetchInteger: 5 ofObject: rcvr.
	zipSourcePos := interpreterProxy fetchInteger: 7 ofObject: rcvr.
	zipSourceLimit := interpreterProxy fetchInteger: 8 ofObject: rcvr.
	interpreterProxy failed ifTrue:[^nil].
	zipReadLimit := zipReadLimit - 1.
	zipSourcePos := zipSourcePos - 1.
	zipSourceLimit := zipSourceLimit - 1.

	"collection"
	oop := interpreterProxy fetchPointer: 0 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipCollection := interpreterProxy firstIndexableField: oop.
	zipCollectionSize := interpreterProxy byteSizeOf: oop.

	"source"
	oop := interpreterProxy fetchPointer: 6 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipSource := interpreterProxy firstIndexableField: oop.

	"do the primitive"
	self zipDecompressBlock.
	interpreterProxy failed ifFalse:[
		"store modified values back"
		interpreterProxy storeInteger: 2 ofObject: rcvr withValue: zipReadLimit + 1.
		interpreterProxy storeInteger: 3 ofObject: rcvr withValue: zipState.
		interpreterProxy storeInteger: 4 ofObject: rcvr withValue: zipBitBuf.
		interpreterProxy storeInteger: 5 ofObject: rcvr withValue: zipBitPos.
		interpreterProxy storeInteger: 7 ofObject: rcvr withValue: zipSourcePos + 1.
		interpreterProxy pop: 2.
	].! !
!InflatePlugin methodsFor: 'inflating' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 16:22'!
zipDecodeValueFrom: table size: tableSize
	"Decode the next value in the receiver using the given huffman table."
	| bits bitsNeeded tableIndex value index |
	<var: #table type: 'unsigned int *'>
	bitsNeeded := (table at: 0) bitShift: -24.	"Initial bits needed"
	bitsNeeded > MaxBits ifTrue:[interpreterProxy primitiveFail. ^0].
	tableIndex := 2.							"First real table"
	[true] whileTrue:[
		bits := self zipNextBits: bitsNeeded.		"Get bits"
		index := tableIndex + bits - 1.
		index >= tableSize ifTrue:[interpreterProxy primitiveFail. ^0].
		value := table at: index.					"Lookup entry in table"
		(value bitAnd: 16r3F000000) = 0 ifTrue:[^value]. "Check if it is a leaf node"
		"Fetch sub table"
		tableIndex := value bitAnd: 16rFFFF.	"Table offset in low 16 bit"
		bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit"
		bitsNeeded > MaxBits ifTrue:[interpreterProxy primitiveFail. ^0]].
	^0! !
!InflatePlugin methodsFor: 'inflating' stamp: 'ar (auto pragmas 12/08) 12/22/1999 00:04'!
zipDecompressBlock
	| value extra length distance oldPos oldBits oldBitPos dstPos srcPos max |
	<inline: false>
	max := zipCollectionSize - 1.
	[zipReadLimit < max and:[zipSourcePos <= zipSourceLimit]] whileTrue:[
		"Back up stuff if we're running out of space"
		oldBits := zipBitBuf.
		oldBitPos := zipBitPos.
		oldPos := zipSourcePos.
		value := self zipDecodeValueFrom: zipLitTable size: zipLitTableSize.
		value < 256 ifTrue:[ "A literal"
			zipCollection at: (zipReadLimit := zipReadLimit + 1) put: value.
		] ifFalse:["length/distance or end of block"
			value = 256 ifTrue:["End of block"
				zipState := zipState bitAnd: StateNoMoreData.
				^0].
			"Compute the actual length value (including possible extra bits)"
			extra := (value bitShift: -16) - 1.
			length := value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[length := length + (self zipNextBits: extra)].
			"Compute the distance value"
			value := self zipDecodeValueFrom: zipDistTable size: zipDistTableSize.
			extra := (value bitShift: -16).
			distance := value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[distance := distance + (self zipNextBits: extra)].
			(zipReadLimit + length >= max) ifTrue:[
				zipBitBuf := oldBits.
				zipBitPos := oldBitPos.
				zipSourcePos := oldPos.
				^0].
			dstPos := zipReadLimit.
			srcPos := zipReadLimit - distance.
			1 to: length do:[:i|
				zipCollection at: dstPos+i put: (zipCollection at: srcPos+i)].
			zipReadLimit := zipReadLimit + length.
		].
	].! !
!InflatePlugin methodsFor: 'inflating' stamp: 'ar (auto pragmas 12/08) 12/21/1999 23:06'!
zipNextBits: n
	| bits byte |
	<inline: true>
	[zipBitPos < n] whileTrue:[
		byte := zipSource at: (zipSourcePos := zipSourcePos + 1).
		zipBitBuf := zipBitBuf + (byte << zipBitPos).
		zipBitPos := zipBitPos + 8].
	bits := zipBitBuf bitAnd: (1 << n)-1.
	zipBitBuf := zipBitBuf >> n.
	zipBitPos := zipBitPos - n.
	^bits! !
!InterpreterPlugin class methodsFor: 'accessing' stamp: 'tpr 12/17/2003 16:52'!
allCallsOn
	"Answer a SortedCollection of all the methods that refer to me. Most classes simply defer to SystemDictionary>allCallsOn: but some have special requirements - plugins may have a module name that does not match the class name"

	self theNonMetaClass name ~= self moduleName asSymbol
		ifTrue:[^super allCallsOn, (self systemNavigation allCallsOn: self moduleName asSymbol)]
		ifFalse:[^super allCallsOn]! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 5/12/2000 00:24'!
baseDirectoryName
	"Return the directory into which plugins should be generated by default."
	^FileDirectory default pathName! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'ikp 8/3/2004 18:55'!
buildCodeGeneratorUpTo: aPluginClass
	"Build a CCodeGenerator for the plugin"
	 | cg theClass |
	cg := self codeGeneratorClass new initialize.
	cg pluginName: self moduleName.
	"Add an extra declaration for module name"
	cg declareModuleName: self moduleNameAndVersion.

	theClass := aPluginClass.
	[theClass == Object | (theClass == InterpreterSimulationObject)] whileFalse:[
		cg addClass: theClass.
		theClass := theClass superclass].
	^cg! !
!InterpreterPlugin class methodsFor: 'private' stamp: 'tpr 6/9/2003 16:41'!
codeGeneratorClass
	"return the appropriate class of code generator for this kind ofplugin"

	^VMPluginCodeGenerator! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 5/12/2000 00:34'!
declareCVarsIn: aCCodeGenerator
	"Note: This method must be implemented by all subclasses to declare variables."

	aCCodeGenerator 
		var: #interpreterProxy 
		type: #'struct VirtualMachine*'.
	self declareHeaderFilesIn: aCCodeGenerator.! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:14'!
declareHeaderFilesIn: aCCodeGenerator
	self hasHeaderFile ifTrue:[
		aCCodeGenerator addHeaderFile: '"', self moduleName,'.h"'].! !
!InterpreterPlugin class methodsFor: 'instance creation' stamp: 'ar 12/31/2001 01:36'!
doPrimitive: primitiveName 
	| proxy plugin |
	proxy := InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	plugin := self simulatorClass new.
	plugin setInterpreter: proxy.
	(plugin respondsTo: #initialiseModule) ifTrue:[plugin initialiseModule].
	plugin perform: primitiveName asSymbol.
	^ proxy stackValue: 0! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:03'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^false! !
!InterpreterPlugin class methodsFor: 'class initialization' stamp: 'ar 9/16/1998 20:26'!
initialize
	"Nothing to do ..."! !
!InterpreterPlugin class methodsFor: 'accessing' stamp: 'RMF 3/27/2000 09:39'!
isCPP
	^ false! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 5/28/2008 19:03'!
isSuitablePluginForPlatform: platName
"Is this plugin one that should be built for platName? We do NOT test for the existence of any external files here"
	"generic answer is true"
	^true! !
!InterpreterPlugin class methodsFor: 'accessing' stamp: 'sma 4/22/2000 12:32'!
moduleExtension
	^ self isCPP ifTrue: ['.cpp'] ifFalse: ['.c']! !
!InterpreterPlugin class methodsFor: 'accessing' stamp: 'sma 3/3/2000 12:24'!
moduleName
	"Answer the receiver's module name that is used for the plugin's C code."

	^ self name asString! !
!InterpreterPlugin class methodsFor: 'accessing' stamp: 'TPR 5/23/2000 15:33'!
moduleNameAndVersion
	"Answer the receiver's module name and version info that is used for the plugin's C code. The default is to append the code generation date, but any useful text is ok (keep it short)"

	^ self moduleName, Character space asString, Date today asString! !
!InterpreterPlugin class methodsFor: 'compiling' stamp: 'tpr 2/17/2005 13:19'!
noteCompilationOf: aSelector meta: isMeta
	"note the recompiliation by resetting the timeStamp "
	timeStamp := Time totalSeconds.
	^super noteCompilationOf: aSelector meta: isMeta! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 2/27/2004 19:05'!
requiredMethodNames
	"return the list of method names that should be retained for export or other support reasons"
	"just which methods?"
	^#()! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 7/2/2001 16:33'!
requiresCrossPlatformFiles
	"default is ok for most, any plugin needing cross platform files aside from a normal header must say so. See SoundCodecPlugin for example"
	^self hasHeaderFile! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 11/21/2000 11:53'!
requiresPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^false! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 5/14/2001 12:05'!
shouldBeTranslated
"is this class intended to be translated as a plugin? Most subclasses should answer true, but some such as:-
	TestInterpreterPlugin
	FlippArrayPlugin2
	InflatePlugin
	should answer false for various reasons."
	^true! !
!InterpreterPlugin class methodsFor: 'accessing' stamp: 'ajh 8/21/2002 21:43'!
simulatorClass
	"For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code.  By default every non-TestInterpreterPlugin can simulate itself."

	^ self! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 9/26/2001 07:27'!
storeString: s onFileNamed: fileName
	"Store the given string in a file of the given name."

	| f |
	f := CrLfFileStream forceNewFileNamed: fileName.
	f nextPutAll: s.
	f close.! !
!InterpreterPlugin class methodsFor: 'accessing' stamp: 'tpr 3/26/2002 15:25'!
timeStamp
	^timeStamp ifNil:[0]! !
!InterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 4/9/2002 16:14'!
translateInDirectory: directory doInlining: inlineFlag
"This is the default method for writing out sources for a plugin. Several classes need special handling, so look at all implementors of this message"
	| cg fname fstat |
	 fname := self moduleName, '.c'.

	"don't translate if the file is newer than my timeStamp"
	fstat := directory entryAt: fname ifAbsent:[nil].
	fstat ifNotNil:[self timeStamp < fstat modificationTime ifTrue:[^nil]].

	self initialize.
	cg := self buildCodeGeneratorUpTo: self.
	cg storeCodeOnFile:  (directory fullNameFor: fname) doInlining: inlineFlag.
	^cg exportedPrimitiveNames asArray! !
!InterpreterPlugin methodsFor: 'initialize' stamp: 'ikp (auto pragmas 12/08) 8/3/2004 19:18'!
getInterpreter
	"Note: This is coded so that plugins can be run from Squeak."

	<returnTypeC: 'VirtualMachine *'>
	^interpreterProxy! !
!InterpreterPlugin methodsFor: 'initialize' stamp: 'ar (auto pragmas dtl 2010-09-28) 5/13/2000 02:00'!
getModuleName
	"Note: This is hardcoded so it can be run from Squeak.
	The module name is used for validating a module *after*
	it is loaded to check if it does really contain the module
	we're thinking it contains. This is important!!"
	<returnTypeC: 'const char*'>
	<export: true>
	^moduleName! !
!InterpreterPlugin methodsFor: 'debugging' stamp: 'yo 1/1/2004 11:09'!
halt
	self cCode: '' inSmalltalk: [nil halt].! !
!InterpreterPlugin methodsFor: 'debugging' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 16:34'!
msg: s 
	<var: #s type: 'char *'>
	self cCode: 'fprintf(stderr, "\n%s: %s", moduleName, s)' inSmalltalk: [Transcript cr; show: self class moduleName , ': ' , s; endEntry]! !
!InterpreterPlugin methodsFor: 'initialize' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:53'!
setInterpreter: anInterpreter 
	"Note: This is coded so that is can be run from Squeak."

	| ok |
	<export: true>
	<var: #anInterpreter type: #'struct VirtualMachine*'>
	interpreterProxy := anInterpreter.
	ok := self cCode: 'interpreterProxy->majorVersion() == VM_PROXY_MAJOR'.
	ok == false ifTrue: [^ false].
	ok := self cCode: 'interpreterProxy->minorVersion() >= VM_PROXY_MINOR'.
	^ ok! !

InterpreterPlugin subclass: #JPEGReaderPlugin
	instanceVariableNames: 'yComponent crComponent cbComponent ySampleStream crSampleStream cbSampleStream yBlocks crBlocks cbBlocks residuals ditherMask jpegBits jpegBitsSize jpegNaturalOrder jsCollection jsPosition jsReadLimit jsBitBuffer jsBitCount acTable dcTable acTableSize dcTableSize'
	classVariableNames: 'BlockWidthIndex BlueIndex ConstBits CurrentXIndex CurrentYIndex DCTSize DCTSize2 FIXn0n298631336 FIXn0n34414 FIXn0n390180644 FIXn0n541196100 FIXn0n71414 FIXn0n765366865 FIXn0n899976223 FIXn1n175875602 FIXn1n40200 FIXn1n501321110 FIXn1n77200 FIXn1n847759065 FIXn1n961570560 FIXn2n053119869 FIXn2n562915447 FIXn3n072711026 GreenIndex HScaleIndex LookaheadBitsIndex LookaheadSymbolIndex MCUBlockIndex MCUWidthIndex MaxBits MaxMCUBlocks MaxSample MaxcodeIndex MinComponentSize Pass1Bits Pass1Div Pass2Div PriorDCValueIndex RedIndex SampleOffset VScaleIndex'
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!JPEGReaderPlugin commentStamp: 'tpr 5/5/2003 12:10' prior: 0!
This is another JPEG reader plugin, this time not requiring jpeglib support. !
!JPEGReaderPlugin class methodsFor: 'translation' stamp: 'ar 3/4/2001 21:13'!
declareCVarsIn: cg
	cg var: 'yComponent'
		declareC: 'int yComponent[' , MinComponentSize printString , ']'.
	cg var: 'crComponent'
		declareC: 'int crComponent[' , MinComponentSize printString , ']'.
	cg var: 'cbComponent'
		declareC: 'int cbComponent[' , MinComponentSize printString , ']'.
	cg var: 'yBlocks'
		declareC: 'int *yBlocks[' , MaxMCUBlocks printString , ']'.
	cg var: 'crBlocks'
		declareC: 'int *crBlocks[' , MaxMCUBlocks printString  , ']'.
	cg var: 'cbBlocks'
		declareC: 'int *cbBlocks[' , MaxMCUBlocks printString  , ']'.
	cg var: 'residuals'
		declareC: 'int *residuals'.
	cg var: 'jpegBits'
		declareC: 'int *jpegBits'.

	cg var: 'jpegNaturalOrder'
		declareC: 'int jpegNaturalOrder[64] = {
	0, 1, 8, 16, 9, 2, 3, 10, 
	17, 24, 32, 25, 18, 11, 4, 5, 
	12, 19, 26, 33, 40, 48, 41, 34, 
	27, 20, 13, 6, 7, 14, 21, 28, 
	35, 42, 49, 56, 57, 50, 43, 36, 
	29, 22, 15, 23, 30, 37, 44, 51, 
	58, 59, 52, 45, 38, 31, 39, 46, 
	53, 60, 61, 54, 47, 55, 62, 63
}'.

	cg var: 'jsCollection' 
		declareC:'unsigned char *jsCollection'.
	cg var: 'acTable' 
		declareC:'int *acTable'.
	cg var: 'dcTable' 
		declareC:'int *dcTable'.
! !
!JPEGReaderPlugin class methodsFor: 'class initialization' stamp: 'ar 3/4/2001 19:13'!
initialize
	"JPEGReaderPlugin initialize"
	DCTSize := 8.
	MaxSample := (2 raisedToInteger: DCTSize) - 1.
	SampleOffset := MaxSample // 2.
	DCTSize2 := DCTSize squared.
	ConstBits := 13.
	Pass1Bits := 2.
	Pass1Div := 1 bitShift: ConstBits - Pass1Bits.
	Pass2Div := 1 bitShift: ConstBits + Pass1Bits + 3.

	"fixed-point Inverse Discrete Cosine Transform (IDCT) constants"
	FIXn0n298631336 := 2446.
	FIXn0n390180644 := 3196.
	FIXn0n541196100 := 4433.
	FIXn0n765366865 := 6270.
	FIXn0n899976223 := 7373.
	FIXn1n175875602 := 9633.
	FIXn1n501321110 := 12299.
	FIXn1n847759065 := 15137.
	FIXn1n961570560 := 16069.
	FIXn2n053119869 := 16819.
	FIXn2n562915447 := 20995.
	FIXn3n072711026 := 25172.

	"fixed-point color conversion constants"
	FIXn0n34414 := 22554.
	FIXn0n71414 := 46802.
	FIXn1n40200 := 91881.
	FIXn1n77200 :=  116130.

	CurrentXIndex := 0.
	CurrentYIndex := 1.
	HScaleIndex := 2.
	VScaleIndex := 3.
	MCUBlockIndex := 4.
	BlockWidthIndex := 5.
	MCUWidthIndex := 8.
	PriorDCValueIndex := 10.
	MinComponentSize := 11.

	RedIndex := 0.
	GreenIndex := 1.
	BlueIndex := 2.

	MaxMCUBlocks := 128.
	MaxBits := 16.! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar 3/4/2001 21:11'!
cbColorComponentFrom: oop
	^(self colorComponent: cbComponent from: oop)
		and:[self colorComponentBlocks: cbBlocks from: oop]! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 20:08'!
colorComponent: aColorComponent from: oop
	<var: #aColorComponent type: 'int *'>
	(interpreterProxy isIntegerObject: oop) ifTrue:[^false].
	(interpreterProxy isPointers: oop) ifFalse:[^false].
	(interpreterProxy slotSizeOf: oop) < MinComponentSize ifTrue:[^false].
	aColorComponent at: CurrentXIndex put: 
		(interpreterProxy fetchInteger: CurrentXIndex ofObject: oop).
	aColorComponent at: CurrentYIndex put: 
		(interpreterProxy fetchInteger: CurrentYIndex ofObject: oop).
	aColorComponent at: HScaleIndex put: 
		(interpreterProxy fetchInteger: HScaleIndex ofObject: oop).
	aColorComponent at: VScaleIndex put: 
		(interpreterProxy fetchInteger: VScaleIndex ofObject: oop).
	aColorComponent at: BlockWidthIndex put: 
		(interpreterProxy fetchInteger: BlockWidthIndex ofObject: oop).
	aColorComponent at: MCUWidthIndex put: 
		(interpreterProxy fetchInteger: MCUWidthIndex ofObject: oop).
	aColorComponent at: PriorDCValueIndex put: 
		(interpreterProxy fetchInteger: PriorDCValueIndex ofObject: oop).
	^interpreterProxy failed not! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 20:08'!
colorComponentBlocks: blocks from: oop
	| arrayOop max blockOop |
	<var: #blocks type: 'int **'>
	(interpreterProxy isIntegerObject: oop) ifTrue:[^false].
	(interpreterProxy isPointers: oop) ifFalse:[^false].
	(interpreterProxy slotSizeOf: oop) < MinComponentSize ifTrue:[^false].

	arrayOop := interpreterProxy fetchPointer: MCUBlockIndex ofObject: oop.
	(interpreterProxy isIntegerObject: arrayOop) ifTrue:[^false].
	(interpreterProxy isPointers: arrayOop) ifFalse:[^false].
	max := interpreterProxy slotSizeOf: arrayOop.
	max > MaxMCUBlocks ifTrue:[^false].
	0 to: max-1 do:[:i|
		blockOop := interpreterProxy fetchPointer: i ofObject: arrayOop.
		(interpreterProxy isIntegerObject: blockOop) ifTrue:[^false].
		(interpreterProxy isWords: blockOop) ifFalse:[^false].
		(interpreterProxy slotSizeOf: blockOop) = DCTSize2 ifFalse:[^false].
		blocks at: i put: (interpreterProxy firstIndexableField: blockOop).
	].
	^interpreterProxy failed not! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar 3/4/2001 22:24'!
colorConvertGrayscaleMCU
	| y |
	yComponent at: CurrentXIndex put: 0.
	yComponent at: CurrentYIndex put: 0.
	0 to: jpegBitsSize-1 do:[:i|
		y := self nextSampleY.
		y := y + (residuals at: GreenIndex).
		y := y min: MaxSample.
		residuals at: GreenIndex put: (y bitAnd: ditherMask).
		y := y bitAnd: MaxSample - ditherMask.
		y := y max: 1.
		jpegBits at: i put: 16rFF000000 + (y<<16) + (y<<8) + y.
	].! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar 3/4/2001 21:11'!
colorConvertMCU
	| y cb cr red green blue |
	yComponent at: CurrentXIndex put: 0.
	yComponent at: CurrentYIndex put: 0.
	cbComponent at: CurrentXIndex put: 0.
	cbComponent at: CurrentYIndex put: 0.
	crComponent at: CurrentXIndex put: 0.
	crComponent at: CurrentYIndex put: 0.
	0 to: jpegBitsSize-1 do:[:i|
		y := self nextSampleY.
		cb := self nextSampleCb.
		cb := cb - SampleOffset.
		cr := self nextSampleCr.
		cr := cr - SampleOffset.
		red := y + ((FIXn1n40200 * cr) // 65536) + (residuals at: RedIndex).
		red := red min: MaxSample. red := red max: 0.
		residuals at: RedIndex put: (red bitAnd: ditherMask).
		red := red bitAnd: MaxSample - ditherMask.
		red := red max: 1.
		green := y - ((FIXn0n34414 * cb) // 65536) -
			((FIXn0n71414 * cr) // 65536) + (residuals at: GreenIndex).
		green := green min: MaxSample. green := green max: 0.
		residuals at: GreenIndex put: (green bitAnd: ditherMask).
		green := green bitAnd: MaxSample - ditherMask.
		green := green max: 1.
		blue := y + ((FIXn1n77200 * cb) // 65536) + (residuals at: BlueIndex).
		blue := blue min: MaxSample. blue := blue max: 0.
		residuals at: BlueIndex put: (blue bitAnd: ditherMask).
		blue := blue bitAnd: MaxSample - ditherMask.
		blue := blue max: 1.
		jpegBits at: i put: 16rFF000000 + (red bitShift: 16) + (green bitShift: 8) + blue.
	].! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar 3/4/2001 21:11'!
crColorComponentFrom: oop
	^(self colorComponent: crComponent from: oop)
		and:[self colorComponentBlocks: crBlocks from: oop]! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:17'!
decodeBlockInto: anArray component: aColorComponent
	| byte zeroCount bits index |
	<var: #anArray type: 'int *'>
	<var: #aColorComponent type: 'int *'>
	byte := self jpegDecodeValueFrom: dcTable size: dcTableSize.
	byte < 0 ifTrue:[^interpreterProxy primitiveFail].
	byte ~= 0 ifTrue: [
		bits := self getBits: byte.
		byte := self scaleAndSignExtend: bits inFieldWidth: byte].
	byte := aColorComponent 
				at: PriorDCValueIndex 
				put: (aColorComponent at: PriorDCValueIndex) + byte.
	anArray at: 0 put: byte.
	1 to: DCTSize2 - 1 do:[:i| anArray at: i put: 0].
	index := 1.
	[index < DCTSize2] whileTrue:[
		byte := self jpegDecodeValueFrom: acTable size: acTableSize.
		byte < 0 ifTrue:[^interpreterProxy primitiveFail].
		zeroCount := byte >> 4.
		byte := byte bitAnd: 16r0F.
		byte ~= 0 ifTrue:[
			index := index + zeroCount.
			bits :=  self getBits: byte.
			byte := self scaleAndSignExtend: bits inFieldWidth: byte.
			(index < 0 or:[index >= DCTSize2]) ifTrue:[^interpreterProxy primitiveFail].
			anArray at:	 (jpegNaturalOrder at: index) put: byte.
		] ifFalse:[
			zeroCount = 15 ifTrue: [index := index + zeroCount] ifFalse: [^ nil].
		].
		index := index + 1
	].! !
!JPEGReaderPlugin methodsFor: 'stream support' stamp: 'ar 3/4/2001 20:44'!
fillBuffer
	| byte |
	[jsBitCount <= 16] whileTrue:[
		jsPosition < jsReadLimit ifFalse:[^jsBitCount].
		byte := jsCollection at: jsPosition.
		jsPosition := jsPosition + 1.
		byte = 16rFF ifTrue:["peek for 00"
			((jsPosition < jsReadLimit) and:[(jsCollection at: jsPosition) = 16r00]) ifFalse:[
				jsPosition := jsPosition - 1.
				^jsBitCount].
			jsPosition := jsPosition + 1].
		jsBitBuffer := (jsBitBuffer bitShift: 8) bitOr: byte.
		jsBitCount := jsBitCount + 8].
	^jsBitCount! !
!JPEGReaderPlugin methodsFor: 'stream support' stamp: 'ar 3/4/2001 21:22'!
getBits: requestedBits
	| value |
	requestedBits > jsBitCount ifTrue:[
		self fillBuffer.
		requestedBits > jsBitCount ifTrue:[^-1]].
	value := jsBitBuffer bitShift: (requestedBits - jsBitCount).
	jsBitBuffer := jsBitBuffer bitAnd: (1 bitShift: (jsBitCount - requestedBits)) -1.
	jsBitCount := jsBitCount - requestedBits.
	^ value! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas dtl 2010-09-28) 3/4/2001 21:16'!
idctBlockInt: anArray qt: qt
	| ws anACTerm dcval z2 z3 z1 t2 t3 t0 t1 t10 t13 t11 t12 z4 z5 v |
	<var: #anArray type: 'int *'>
	<var: #qt type: 'int *'>
	<var: #ws declareC: 'int ws[64]'>
	self cCode:'' inSmalltalk:[ws := CArrayAccessor on: (IntegerArray new: 64)].
	"Pass 1: process columns from anArray, store into work array"
	0 to: DCTSize-1 do:[:i |
		anACTerm := -1.
		1 to: DCTSize-1 do:[:row|
			anACTerm = -1 ifTrue:[
				(anArray at: row * DCTSize + i) = 0 ifFalse:[anACTerm := row]]].
		anACTerm = -1 ifTrue:[
			dcval := (anArray at: i) * (qt at: 0) bitShift: Pass1Bits.
			0 to: DCTSize-1 do: [:j | ws at: (j * DCTSize + i) put: dcval]
		] ifFalse:[
			z2 := (anArray at: (DCTSize * 2 + i)) * (qt at: (DCTSize * 2 + i)).
			z3 := (anArray at: (DCTSize * 6 + i)) * (qt at: (DCTSize * 6 + i)).
			z1 := (z2 + z3) * FIXn0n541196100.
			t2 := z1 + (z3 * (0 - FIXn1n847759065)).
			t3 := z1 + (z2 * FIXn0n765366865).
			z2 := (anArray at: i) * (qt at: i).
			z3 := (anArray at: (DCTSize * 4 + i)) * (qt at: (DCTSize * 4 + i)).
			t0 := (z2 + z3) bitShift: ConstBits.
			t1 := (z2 - z3) bitShift: ConstBits.
			t10 := t0 + t3.
			t13 := t0 - t3.
			t11 := t1 + t2.
			t12 := t1 - t2.
			t0 := (anArray at: (DCTSize * 7 + i)) * (qt at: (DCTSize * 7 + i)).
			t1 := (anArray at: (DCTSize * 5 + i)) * (qt at: (DCTSize * 5 + i)).
			t2 := (anArray at: (DCTSize * 3 + i)) * (qt at: (DCTSize * 3 + i)).
			t3 := (anArray at: (DCTSize + i)) * (qt at: (DCTSize + i)).
			z1 := t0 + t3.
			z2 := t1 + t2.
			z3 := t0 + t2.
			z4 := t1 + t3.
			z5 := (z3 + z4) * FIXn1n175875602.
			t0 := t0 * FIXn0n298631336.
			t1 := t1 * FIXn2n053119869.
			t2 := t2 * FIXn3n072711026.
			t3 := t3 * FIXn1n501321110.
			z1 := z1 * (0 - FIXn0n899976223).
			z2 := z2 * (0 - FIXn2n562915447).
			z3 := z3 * (0 - FIXn1n961570560).
			z4 := z4 * (0 - FIXn0n390180644).
			z3 := z3 + z5.
			z4 := z4 + z5.
			t0 := t0 + z1 + z3.
			t1 := t1 +z2 +z4.
			t2 := t2 + z2 + z3.
			t3 := t3 + z1 + z4.
			ws at: i put: (t10 + t3) // Pass1Div.
			ws at: (DCTSize * 7 + i) put: (t10 - t3) // Pass1Div.
			ws at: (DCTSize * 1 + i) put: (t11 + t2) // Pass1Div.
			ws at: (DCTSize * 6 + i) put: (t11 - t2) // Pass1Div.
			ws at: (DCTSize * 2 + i) put: (t12 + t1) // Pass1Div.
			ws at: (DCTSize * 5 + i) put: (t12 - t1) // Pass1Div.
			ws at: (DCTSize * 3 + i) put: (t13 + t0) // Pass1Div.
			ws at: (DCTSize * 4 + i) put: (t13 - t0) // Pass1Div]].

	"Pass 2: process rows from work array, store back into anArray"
	0 to: DCTSize2-DCTSize by: DCTSize do:[:i |
		z2 := ws at: i + 2.
		z3 := ws at: i + 6.
		z1 := (z2 + z3) * FIXn0n541196100.
		t2 := z1 + (z3 * (0-FIXn1n847759065)).
		t3 := z1 + (z2 * FIXn0n765366865).
		t0 := (ws at: i) + (ws at: (i + 4)) bitShift: ConstBits.
		t1 := (ws at: i) - (ws at: (i + 4)) bitShift: ConstBits.
		t10 := t0 + t3.
		t13 := t0 - t3.
		t11 := t1 + t2.
		t12 := t1 -t2.
		t0 := ws at: (i + 7).
		t1 := ws at: (i + 5).
		t2 := ws at: (i + 3).
		t3 := ws at: (i + 1).
		z1 := t0 + t3.
		z2 := t1 + t2.
		z3 := t0 + t2.
		z4 := t1 + t3.
		z5 := (z3 + z4) * FIXn1n175875602.
		t0 := t0 * FIXn0n298631336.
		t1 := t1 * FIXn2n053119869.
		t2 := t2 * FIXn3n072711026.
		t3 := t3 * FIXn1n501321110.
		z1 := z1 * (0-FIXn0n899976223).
		z2 := z2 * (0-FIXn2n562915447).
		z3 := z3 * (0-FIXn1n961570560).
		z4 := z4 * (0-FIXn0n390180644).
		z3 := z3 + z5.
		z4 := z4 + z5.
		t0 := t0 + z1 + z3.
		t1 := t1 + z2 + z4.
		t2 := t2 + z2 + z3.
		t3 := t3 + z1 + z4.
		v := (t10 + t3) // Pass2Div + SampleOffset.
		v := v min: MaxSample. v := v max: 0.
		anArray at: i put: v.
		v := (t10 - t3) // Pass2Div + SampleOffset.
		v := v min: MaxSample. v := v max: 0.
		anArray at: (i + 7) put: v.
		v := (t11 + t2) // Pass2Div + SampleOffset. 
		v := v min: MaxSample. v := v max: 0.
		anArray at: (i + 1) put: v.
		v := (t11 - t2) // Pass2Div + SampleOffset.
		v := v min: MaxSample. v := v max: 0.
		anArray at: (i + 6) put: v.
		v :=  (t12 + t1) // Pass2Div + SampleOffset.
		v := v min: MaxSample. v := v max: 0.
		anArray at: (i + 2) put: v.
		v :=  (t12 - t1) // Pass2Div + SampleOffset.
		v := v min: MaxSample. v := v max: 0.
		anArray at: (i + 5) put: v.
		v := (t13 + t0) // Pass2Div + SampleOffset.
		v := v min: MaxSample. v := v max: 0.
		anArray at: (i + 3) put: v.
		v := (t13 - t0) // Pass2Div + SampleOffset.
		v := v min: MaxSample. v := v max: 0.
		anArray at: (i + 4) put: v].! !
!JPEGReaderPlugin methodsFor: 'stream support' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 16:36'!
jpegDecodeValueFrom: table size: tableSize
	"Decode the next value in the receiver using the given huffman table."
	| bits bitsNeeded tableIndex value index |
	<var: #table type: 'int *'>
	bitsNeeded := (table at: 0) >> 24.	"Initial bits needed"
	bitsNeeded > MaxBits ifTrue:[^-1].
	tableIndex := 2.							"First real table"
	[true] whileTrue:[
		bits := self getBits: bitsNeeded.		"Get bits"
		bits < 0 ifTrue:[^-1].
		index := tableIndex + bits - 1.
		index >= tableSize ifTrue:[^-1].
		value := table at: index.					"Lookup entry in table"
		(value bitAnd: 16r3F000000) = 0 ifTrue:[^value]. "Check if it is a leaf node"
		"Fetch sub table"
		tableIndex := value bitAnd: 16rFFFF.	"Table offset in low 16 bit"
		bitsNeeded := (value >> 24) bitAnd: 255. "Additional bits in high 8 bit"
		bitsNeeded > MaxBits ifTrue:[^-1]].
	^-1! !
!JPEGReaderPlugin methodsFor: 'stream support' stamp: 'ar 3/4/2001 19:12'!
loadJPEGStreamFrom: streamOop
	| oop sz |
	(interpreterProxy slotSizeOf: streamOop) < 5 ifTrue:[^false].
	(interpreterProxy isPointers: streamOop) ifFalse:[^false].
	oop := interpreterProxy fetchPointer: 0 ofObject: streamOop.
	(interpreterProxy isIntegerObject: oop) ifTrue:[^false].
	(interpreterProxy isBytes: oop) ifFalse:[^false].
	jsCollection := interpreterProxy firstIndexableField: oop.
	sz := interpreterProxy byteSizeOf: oop.
	jsPosition := interpreterProxy fetchInteger: 1 ofObject: streamOop.
	jsReadLimit := interpreterProxy fetchInteger: 2 ofObject: streamOop.
	jsBitBuffer := interpreterProxy fetchInteger: 3 ofObject: streamOop.
	jsBitCount := interpreterProxy fetchInteger: 4 ofObject: streamOop.
	interpreterProxy failed ifTrue:[^false].
	sz < jsReadLimit ifTrue:[^false].
	(jsPosition < 0 or:[jsPosition >= jsReadLimit]) ifTrue:[^false].
	^true! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:11'!
nextSampleCb
	| dx dy blockIndex sampleIndex sample curX sx sy |
	<inline: true>
	dx := curX := cbComponent at: CurrentXIndex.
	dy := cbComponent at: CurrentYIndex.
	sx := cbComponent at: HScaleIndex.
	sy := cbComponent at: VScaleIndex.
	(sx = 0 and:[sy = 0]) ifFalse:[
		dx := dx // sx.
		dy := dy // sy.
	].
	blockIndex := (dy bitShift: -3) * (cbComponent at: BlockWidthIndex) + (dx bitShift: -3).
	sampleIndex := ((dy bitAnd: 7) bitShift: 3) + (dx bitAnd: 7).
	sample := (cbBlocks at: blockIndex) at: sampleIndex.
	curX := curX + 1.
	curX < ((cbComponent at: MCUWidthIndex) * 8) ifTrue:[
		cbComponent at: CurrentXIndex put: curX.
	] ifFalse:[
		cbComponent at: CurrentXIndex put: 0.
		cbComponent at: CurrentYIndex put: (cbComponent at: CurrentYIndex) + 1.
	].
	^ sample! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:11'!
nextSampleCr
	| dx dy blockIndex sampleIndex sample curX sx sy |
	<inline: true>
	dx := curX := crComponent at: CurrentXIndex.
	dy := crComponent at: CurrentYIndex.
	sx := crComponent at: HScaleIndex.
	sy := crComponent at: VScaleIndex.
	(sx = 0 and:[sy = 0]) ifFalse:[
		dx := dx // sx.
		dy := dy // sy.
	].
	blockIndex := (dy bitShift: -3) * (crComponent at: BlockWidthIndex) + (dx bitShift: -3).
	sampleIndex := ((dy bitAnd: 7) bitShift: 3) + (dx bitAnd: 7).
	sample := (crBlocks at: blockIndex) at: sampleIndex.
	curX := curX + 1.
	curX < ((crComponent at: MCUWidthIndex) * 8) ifTrue:[
		crComponent at: CurrentXIndex put: curX.
	] ifFalse:[
		crComponent at: CurrentXIndex put: 0.
		crComponent at: CurrentYIndex put: (crComponent at: CurrentYIndex) + 1.
	].
	^ sample! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:16'!
nextSampleFrom: aComponent blocks: aBlockArray
	| dx dy blockIndex sampleIndex sample curX sx sy |
	<var: #aComponent type: 'int *'>
	<var: #aBlockArray type: 'int **'>
	<inline: true>
	dx := curX := aComponent at: CurrentXIndex.
	dy := aComponent at: CurrentYIndex.
	sx := aComponent at: HScaleIndex.
	sy := aComponent at: VScaleIndex.
	(sx = 0 and:[sy = 0]) ifFalse:[
		dx := dx // sx.
		dy := dy // sy.
	].
	blockIndex := (dy bitShift: -3) * (aComponent at: BlockWidthIndex) + (dx bitShift: -3).
	sampleIndex := ((dy bitAnd: 7) bitShift: 3) + (dx bitAnd: 7).
	sample := (aBlockArray at: blockIndex) at: sampleIndex.
	curX := curX + 1.
	curX < ((aComponent at: MCUWidthIndex) * 8) ifTrue:[
		aComponent at: CurrentXIndex put: curX.
	] ifFalse:[
		aComponent at: CurrentXIndex put: 0.
		aComponent at: CurrentYIndex put: (aComponent at: CurrentYIndex) + 1.
	].
	^ sample! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:10'!
nextSampleY
	| dx dy blockIndex sampleIndex sample curX sx sy |
	<inline: true>
	dx := curX := yComponent at: CurrentXIndex.
	dy := yComponent at: CurrentYIndex.
	sx := yComponent at: HScaleIndex.
	sy := yComponent at: VScaleIndex.
	(sx = 0 and:[sy = 0]) ifFalse:[
		dx := dx // sx.
		dy := dy // sy.
	].
	blockIndex := (dy bitShift: -3) * (yComponent at: BlockWidthIndex) + (dx bitShift: -3).
	sampleIndex := ((dy bitAnd: 7) bitShift: 3) + (dx bitAnd: 7).
	sample := (yBlocks at: blockIndex) at: sampleIndex.
	curX := curX + 1.
	curX < ((yComponent at: MCUWidthIndex) * 8) ifTrue:[
		yComponent at: CurrentXIndex put: curX.
	] ifFalse:[
		yComponent at: CurrentXIndex put: 0.
		yComponent at: CurrentYIndex put: (yComponent at: CurrentYIndex) + 1.
	].
	^ sample! !
!JPEGReaderPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 3/4/2001 22:21'!
primitiveColorConvertGrayscaleMCU
	"Requires:
		JPEGColorComponent
		bits
		WordArray with: 3*Integer (residuals)
		ditherMask
	"
	| arrayOop |
	<export: true>
	self stInit.
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	ditherMask := interpreterProxy stackIntegerValue: 0.
	arrayOop := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: arrayOop) and:[(interpreterProxy slotSizeOf: arrayOop) = 3])
		ifFalse:[^interpreterProxy primitiveFail].
	residuals := interpreterProxy firstIndexableField: arrayOop.
	arrayOop := interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: arrayOop)
		ifFalse:[^interpreterProxy primitiveFail].
	jpegBitsSize := interpreterProxy slotSizeOf: arrayOop.
	jpegBits := interpreterProxy firstIndexableField: arrayOop.
	arrayOop := interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	(self yColorComponentFrom: arrayOop)
		ifFalse:[^interpreterProxy primitiveFail].
	self colorConvertGrayscaleMCU.
	interpreterProxy pop: 4.! !
!JPEGReaderPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:13'!
primitiveColorConvertMCU
	"Requires:
		Array with: 3*JPEGColorComponent
		bits
		WordArray with: 3*Integer (residuals)
		ditherMask
	"
	| arrayOop |
	<export: true>
	self stInit.
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	ditherMask := interpreterProxy stackIntegerValue: 0.
	arrayOop := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: arrayOop) and:[(interpreterProxy slotSizeOf: arrayOop) = 3])
		ifFalse:[^interpreterProxy primitiveFail].
	residuals := interpreterProxy firstIndexableField: arrayOop.
	arrayOop := interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: arrayOop)
		ifFalse:[^interpreterProxy primitiveFail].
	jpegBitsSize := interpreterProxy slotSizeOf: arrayOop.
	jpegBits := interpreterProxy firstIndexableField: arrayOop.
	arrayOop := interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isPointers: arrayOop) and:[(interpreterProxy slotSizeOf: arrayOop) = 3])
		ifFalse:[^interpreterProxy primitiveFail].
	(self yColorComponentFrom: (interpreterProxy fetchPointer: 0 ofObject: arrayOop))
		ifFalse:[^interpreterProxy primitiveFail].
	(self cbColorComponentFrom: (interpreterProxy fetchPointer: 1 ofObject: arrayOop))
		ifFalse:[^interpreterProxy primitiveFail].
	(self crColorComponentFrom: (interpreterProxy fetchPointer: 2 ofObject: arrayOop))
		ifFalse:[^interpreterProxy primitiveFail].
	self colorConvertMCU.
	interpreterProxy pop: 4.! !
!JPEGReaderPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:21'!
primitiveDecodeMCU
	"In:
		anArray 		WordArray of: DCTSize2
		aColorComponent JPEGColorComponent
		dcTable			WordArray
		acTable			WordArray
		stream			JPEGStream
	"
	| arrayOop oop anArray |
	<export: true>
	<var: #anArray type: 'int *'>
	self cCode:'' inSmalltalk:[self stInit].

	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	oop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self loadJPEGStreamFrom: oop)
		ifFalse:[^interpreterProxy primitiveFail].

	arrayOop := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: arrayOop)
		ifFalse:[^interpreterProxy primitiveFail].
	acTableSize := interpreterProxy slotSizeOf: arrayOop.
	acTable := interpreterProxy firstIndexableField: arrayOop.

	arrayOop := interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: arrayOop)
		ifFalse:[^interpreterProxy primitiveFail].
	dcTableSize := interpreterProxy slotSizeOf: arrayOop.
	dcTable := interpreterProxy firstIndexableField: arrayOop.

	oop := interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	(self colorComponent: yComponent from: oop)
		ifFalse:[^interpreterProxy primitiveFail].

	arrayOop := interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: arrayOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: arrayOop) = DCTSize2
		ifFalse:[^interpreterProxy primitiveFail].
	anArray := interpreterProxy firstIndexableField: arrayOop.

	interpreterProxy failed ifTrue:[^nil].

	self decodeBlockInto: anArray component: yComponent.

	interpreterProxy failed ifTrue:[^nil].
	self storeJPEGStreamOn: (interpreterProxy stackValue: 0).
	interpreterProxy 
		storeInteger: PriorDCValueIndex 
		ofObject: (interpreterProxy stackValue: 3) 
		withValue: (yComponent at: PriorDCValueIndex).

	interpreterProxy pop: 5.! !
!JPEGReaderPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 3/4/2001 21:14'!
primitiveIdctInt
	"In:
		anArray: IntegerArray new: DCTSize2
		qt: IntegerArray new: DCTSize2.
	"
	| arrayOop anArray qt |
	<export: true>
	<var: #anArray type: 'int *'>
	<var: #qt type: 'int *'>
	self cCode:'' inSmalltalk:[self stInit].
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	arrayOop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: arrayOop) and:[(interpreterProxy slotSizeOf: arrayOop) = DCTSize2])
		ifFalse:[^interpreterProxy primitiveFail].
	qt := interpreterProxy firstIndexableField: arrayOop.
	arrayOop := interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: arrayOop) and:[(interpreterProxy slotSizeOf: arrayOop) = DCTSize2])
		ifFalse:[^interpreterProxy primitiveFail].
	anArray := interpreterProxy firstIndexableField: arrayOop.
	self idctBlockInt: anArray qt: qt.
	interpreterProxy pop: 2.! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar (auto pragmas 12/08) 3/4/2001 17:16'!
scaleAndSignExtend: aNumber inFieldWidth: w
	<inline: true>
	aNumber < (1 bitShift: (w - 1))
		ifTrue: [^aNumber - (1 bitShift: w) + 1]
		ifFalse: [^aNumber]! !
!JPEGReaderPlugin methodsFor: 'initialize' stamp: 'ar 3/4/2001 21:10'!
stInit
	self cCode:'' inSmalltalk:[
		yComponent := CArrayAccessor on: (IntegerArray new: MinComponentSize).
		cbComponent := CArrayAccessor on: (IntegerArray new: MinComponentSize).
		crComponent := CArrayAccessor on: (IntegerArray new: MinComponentSize).
		yBlocks := CArrayAccessor on: (Array new: MaxMCUBlocks).
		crBlocks := CArrayAccessor on: (Array new: MaxMCUBlocks).
		cbBlocks := CArrayAccessor on: (Array new: MaxMCUBlocks).
		jpegNaturalOrder := CArrayAccessor on: #(
			0 1 8 16 9 2 3 10 
			17 24 32 25 18 11 4 5 
			12 19 26 33 40 48 41 34 
			27 20 13 6 7 14 21 28 
			35 42 49 56 57 50 43 36 
			29 22 15 23 30 37 44 51 
			58 59 52 45 38 31 39 46 
			53 60 61 54 47 55 62 63).
	].! !
!JPEGReaderPlugin methodsFor: 'stream support' stamp: 'ar 3/4/2001 19:04'!
storeJPEGStreamOn: streamOop
	interpreterProxy storeInteger: 1 ofObject: streamOop withValue: jsPosition.
	interpreterProxy storeInteger: 3 ofObject: streamOop withValue: jsBitBuffer.
	interpreterProxy storeInteger: 4 ofObject: streamOop withValue: jsBitCount.! !
!JPEGReaderPlugin methodsFor: 'decoding' stamp: 'ar 3/4/2001 21:10'!
yColorComponentFrom: oop
	^(self colorComponent: yComponent from: oop)
		and:[self colorComponentBlocks: yBlocks from: oop]! !

InterpreterPlugin subclass: #Matrix2x3Plugin
	instanceVariableNames: 'm23ResultX m23ResultY m23ArgX m23ArgY'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!Matrix2x3Plugin class methodsFor: 'class initialization' stamp: 'sma 3/3/2000 12:39'!
declareCVarsIn: cg 
	cg var: #m23ResultX type: #double.
	cg var: #m23ResultY type: #double.
	cg var: #m23ArgX type: #double.
	cg var: #m23ArgY type: #double! !
!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar (auto pragmas dtl 2010-09-28) 11/9/1998 15:17'!
loadArgumentMatrix: matrix
	"Load the argument matrix"
	<returnTypeC: 'float *'>
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: matrix) and:[(interpreterProxy slotSizeOf: matrix) = 6]) 
		ifFalse:[interpreterProxy primitiveFail.
				^nil].
	^self cCoerce: (interpreterProxy firstIndexableField: matrix) to:'float *'.! !
!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar 11/9/1998 16:17'!
loadArgumentPoint: point
	"Load the argument point into m23ArgX and m23ArgY"
	| oop isInt |
	interpreterProxy failed ifTrue:[^nil].
	"Check class of point"
	(interpreterProxy fetchClassOf: point) = (interpreterProxy classPoint) 
		ifFalse:[^interpreterProxy primitiveFail].
	"Load X value"
	oop := interpreterProxy fetchPointer: 0 ofObject: point.
	isInt := interpreterProxy isIntegerObject: oop.
	(isInt or:[interpreterProxy isFloatObject: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	isInt
		ifTrue:[m23ArgX := interpreterProxy integerValueOf: oop]
		ifFalse:[m23ArgX := interpreterProxy floatValueOf: oop].

	"Load Y value"
	oop := interpreterProxy fetchPointer: 1 ofObject: point.
	isInt := interpreterProxy isIntegerObject: oop.
	(isInt or:[interpreterProxy isFloatObject: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	isInt
		ifTrue:[m23ArgY := interpreterProxy integerValueOf: oop]
		ifFalse:[m23ArgY := interpreterProxy floatValueOf: oop].

! !
!Matrix2x3Plugin methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:02'!
matrix2x3ComposeMatrix: m1 with: m2 into: m3
	"Multiply matrix m1 with m2 and store the result into m3."
	| a11 a12 a13 a21 a22 a23 |
	<var: #m1 type: 'const float *'>
	<var: #m2 type: 'const float *'>
	<var: #m3 type: 'float *'>
	<var: #a11 type: 'double '>
	<var: #a12 type: 'double '>
	<var: #a13 type: 'double '>
	<var: #a21 type: 'double '>
	<var: #a22 type: 'double '>
	<var: #a23 type: 'double '>

	a11 := ((m1 at: 0) * (m2 at: 0)) + ((m1 at: 1) * (m2 at: 3)).
	a12 := ((m1 at: 0) * (m2 at: 1)) + ((m1 at: 1) * (m2 at: 4)).
	a13 := ((m1 at: 0) * (m2 at: 2)) + ((m1 at: 1) * (m2 at: 5)) + (m1 at: 2).
	a21 := ((m1 at: 3) * (m2 at: 0)) + ((m1 at: 4) * (m2 at: 3)).
	a22 := ((m1 at: 3) * (m2 at: 1)) + ((m1 at: 4) * (m2 at: 4)).
	a23 := ((m1 at: 3) * (m2 at: 2)) + ((m1 at: 4) * (m2 at: 5)) + (m1 at: 5).

	m3 at: 0 put: (self cCoerce: a11 to: 'float').
	m3 at: 1 put: (self cCoerce: a12 to: 'float').
	m3 at: 2 put: (self cCoerce: a13 to: 'float').
	m3 at: 3 put: (self cCoerce: a21 to: 'float').
	m3 at: 4 put: (self cCoerce: a22 to: 'float').
	m3 at: 5 put: (self cCoerce: a23 to: 'float').
! !
!Matrix2x3Plugin methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:02'!
matrix2x3InvertPoint: m
	"Invert the pre-loaded argument point by the given matrix"
	| x y det detX detY |
	<var: #m type: 'float *'>
	<var: #x type: 'double '>
	<var: #y type: 'double '>
	<var: #det type: 'double '>
	<var: #detX type: 'double '>
	<var: #detY type: 'double '>

	x := m23ArgX - (m at: 2).
	y := m23ArgY - (m at: 5).
	det := ((m at: 0) * (m at: 4)) - ((m at: 1) * (m at: 3)).
	det = 0.0 ifTrue:[^interpreterProxy primitiveFail]."Matrix is singular."
	det := 1.0 / det.
	detX := (x * (m at: 4)) - ((m at: 1) * y).
	detY := ((m at: 0) * y) - (x * (m at: 3)).
	m23ResultX := detX * det.
	m23ResultY := detY * det.! !
!Matrix2x3Plugin methodsFor: 'transforming' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:03'!
matrix2x3TransformPoint: m
	"Transform the pre-loaded argument point by the given matrix"
	<var: #m type: 'float *'>
	m23ResultX := (m23ArgX * (m at: 0)) + (m23ArgY * (m at: 1)) + (m at: 2).
	m23ResultY := (m23ArgX * (m at: 3)) + (m23ArgY * (m at: 4)) + (m at: 5).! !
!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar 11/14/1998 02:37'!
okayIntValue: value
	^(value >= -1073741824 asFloat and:[m23ResultX <= 1073741823 asFloat]) 
! !
!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'dtl 10/14/2010 23:23'!
primitiveComposeMatrix
	| m1 m2 m3 result |
	<export: true>
	<inline: false>
	<var: #m1 type: #'float *'>
	<var: #m2 type: #'float *'>
	<var: #m3 type: #'float *'>
	self cCode: ''  "Make this fail in simulation"
		inSmalltalk: [interpreterProxy success: false. ^ nil].
	m3 := self loadArgumentMatrix: (result := interpreterProxy stackObjectValue: 0).
	m2 := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 1).
	m1 := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 2).
	interpreterProxy failed ifTrue:[^nil].
	self matrix2x3ComposeMatrix: m1 with: m2 into: m3.
	interpreterProxy pop: 3 thenPush: result! !
!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:03'!
primitiveInvertPoint
	| matrix |
	<export: true>
	<inline: false>
	<var: #matrix type: 'float *'>
	self loadArgumentPoint: (interpreterProxy stackObjectValue: 0).
	matrix := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 1).
	interpreterProxy failed ifTrue:[^nil].
	self matrix2x3InvertPoint: matrix.
	interpreterProxy failed ifFalse:[self roundAndStoreResultPoint: 2].! !
!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'dtl 10/14/2010 23:25'!
primitiveInvertRectInto
	| matrix srcOop dstOop originX originY cornerX cornerY minX maxX minY maxY |
	<export: true>
	<inline: false>
	<var: #matrix type: 'float *'>
	<var: #originX type: 'double '>
	<var: #originY type: 'double '>
	<var: #cornerX type: 'double '>
	<var: #cornerY type: 'double '>
	<var: #minX type: 'double '>
	<var: #maxX type: 'double '>
	<var: #minY type: 'double '>
	<var: #maxY type: 'double '>

	dstOop := interpreterProxy stackObjectValue: 0.
	srcOop := interpreterProxy stackObjectValue: 1.
	matrix := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 2).
	interpreterProxy failed ifTrue:[^nil].

	(interpreterProxy fetchClassOf: srcOop) = (interpreterProxy fetchClassOf: dstOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isPointers: srcOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: srcOop) = 2
		ifFalse:[^interpreterProxy primitiveFail].

	"Load top-left point"
	self loadArgumentPoint: (interpreterProxy fetchPointer: 0 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	originX := m23ArgX.
	originY := m23ArgY.
	self matrix2x3InvertPoint: matrix.
	minX := maxX := m23ResultX.
	minY := maxY := m23ResultY.

	"Load bottom-right point"
	self loadArgumentPoint:(interpreterProxy fetchPointer: 1 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	cornerX := m23ArgX.
	cornerY := m23ArgY.
	self matrix2x3InvertPoint: matrix.
	minX := minX min: m23ResultX.
	maxX := maxX max: m23ResultX.
	minY := minY min: m23ResultY.
	maxY := maxY max: m23ResultY.

	"Load top-right point"
	m23ArgX := cornerX.
	m23ArgY := originY.
	self matrix2x3InvertPoint: matrix.
	minX := minX min: m23ResultX.
	maxX := maxX max: m23ResultX.
	minY := minY min: m23ResultY.
	maxY := maxY max: m23ResultY.

	"Load bottom-left point"
	m23ArgX := originX.
	m23ArgY := cornerY.
	self matrix2x3InvertPoint: matrix.
	minX := minX min: m23ResultX.
	maxX := maxX max: m23ResultX.
	minY := minY min: m23ResultY.
	maxY := maxY max: m23ResultY.

	interpreterProxy failed ifFalse:[
		dstOop := self roundAndStoreResultRect: dstOop x0: minX y0: minY x1: maxX y1: maxY].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 3 thenPush: dstOop
	]
! !
!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:03'!
primitiveIsIdentity
	| matrix |
	<export: true>
	<inline: false>
	<var: #matrix type: 'float *'>
	matrix := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 0).
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: 1.
	interpreterProxy pushBool:(
		((matrix at: 0) = (self cCoerce: 1.0 to: 'float')) &
		((matrix at: 1) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 2) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 3) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 4) = (self cCoerce: 1.0 to: 'float')) &
		((matrix at: 5) = (self cCoerce: 0.0 to: 'float'))).! !
!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:04'!
primitiveIsPureTranslation
	| matrix |
	<export: true>
	<inline: false>
	<var: #matrix type: 'float *'>
	matrix := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 0).
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: 1.
	interpreterProxy pushBool:(
		((matrix at: 0) = (self cCoerce: 1.0 to: 'float')) &
		((matrix at: 1) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 3) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 4) = (self cCoerce: 1.0 to: 'float'))).! !
!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:04'!
primitiveTransformPoint
	| matrix |
	<export: true>
	<inline: false>
	<var: #matrix type: 'float *'>
	self loadArgumentPoint: (interpreterProxy stackObjectValue: 0).
	matrix := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 1).
	interpreterProxy failed ifTrue:[^nil].
	self matrix2x3TransformPoint: matrix.
	self roundAndStoreResultPoint: 2.! !
!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'dtl 10/14/2010 23:27'!
primitiveTransformRectInto
	| matrix srcOop dstOop originX originY cornerX cornerY minX maxX minY maxY |
	<export: true>
	<inline: false>
	<var: #matrix type: 'float *'>
	<var: #originX type: 'double '>
	<var: #originY type: 'double '>
	<var: #cornerX type: 'double '>
	<var: #cornerY type: 'double '>
	<var: #minX type: 'double '>
	<var: #maxX type: 'double '>
	<var: #minY type: 'double '>
	<var: #maxY type: 'double '>

	dstOop := interpreterProxy stackObjectValue: 0.
	srcOop := interpreterProxy stackObjectValue: 1.
	matrix := self loadArgumentMatrix: (interpreterProxy stackObjectValue: 2).
	interpreterProxy failed ifTrue:[^nil].

	(interpreterProxy fetchClassOf: srcOop) = (interpreterProxy fetchClassOf: dstOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isPointers: srcOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: srcOop) = 2
		ifFalse:[^interpreterProxy primitiveFail].

	"Load top-left point"
	self loadArgumentPoint: (interpreterProxy fetchPointer: 0 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	originX := m23ArgX.
	originY := m23ArgY.
	self matrix2x3TransformPoint: matrix.
	minX := maxX := m23ResultX.
	minY := maxY := m23ResultY.

	"Load bottom-right point"
	self loadArgumentPoint:(interpreterProxy fetchPointer: 1 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	cornerX := m23ArgX.
	cornerY := m23ArgY.
	self matrix2x3TransformPoint: matrix.
	minX := minX min: m23ResultX.
	maxX := maxX max: m23ResultX.
	minY := minY min: m23ResultY.
	maxY := maxY max: m23ResultY.

	"Load top-right point"
	m23ArgX := cornerX.
	m23ArgY := originY.
	self matrix2x3TransformPoint: matrix.
	minX := minX min: m23ResultX.
	maxX := maxX max: m23ResultX.
	minY := minY min: m23ResultY.
	maxY := maxY max: m23ResultY.

	"Load bottom-left point"
	m23ArgX := originX.
	m23ArgY := cornerY.
	self matrix2x3TransformPoint: matrix.
	minX := minX min: m23ResultX.
	maxX := maxX max: m23ResultX.
	minY := minY min: m23ResultY.
	maxY := maxY max: m23ResultY.

	dstOop := self roundAndStoreResultRect: dstOop x0: minX y0: minY x1: maxX y1: maxY.
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 3 thenPush: dstOop
	]
! !
!Matrix2x3Plugin methodsFor: 'private' stamp: 'eem 7/10/2010 21:38'!
roundAndStoreResultPoint: nItemsToPop
	"Store the result of a previous operation.
	Fail if we cannot represent the result as SmallInteger"
	m23ResultX := m23ResultX + 0.5.
	m23ResultY := m23ResultY + 0.5.
	(self okayIntValue: m23ResultX) ifFalse:[^interpreterProxy primitiveFail].
	(self okayIntValue: m23ResultY) ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: nItemsToPop thenPush:
		(interpreterProxy makePointwithxValue: m23ResultX asInteger
							yValue: m23ResultY asInteger)! !
!Matrix2x3Plugin methodsFor: 'private' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 17:04'!
roundAndStoreResultRect: dstOop x0: x0 y0: y0 x1: x1 y1: y1
	"Check, round and store the result of a rectangle operation"
	| minX maxX minY maxY originOop cornerOop rectOop |
	<var: #x0 type: 'double '>
	<var: #y0 type: 'double '>
	<var: #x1 type: 'double '>
	<var: #y1 type: 'double '>
	<var: #minX type: 'double '>
	<var: #maxX type: 'double '>
	<var: #minY type: 'double '>
	<var: #maxY type: 'double '>

	minX := x0 + 0.5.
	(self okayIntValue: minX) ifFalse:[^interpreterProxy primitiveFail].
	maxX := x1 + 0.5.
	(self okayIntValue: maxX) ifFalse:[^interpreterProxy primitiveFail].
	minY := y0 + 0.5.
	(self okayIntValue: minY) ifFalse:[^interpreterProxy primitiveFail].
	maxY := y1 + 0.5.
	(self okayIntValue: maxY) ifFalse:[^interpreterProxy primitiveFail].

	interpreterProxy pushRemappableOop: dstOop.
	originOop := interpreterProxy makePointwithxValue: minX asInteger yValue: minY asInteger.
	interpreterProxy pushRemappableOop: originOop.
	cornerOop := interpreterProxy makePointwithxValue: maxX asInteger yValue: maxY asInteger.
	originOop := interpreterProxy popRemappableOop.
	rectOop := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: rectOop withValue: originOop.
	interpreterProxy storePointer: 1 ofObject: rectOop withValue: cornerOop.
	^rectOop! !

InterpreterPlugin subclass: #MiscPrimitivePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!MiscPrimitivePlugin commentStamp: 'dtl 12/2/2009 11:28' prior: 0!
This plugin pulls together a number of translatable methods with no particularly meaningful home. See class>translatedPrimitives for the list.

The primitives in this plugin consist of various methods in the image that can benefit greatly from translation to C, but that do not inherently require translation. These may be thought of not as traditional primitives, but as methods that have been annotated for translation to C by this plugin. This approach allows performance critical methods to be written entirely in Smalltalk, then marked for translation as needed to achieve improved performance.!
!MiscPrimitivePlugin class methodsFor: 'translation' stamp: 'tpr 4/9/2002 16:15'!
translateInDirectory: directory doInlining: inlineFlag
"handle a special case code string rather than normal generated code."
	| cg fname fstat |
	 fname := self moduleName, '.c'.

	"don't translate if the file is newer than my timeStamp"
	fstat := directory entryAt: fname ifAbsent:[nil].
	fstat ifNotNil:[self timeStamp < fstat modificationTime ifTrue:[^nil]].

	self initialize.
	cg := self buildCodeGeneratorUpTo: InterpreterPlugin.
	cg addMethodsForPrimitives: self translatedPrimitives.
	self storeString: cg generateCodeStringForPrimitives onFileNamed: (directory fullNameFor: fname).
	^cg exportedPrimitiveNames asArray
! !
!MiscPrimitivePlugin class methodsFor: 'translation' stamp: 'eem 5/24/2010 09:15'!
translatedPrimitives
	"an assorted list of various primitives"
	^#(
		(Bitmap compress:toByteArray:)
		(Bitmap decompress:fromByteArray:at:)
		(Bitmap encodeBytesOf:in:at:)
		(Bitmap encodeInt:in:at:)
		(ByteString compare:with:collated:)
		(ByteString translate:from:to:table:)	
		(ByteString findFirstInString:inSet:startingAt:)
		(ByteString indexOfAscii:inString:startingAt:)
		(ByteString findSubstring:in:startingAt:matchTable:)
		(ByteArray hashBytes:startingWith:)
		(SampledSound convert8bitSignedFrom:to16Bit:)
	)

	"| tps |
	'This opens a list browser on all translated primitives in the image'.
	 tps := (SystemNavigation default allImplementorsOf: #translatedPrimitives)
				inject: Set new
				into: [:tp :mr|
					tp addAll: (mr actualClass theNonMetaClass translatedPrimitives collect:
								[:pair|
								MethodReference
									class: (((Smalltalk at: pair first) canUnderstand: pair last)
												ifTrue: [Smalltalk at: pair first]
												ifFalse: [(Smalltalk at: pair first) class])
									selector: pair last]);
						yourself].
	SystemNavigation default browseMessageList: tps asArray sort name: 'Translated Primitives' "! !

InterpreterPlugin subclass: #SecurityPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!SecurityPlugin commentStamp: 'tpr 5/5/2003 12:19' prior: 0!
IMPLEMENTATION NOTES:
The support should assume a trusted directory based on which access to files is granted when running in restricted mode. If necessary, links need to be resolved before granting access (currently, this applies only to platforms on which links can be created by simply creating the right kind of file).

The untrusted user directory returned MUST be different from the image and VM location. Otherwise a Badlet could attempt to overwrite these by using simple file primitives. The secure directory location returned by the primitive is a place to store per-user security information. Again, this place needs to be outside the untrusted space. Examples:

[Windows]
	* VM+image location: "C:\Program Files\Squeak\"
	* secure directory location: "C:\Program Files\Squeak\username\"
	* untrusted user directory: "C:\My Squeak\username\"
[Unix]
	* VM+image location: "/user/local/squeak"
	* secure directory location: "~username/.squeak/
	* untrusted user directory: "~username/squeak/"
[Mac]
	* plugin VM location: "MacHD:Netscape:Plugins:"
	* standalone VM and image location: "MacHD:Squeak:"
	* secure directory location: "MacHD:Squeak:username:"
	* untrusted user directory: "MacHD:My Squeak:username:"

Restoring the rights revoked by an image might be possible by some interaction with the VM directly. Any such action should be preceeded by a BIG FAT WARNING - the average user will never need that ability (if she does, we did something wrong) so this is a last resort in cases where something fundamtally tricky happened.
!
!SecurityPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:10'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!SecurityPlugin class methodsFor: 'translation' stamp: 'tpr 3/20/2001 12:33'!
requiresPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^true! !
!SecurityPlugin methodsFor: 'initialize' stamp: 'JMM (auto pragmas 12/08) 8/15/2001 11:59'!
initialiseModule
	<export: true>
	^self cCode: 'ioInitSecurity()' inSmalltalk:[true]! !
!SecurityPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 7/24/2003 12:54'!
primitiveCanWriteImage
	<export: true>
	interpreterProxy pop: 1.
	interpreterProxy pushBool: (self cCode:'ioCanWriteImage()' inSmalltalk:[true])! !
!SecurityPlugin methodsFor: 'primitives' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-28) 5/5/2009 10:59'!
primitiveDisableImageWrite
	<export: true>
	self cCode:'ioDisableImageWrite()'.
! !
!SecurityPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:51'!
primitiveGetSecureUserDirectory
	"Primitive. Return the secure directory for the current user."
	| dirName dirLen dirOop dirPtr |
	<export: true>
	<var: #dirName type: 'char *'>
	<var: #dirPtr type: 'char *'>
	dirName := self cCode: 'ioGetSecureUserDirectory()' inSmalltalk: [nil].
	(dirName == nil or:[interpreterProxy failed]) 
		ifTrue:[^interpreterProxy primitiveFail].
	dirLen := self strlen: dirName.
	dirOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: dirLen.
	interpreterProxy failed ifTrue:[^nil].
	dirPtr := interpreterProxy firstIndexableField: dirOop.
	0 to: dirLen-1 do:[:i|
		dirPtr at: i put: (dirName at: i)].
	interpreterProxy pop: 1 thenPush: dirOop.! !
!SecurityPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:52'!
primitiveGetUntrustedUserDirectory
	"Primitive. Return the untrusted user directory name."
	| dirName dirLen dirOop dirPtr |
	<export: true>
	<var: #dirName type: 'char *'>
	<var: #dirPtr type: 'char *'>
	dirName := self cCode:'ioGetUntrustedUserDirectory()' inSmalltalk:[nil].
	(dirName == nil or:[interpreterProxy failed]) 
		ifTrue:[^interpreterProxy primitiveFail].
	dirLen := self strlen: dirName.
	dirOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: dirLen.
	interpreterProxy failed ifTrue:[^nil].
	dirPtr := interpreterProxy firstIndexableField: dirOop.
	0 to: dirLen-1 do:[:i|
		dirPtr at: i put: (dirName at: i)].
	interpreterProxy pop: 1 thenPush: dirOop.! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCan: socket ListenOnPort: port
	<export: true>
	^self cCode: 'ioCanListenOnPort(socket, port)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanConnect: addr ToPort: port
	<export: true>
	^self cCode: 'ioCanConnectToPort(addr, port)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanCreate: netType SocketOfType: socketType
	<export: true>
	^self cCode: 'ioCanCreateSocketOfType(netType, socketType)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanCreatePath: dirName OfSize: dirNameSize
	<export: true>
	<var: #dirName type: 'char *'>
	^self cCode: 'ioCanCreatePathOfSize(dirName, dirNameSize)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanDeleteFile: fileName OfSize: fileNameSize
	<export: true>
	<var: #fileName type: 'char *'>
	^self cCode: 'ioCanDeleteFileOfSize(fileName, fileNameSize)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanDeletePath: dirName OfSize: dirNameSize
	<export: true>
	<var: #dirName type: 'char *'>
	^self cCode: 'ioCanDeletePathOfSize(dirName, dirNameSize)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanGetFileType: fileName OfSize: fileNameSize
	<export: true>
	<var: #fileName type: 'char *'>
	^self cCode: 'ioCanGetFileTypeOfSize(fileName, fileNameSize)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanListPath: pathName OfSize: pathNameSize
	<export: true>
	<var: #pathName type: 'char *'>
	^self cCode: 'ioCanListPathOfSize(pathName, pathNameSize)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanOpenAsyncFile: fileName OfSize: fileNameSize Writable: writeFlag
	<export: true>
	<var: #fileName type: 'char *'>
	^self cCode: 'ioCanOpenAsyncFileOfSizeWritable(fileName, fileNameSize, writeFlag)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanOpenFile: fileName OfSize: fileNameSize Writable: writeFlag
	<export: true>
	<var: #fileName type: 'char *'>
	^self cCode: 'ioCanOpenFileOfSizeWritable(fileName, fileNameSize, writeFlag)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanRenameFile: fileName OfSize: fileNameSize
	<export: true>
	<var: #fileName type: 'char *'>
	^self cCode: 'ioCanRenameFileOfSize(fileName, fileNameSize)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanRenameImage
	<export: true>
	^self cCode: 'ioCanRenameImage()'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanSetFileType: fileName OfSize: fileNameSize
	<export: true>
	<var: #fileName type: 'char *'>
	^self cCode: 'ioCanSetFileTypeOfSize(fileName, fileNameSize)'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secCanWriteImage
	<export: true>
	^self cCode: 'ioCanWriteImage()'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secDisableFileAccess
	<export: true>
	^self cCode: 'ioDisableFileAccess()'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secDisableSocketAccess
	<export: true>
	^self cCode: 'ioDisableSocketAccess()'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secHasFileAccess
	<export: true>
	^self cCode: 'ioHasFileAccess()'! !
!SecurityPlugin methodsFor: 'exported functions' stamp: '(auto pragmas 12/08) '!
secHasSocketAccess
	<export: true>
	^self cCode: 'ioHasSocketAccess()'! !

InterpreterPlugin subclass: #SlangTestSupportPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Tests'!
!SlangTestSupportPlugin commentStamp: 'dtl 9/19/2010 21:36' prior: 0!
SlangTestSupport implements translatable methods for use in SlangTest unit tests.
This is a subclass of InterpreterPlugin, which provides coverage of slang translation
for base plugins.

	"VMMaker clearCacheEntriesFor: SlangTestSupportPlugin.
	SlangTestSupportPlugin asCString"!
!SlangTestSupportPlugin methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:29'!
declareExportFalseByMethod
	"SlangTestSupport asCString: #declareExportFalseByMethod"

	self export: false
! !
!SlangTestSupportPlugin methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:29'!
declareExportFalseByPragma
	"SlangTestSupport asCString: #declareExportFalseByPragma"

	<export: false>
! !
!SlangTestSupportPlugin methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:21'!
declareExportTrueByMethod
	"SlangTestSupport asCString: #declareExportTrueByMethod"

	self export: true
! !
!SlangTestSupportPlugin methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:21'!
declareExportTrueByPragma
	"SlangTestSupport asCString: #declareExportTrueByPragma"

	<export: true>
! !
!SlangTestSupportPlugin methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:29'!
declareStaticFalseByMethod
	"SlangTestSupport asCString: #declareStaticFalseByMethod"

	self static: false
! !
!SlangTestSupportPlugin methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:30'!
declareStaticFalseByPragma
	"SlangTestSupport asCString: #declareStaticFalseByPragma"

	<static: false>
! !
!SlangTestSupportPlugin methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:29'!
declareStaticTrueByMethod
	"SlangTestSupport asCString: #declareStaticTrueByMethod"

	self static: true
! !
!SlangTestSupportPlugin methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:30'!
declareStaticTrueByPragma
	"SlangTestSupport asCString: #declareStaticTrueByPragma"

	<static: true>
! !
!SlangTestSupportPlugin methodsFor: 'inlining' stamp: 'dtl 9/19/2010 11:50'!
inlineByMethod
	"SlangTestSupport asCString: #inlineByMethod"
	"SlangTestSupport asInlinedCString: #inlineByMethod"

	| bar foo |
	foo := self methodThatShouldBeInlinedByMethod.
	bar := self methodThatShouldNotBeInlinedByMethod! !
!SlangTestSupportPlugin methodsFor: 'inlining' stamp: 'dtl 9/19/2010 11:50'!
inlineByPragma
	"SlangTestSupport asCString: #inlineByPragma"
	"SlangTestSupport asInlinedCString: #inlineByPragma"

	| bar foo |
	foo := self methodThatShouldBeInlinedByPragma.
	bar := self methodThatShouldNotBeInlinedByPragma! !
!SlangTestSupportPlugin methodsFor: 'inlining' stamp: 'dtl 9/18/2010 17:59'!
methodThatShouldBeInlinedByMethod

	self inline: true.
	^ #foo! !
!SlangTestSupportPlugin methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldBeInlinedByPragma

	<inline: true>
	^ #foo! !
!SlangTestSupportPlugin methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldNotBeInlinedByMethod

	self inline: false.
	^ #bar! !
!SlangTestSupportPlugin methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldNotBeInlinedByPragma

	<inline: false>
	^ #bar! !
!SlangTestSupportPlugin methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:50'!
returnTypeByMethod
	"SlangTestSupport asCString: #returnTypeByMethod"

	self returnTypeC: 'char *'.
! !
!SlangTestSupportPlugin methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:51'!
returnTypeByPragma
	"SlangTestSupport asCString: #returnTypeByPragma"

	<returnTypeC: 'char *'>
! !
!SlangTestSupportPlugin methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:51'!
varDefByMethod
	"SlangTestSupport asCString: #varDefByMethod"

	| foo bar |
	self var: #foo type: 'char *'.
	self var: #bar declareC: 'unsigned int * bar'
! !
!SlangTestSupportPlugin methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 22:25'!
varDefByMethodAndPragma
	"SlangTestSupportPlugin asCString: #varDefByMethodAndPragma"

	| foo bar baz fum |
	<var: #baz type: 'float'>
	<var: #fum declareC: 'double fum'>
	self var: #foo type: 'char *'.
	self var: #bar declareC: 'unsigned int * bar'
! !
!SlangTestSupportPlugin methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 12:05'!
varDefByPragma
	"SlangTestSupport asCString: #varDefByPragma"

	| foo bar |
	<var: #foo type: 'char *'>
	<var: #bar declareC: 'unsigned int * bar'>
! !

InterpreterPlugin subclass: #SmartSyntaxInterpreterPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-SmartSyntaxPlugins'!
!SmartSyntaxInterpreterPlugin commentStamp: '<historical>' prior: 0!
Subclass of InterpreterPlugin, used in connection with TestCodeGenerator for named primitives with type coercion specifications!

SmartSyntaxInterpreterPlugin subclass: #AsynchFilePlugin
	instanceVariableNames: 'sCOAFfn'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!AsynchFilePlugin commentStamp: 'tpr 5/2/2003 15:22' prior: 0!
Implements the asynchronous file primitives available on a few platforms. See the platform specific files in platforms- {your platform} - plugins - Asynchplugin!
!AsynchFilePlugin class methodsFor: 'translation' stamp: 'JMM 5/23/2005 18:59'!
declareCVarsIn: cg
	super declareCVarsIn: cg.
	cg var: #sCOAFfn type: #'void *'.
! !
!AsynchFilePlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:04'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!AsynchFilePlugin class methodsFor: 'translation' stamp: 'tpr 11/29/2000 22:37'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'TPR (auto pragmas 12/08) 2/7/2000 13:01'!
asyncFileValueOf: oop
	"Return a pointer to the first byte of the async file record within the given Smalltalk bytes object, or nil if oop is not an async file record."

	<returnTypeC: 'AsyncFile *'>
	interpreterProxy success:
		((interpreterProxy isIntegerObject: oop) not and:
		 [(interpreterProxy isBytes: oop) and:
		 [(interpreterProxy slotSizeOf: oop) = (self cCode: 'sizeof(AsyncFile)')]]).
	interpreterProxy failed ifTrue: [^ nil].
	^ self cCode: '(AsyncFile *) (oop + 4)'
! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'dtl (auto pragmas dtl 2010-09-27) 6/30/2008 08:16'!
bufferPointer: buffer startIndex: startIndex
 	"Adjust for zero-origin indexing. This is implemented as a separate method in order
	to encourage inlining."

	<inline: true>
	<returnTypeC: 'char *'>
	^ (self pointerForOop: buffer) + self baseHeaderSize + startIndex - 1.
! !
!AsynchFilePlugin methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 1/20/2002 22:00'!
initialiseModule
	"Initialise the module"
	<export: true>
	sCOAFfn := interpreterProxy ioLoadFunction: 'secCanOpenAsyncFileOfSizeWritable' From: 'SecurityPlugin'.
	^self cCode: 'asyncFileInit()' inSmalltalk:[true]! !
!AsynchFilePlugin methodsFor: 'initialize-release' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 14:51'!
moduleUnloaded: aModuleName 
	"The module with the given name was just unloaded. 
	Make sure we have no dangling references."
	<export: true>
	<var: #aModuleName type: 'char *'>
	(aModuleName strcmp: 'SecurityPlugin') = 0
		ifTrue: ["The security plugin just shut down. How odd. Zero the function pointer we have into it"
			sCOAFfn := 0]! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 14:15'!
primitiveAsyncFileClose: fh 
	| f |
	<var: #f type: 'AsyncFile *'>
	self primitive: 'primitiveAsyncFileClose' parameters: #(Oop ).
	f := self asyncFileValueOf: fh.
	self asyncFileClose: f! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-27) 12/1/2009 21:42'!
primitiveAsyncFileOpen: fileName forWrite: writeFlag semaIndex: semaIndex 
	| fileNameSize fOop f okToOpen |
	<var: #f type: 'AsyncFile *'>
	<var: #f type: 'AsyncFile *'>
	self primitive: 'primitiveAsyncFileOpen' parameters: #(#String #Boolean #SmallInteger ).
	fileNameSize := interpreterProxy slotSizeOf: (fileName asOop: String).
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCOAFfn ~= 0
		ifTrue: [okToOpen := self cCode: ' ((sqInt (*) (char *, sqInt, sqInt)) sCOAFfn)(fileName, fileNameSize, writeFlag)'.
			okToOpen ifFalse: [^ interpreterProxy primitiveFail]].
	fOop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: (self cCode: 'sizeof(AsyncFile)').
	f := self asyncFileValueOf: fOop.
	interpreterProxy failed ifFalse: [self cCode: 'asyncFileOpen(f, fileName, fileNameSize, writeFlag, semaIndex)'].
	^ fOop! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'dtl (auto pragmas dtl 2010-09-27) 5/31/2008 18:38'!
primitiveAsyncFileReadResult: fhandle intoBuffer: buffer at: start count: num 
	| bufferSize bufferPtr r f count startIndex |
	<var: #f type: 'AsyncFile *'>
	<var: #bufferPtr type: 'char *'>
	self primitive: 'primitiveAsyncFileReadResult' parameters: #(Oop Oop SmallInteger SmallInteger ).

	f := self asyncFileValueOf: fhandle.
	count := num.
	startIndex := start.
	bufferSize := interpreterProxy slotSizeOf: buffer. "in bytes or words"
	(interpreterProxy isWords: buffer)
		ifTrue: ["covert word counts to byte counts"
			count := count * 4.
			startIndex := startIndex - 1 * 4 + 1.
			bufferSize := bufferSize * 4].
	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= bufferSize]).
	bufferPtr := self bufferPointer: buffer startIndex: startIndex.
	interpreterProxy failed ifFalse: [r := self cCode: 'asyncFileReadResult(f, bufferPtr, count)'].
	^ r asOop: SmallInteger! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 14:16'!
primitiveAsyncFileReadStart: fHandle fPosition: fPosition count: count
	| f |
	<var: #f type: 'AsyncFile *'>
	self primitive: 'primitiveAsyncFileReadStart' parameters: #(Oop SmallInteger SmallInteger).
	f := self asyncFileValueOf: fHandle.
	self cCode: 'asyncFileReadStart(f, fPosition, count)'
! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 14:16'!
primitiveAsyncFileWriteResult: fHandle

	| f r |
	<var: #f type: 'AsyncFile *'>
	self primitive: 'primitiveAsyncFileWriteResult' parameters:#(Oop).

	f := self asyncFileValueOf: fHandle.
	r := self cCode:' asyncFileWriteResult(f)'.
	^r asOop: SmallInteger! !
!AsynchFilePlugin methodsFor: 'primitives' stamp: 'dtl (auto pragmas dtl 2010-09-27) 5/31/2008 18:38'!
primitiveAsyncFileWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: start count: num 
	| f bufferSize bufferPtr count startIndex |
	<var: #f type: 'AsyncFile *'>
	<var: #bufferPtr type: 'char *'>
	self primitive: 'primitiveAsyncFileWriteStart' parameters: #(Oop SmallInteger Oop SmallInteger SmallInteger ).
	f := self asyncFileValueOf: fHandle.
	interpreterProxy failed ifTrue: [^ nil].

	count := num.
	startIndex := start.
	bufferSize := interpreterProxy slotSizeOf: buffer.	"in bytes or words"
	(interpreterProxy isWords: buffer)
		ifTrue: ["convert word counts to byte counts"
			count := count * self bytesPerWord.
			startIndex := startIndex - 1 * self bytesPerWord + 1.
			bufferSize := bufferSize * self bytesPerWord].
	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= bufferSize]).
	bufferPtr := self bufferPointer: buffer startIndex: startIndex.
	interpreterProxy failed ifFalse: [self cCode: 'asyncFileWriteStart(f, fPosition, bufferPtr, count)']! !
!AsynchFilePlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:54'!
shutdownModule
	"Initialise the module"
	<export: true>
	^self cCode: 'asyncFileShutdown()' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #ClipboardExtendedPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!ClipboardExtendedPlugin methodsFor: 'io' stamp: 'JSM 5/8/2006 23:39'!
ioAddClipboardData: clipboard data: data dataFormat: aFormat
| clipboardAddress formatLength dataLength |
self primitive: 'ioAddClipboardData' parameters: #(Oop ByteArray String).

clipboardAddress := interpreterProxy positive32BitValueOf: clipboard.

dataLength := interpreterProxy slotSizeOf: data cPtrAsOop.
formatLength := interpreterProxy slotSizeOf: aFormat cPtrAsOop.

self sqPasteboardPutItemFlavor: clipboardAddress data: data length: dataLength formatType: aFormat formatLength: formatLength.
! !
!ClipboardExtendedPlugin methodsFor: 'io' stamp: 'JSM 5/6/2006 18:59'!
ioClearClipboard: clipboard
| clipboardAddress |
self primitive: 'ioClearClipboard' parameters: #(Oop).
clipboardAddress :=  interpreterProxy positive32BitValueOf: clipboard.
self sqPasteboardClear: clipboardAddress.! !
!ClipboardExtendedPlugin methodsFor: 'io' stamp: 'JSM 5/6/2006 19:23'!
ioCreateClipboard
| clipboardAddress |
self primitive: 'ioCreateClipboard' parameters: #().

clipboardAddress := interpreterProxy positive32BitIntegerFor: self sqCreateClipboard.

^ clipboardAddress.! !
!ClipboardExtendedPlugin methodsFor: 'io' stamp: 'JSM 5/9/2006 01:39'!
ioGetClipboardFormat: clipboard formatNumber: formatNumber 
	| clipboardAddress itemCount |
	self primitive: 'ioGetClipboardFormat' parameters: #(#Oop #SmallInteger ).
	clipboardAddress := interpreterProxy positive32BitValueOf: clipboard.
	itemCount := self sqPasteboardGetItemCount: clipboardAddress.
	itemCount > 0
		ifTrue: [^ self sqPasteboardCopyItemFlavors: clipboardAddress itemNumber: formatNumber].
	^ interpreterProxy nilObject! !
!ClipboardExtendedPlugin methodsFor: 'io' stamp: 'JSM 5/7/2006 13:07'!
ioReadClipboardData: clipboard format: format
| clipboardAddress formatLength |
self primitive: 'ioReadClipboardData' parameters: #(Oop String).
clipboardAddress := interpreterProxy positive32BitValueOf: clipboard.
formatLength := interpreterProxy slotSizeOf: format cPtrAsOop.
^ self sqPasteboardCopyItemFlavorData: clipboardAddress format: format formatLength: formatLength.
! !

SmartSyntaxInterpreterPlugin subclass: #FileCopyPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!FileCopyPlugin commentStamp: 'tpr 5/2/2003 15:48' prior: 0!
This plugin is a simple workaround for the lamentable state of the Squeak file handling system; it provides a primitive to copy a file or tree via the OS facility and thus preserve all the OS attributes in the most trivial possible manner. Not intended for a long life and should be replaced by better code as soon as possible. The key benefit it offers is maintenance of any OS flags, tags, bits and bobs belonging to the file.  Since it requires platform support it will only be built when supported on your platform!
!FileCopyPlugin class methodsFor: 'translation' stamp: 'tpr 4/27/2001 11:02'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!FileCopyPlugin methodsFor: 'system primitives' stamp: 'tpr 4/10/2002 19:34'!
primitiveFile: srcName copyTo: dstName

	|srcSz dstSz ok |
	self primitive: 'primitiveFileCopyNamedTo'
		parameters: #(String String).

	srcSz := interpreterProxy slotSizeOf: srcName cPtrAsOop.
	dstSz := interpreterProxy slotSizeOf: dstName cPtrAsOop.
	ok := self sqCopyFile: srcName size: srcSz to: dstName size: dstSz.
	ok ifFalse:[interpreterProxy primitiveFail].
! !

SmartSyntaxInterpreterPlugin subclass: #GeniePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!GeniePlugin commentStamp: '<historical>' prior: 0!
This plugin implements the functionality of
	CRStrokeFeature>>sameClassAbsoluteStrokeDistance: aCRFeature forReference: aBoolean
. This means that changes there should be mirrored here!!

GeniePlugin>>majorNO should be in sync with version number of Genie.
!
!GeniePlugin class methodsFor: 'check installed plugin' stamp: 'sr 6/25/2001 20:49'!
majorNO
	| no |
	^ (no := self versionNO) ifNotNil: [no // 1000]
! !
!GeniePlugin class methodsFor: 'check installed plugin' stamp: 'sr 6/25/2001 20:50'!
minorNO
	| no |
	^ (no := self versionNO) ifNotNil: [no \\ 1000]
! !
!GeniePlugin class methodsFor: 'translation' stamp: 'sr 4/15/2001 17:44'!
moduleNameAndVersion
	"Answer the receiver's module name and version info that is used for the plugin's C code. The default is to append the code generation date, but any useful text is ok (keep it short)"

	^ self moduleName, Character space asString, self version, Character space asString, Date today asString! !
!GeniePlugin class methodsFor: 'translation' stamp: 'sr 6/25/2001 20:42'!
version
	"Answer the receiver's version info as String."
	"Somewhat a hack, but calling class methods from inst methods doesn't result in usable C-code..."

	| inst |
	inst := self new.
	^ 'v', inst majorNO asString, '.', inst minorNO asString! !
!GeniePlugin class methodsFor: 'check installed plugin' stamp: 'sr 6/25/2001 20:46'!
versionNO
	<primitive: 'primVersionNO' module: 'GeniePlugin'>
	^ nil
! !
!GeniePlugin class methodsFor: 'check installed plugin' stamp: 'NS 8/8/2001 15:31'!
versionString
	^ 'v', (self versionNO / 1000 asFloat) asString! !
!GeniePlugin methodsFor: 'computation' stamp: 'tpr 12/29/2005 16:21'!
cSquaredDistanceFrom: aPoint to: bPoint
	"arguments are pointer to ints paired as x,y coordinates of points"
	| aPointX aPointY bPointX bPointY xDiff yDiff |
	self var: #aPoint type: 'int *  '.
	self var: #bPoint type: 'int *  '.
	aPointX := aPoint at: 0.
	aPointY := aPoint at: 1.
	bPointX := bPoint at: 0.
	bPointY := bPoint at: 1.

	xDiff := bPointX - aPointX.
	yDiff := bPointY - aPointY.
	^ xDiff * xDiff + (yDiff * yDiff)! !
!GeniePlugin methodsFor: 'computation' stamp: 'sr 6/5/2001 06:53'!
cSubstAngleFactorFrom: startDegreeNumber to: endDegreeNumber 
	| absDiff |
	absDiff := (endDegreeNumber - startDegreeNumber) abs.
	absDiff > 180 ifTrue: [absDiff := 360 - absDiff].
	^ absDiff * absDiff bitShift: -6! !
!GeniePlugin methodsFor: 'version' stamp: 'NS 7/12/2001 11:54'!
majorNO
	^ 2! !
!GeniePlugin methodsFor: 'version' stamp: 'NS 7/12/2001 11:54'!
minorNO
	^ 0! !
!GeniePlugin methodsFor: 'computation' stamp: 'dtl 8/18/2009 07:24'!
primSameClassAbsoluteStrokeDistanceMyPoints: myPointsOop otherPoints: otherPointsOop myVectors: myVectorsOop otherVectors: otherVectorsOop mySquaredLengths: mySquaredLengthsOop otherSquaredLengths: otherSquaredLengthsOop myAngles: myAnglesOop otherAngles: otherAnglesOop maxSizeAndReferenceFlag: maxSizeAndRefFlag rowBase: rowBaseOop rowInsertRemove: rowInsertRemoveOop rowInsertRemoveCount: rowInsertRemoveCountOop
	| base insertRemove jLimiT substBase insert remove subst removeBase insertBase insertRemoveCount additionalMultiInsertRemoveCost myPoints otherPoints myVectors otherVectors rowInsertRemoveCount mySquaredLengths otherSquaredLengths myAngles otherAngles rowBase rowInsertRemove otherPointsSize myVectorsSize otherVectorsSize otherSquaredLengthsSize rowBaseSize maxDist maxSize forReference jM1 iM1 iM1T2 jM1T2 |
	self var: #myPoints type: 'int *  '.
	self var: #otherPoints type: 'int *  '.
	self var: #myVectors type: 'int *  '.
	self var: #otherVectors type: 'int *  '.
	self var: #mySquaredLengths type: 'int *  '.
	self var: #otherSquaredLengths type: 'int *  '.
	self var: #myAngles type: 'int *  '.
	self var: #otherAngles type: 'int *  '.
	self var: #rowBase type: 'int *  '.
	self var: #rowInsertRemove type: 'int *  '.
	self var: #rowInsertRemoveCount type: 'int *  '.
	self
		primitive: 'primSameClassAbsoluteStrokeDistanceMyPoints_otherPoints_myVectors_otherVectors_mySquaredLengths_otherSquaredLengths_myAngles_otherAngles_maxSizeAndReferenceFlag_rowBase_rowInsertRemove_rowInsertRemoveCount'
		parameters: #(#Oop #Oop #Oop #Oop #Oop #Oop #Oop #Oop #SmallInteger #Oop #Oop #Oop)
		receiver: #Oop.
	interpreterProxy failed
		ifTrue: [self msg: 'failed 1'.
			^ nil].

	interpreterProxy success: (interpreterProxy isWords: myPointsOop)
			& (interpreterProxy isWords: otherPointsOop)
			& (interpreterProxy isWords: myVectorsOop)
			& (interpreterProxy isWords: otherVectorsOop)
			& (interpreterProxy isWords: mySquaredLengthsOop)
			& (interpreterProxy isWords: otherSquaredLengthsOop)
			& (interpreterProxy isWords: myAnglesOop)
			& (interpreterProxy isWords: otherAnglesOop)
			& (interpreterProxy isWords: rowBaseOop)
			& (interpreterProxy isWords: rowInsertRemoveOop)
			& (interpreterProxy isWords: rowInsertRemoveCountOop).
	interpreterProxy failed
		ifTrue: [self msg: 'failed 2'.
			^ nil].
	interpreterProxy success: (interpreterProxy is: myPointsOop MemberOf: 'PointArray')
			& (interpreterProxy is: otherPointsOop MemberOf: 'PointArray').
	interpreterProxy failed
		ifTrue: [self msg: 'failed 3'.
			^ nil].
	myPoints := interpreterProxy firstIndexableField: myPointsOop.
	otherPoints := interpreterProxy firstIndexableField: otherPointsOop.
	myVectors := interpreterProxy firstIndexableField: myVectorsOop.
	otherVectors := interpreterProxy firstIndexableField: otherVectorsOop.
	mySquaredLengths := interpreterProxy firstIndexableField: mySquaredLengthsOop.
	otherSquaredLengths := interpreterProxy firstIndexableField: otherSquaredLengthsOop.
	myAngles := interpreterProxy firstIndexableField: myAnglesOop.
	otherAngles := interpreterProxy firstIndexableField: otherAnglesOop.
	rowBase := interpreterProxy firstIndexableField: rowBaseOop.
	rowInsertRemove := interpreterProxy firstIndexableField: rowInsertRemoveOop.
	rowInsertRemoveCount := interpreterProxy firstIndexableField: rowInsertRemoveCountOop.
	"Note: myPointsSize and mySquaredLengthsSize variables eliminated to reduce
	method temporary variable count for closure-enabled images"
	"PointArrays"
	"myPointsSize := (interpreterProxy stSizeOf: myPointsOop) bitShift: -1."
	otherPointsSize := (interpreterProxy stSizeOf: otherPointsOop) bitShift: -1.
	myVectorsSize := (interpreterProxy stSizeOf: myVectorsOop) bitShift: -1.
	otherVectorsSize := (interpreterProxy stSizeOf: otherVectorsOop) bitShift: -1.
	"IntegerArrays"
	"mySquaredLengthsSize := interpreterProxy stSizeOf: mySquaredLengthsOop."
	otherSquaredLengthsSize := interpreterProxy stSizeOf: otherSquaredLengthsOop.
	rowBaseSize := interpreterProxy stSizeOf: rowBaseOop.

	interpreterProxy success: rowBaseSize
			= (interpreterProxy stSizeOf: rowInsertRemoveOop) & (rowBaseSize
				= (interpreterProxy stSizeOf: rowInsertRemoveCountOop)) & (rowBaseSize > otherVectorsSize).
	interpreterProxy failed
		ifTrue: [self msg: 'failed 4'.
			^ nil].
	interpreterProxy success: (interpreterProxy stSizeOf: mySquaredLengthsOop) >= (myVectorsSize - 1)
				& (((interpreterProxy stSizeOf: myPointsOop) bitShift: -1) >= myVectorsSize)
				& (otherSquaredLengthsSize >= (otherVectorsSize - 1))
				& (otherPointsSize >= otherVectorsSize) & ((interpreterProxy stSizeOf: myAnglesOop)
				>= (myVectorsSize - 1)) & ((interpreterProxy stSizeOf: otherAnglesOop)
				>= (otherVectorsSize - 1)).
	interpreterProxy failed
		ifTrue: [self msg: 'failed 5'.
			^ nil].

	"maxSizeAndRefFlag contains the maxium feature size (pixel) and also indicates whether
	the reference flag (boolean) is set. Therefore the maximum size is moved to the left 
	and the reference flag is stored in the LSB.
	Note: This is necessary to avoid more than 12 primitive parameters"
	forReference := maxSizeAndRefFlag bitAnd: 1.
	maxSize := maxSizeAndRefFlag bitShift: -1.
	maxDist := 1 bitShift: 29.
	forReference
		ifTrue: [additionalMultiInsertRemoveCost := 0]
		ifFalse: [additionalMultiInsertRemoveCost := maxSize * maxSize bitShift: -10].
	"C indices!!!!"
	rowBase
		at: 0
		put: 0.
	rowInsertRemove
		at: 0
		put: 0.
	rowInsertRemoveCount
		at: 0
		put: 2.
	insertRemove := 0 - additionalMultiInsertRemoveCost.
	jLimiT := otherVectorsSize.
	otherPointsSize >= (jLimiT - 1) & (otherSquaredLengthsSize >= (jLimiT - 1))
		ifFalse: [^ interpreterProxy primitiveFail].
	1
		to: jLimiT
		do: [:j |
			jM1 := j - 1.
			insertRemove := insertRemove + ((otherSquaredLengths at: jM1)
							+ (self
									cSquaredDistanceFrom: (otherPoints + (jM1 bitShift: 1))
									to: myPoints) bitShift: -7) + additionalMultiInsertRemoveCost.
			rowInsertRemove
				at: j
				put: insertRemove.
			rowBase
				at: j
				put: insertRemove * j.
			rowInsertRemoveCount
				at: j
				put: j + 1].
	insertRemove := (rowInsertRemove at: 0)
				- additionalMultiInsertRemoveCost.
	1
		to: myVectorsSize
		do: [:i |
			iM1 := i - 1.
			iM1T2 := iM1 bitShift: 1.
			substBase := rowBase at: 0.
			insertRemove := insertRemove + ((mySquaredLengths at: iM1)
							+ (self
									cSquaredDistanceFrom: (myPoints + iM1T2)
									to: otherPoints) bitShift: -7) + additionalMultiInsertRemoveCost.
			rowInsertRemove
				at: 0
				put: insertRemove.
			rowBase
				at: 0
				put: insertRemove * i.
			rowInsertRemoveCount
				at: 0
				put: i + 1.
			jLimiT := otherVectorsSize.
			1
				to: jLimiT
				do: [:j |
					jM1 := j - 1.
					jM1T2 := jM1 bitShift: 1.
					removeBase := rowBase at: j.
					insertBase := rowBase at: jM1.
					remove := (mySquaredLengths at: iM1)
								+ (self
										cSquaredDistanceFrom: (myPoints + iM1T2)
										to: (otherPoints + (j bitShift: 1))) bitShift: -7.
					(insertRemove := rowInsertRemove at: j) = 0
						ifTrue: [removeBase := removeBase + remove]
						ifFalse: [removeBase := removeBase + insertRemove + (remove
											* (rowInsertRemoveCount at: j)).
							remove := remove + insertRemove].
					insert := (otherSquaredLengths at: jM1)
								+ (self
										cSquaredDistanceFrom: (otherPoints + jM1T2)
										to: (myPoints + (i bitShift: 1))) bitShift: -7.
					(insertRemove := rowInsertRemove at: jM1) = 0
						ifTrue: [insertBase := insertBase + insert]
						ifFalse: [insertBase := insertBase + insertRemove + (insert
											* (rowInsertRemoveCount at: jM1)).
							insert := insert + insertRemove].
					forReference
						ifTrue: [substBase := maxDist]
						ifFalse: [subst := (self
										cSquaredDistanceFrom: (otherVectors + jM1T2)
										to: (myVectors + iM1T2))
										+ (self
												cSquaredDistanceFrom: (otherPoints + jM1T2)
												to: (myPoints + iM1T2)) * (16
											+ (self
													cSubstAngleFactorFrom: (otherAngles at: jM1)
													to: (myAngles at: iM1))) bitShift: -11.
							substBase := substBase + subst].
					(substBase <= removeBase
							and: [substBase <= insertBase])
						ifTrue: [base := substBase.
							insertRemove := 0.
							insertRemoveCount := 1]
						ifFalse: [removeBase <= insertBase
								ifTrue: [base := removeBase.
									insertRemove := remove + additionalMultiInsertRemoveCost.
									insertRemoveCount := (rowInsertRemoveCount at: j)
												+ 1]
								ifFalse: [base := insertBase.
									insertRemove := insert + additionalMultiInsertRemoveCost.
									insertRemoveCount := (rowInsertRemoveCount at: jM1)
												+ 1]].
					substBase := rowBase at: j.
					rowBase
						at: j
						put: (base min: maxDist).
					rowInsertRemove
						at: j
						put: (insertRemove min: maxDist).
					rowInsertRemoveCount
						at: j
						put: insertRemoveCount].
			insertRemove := rowInsertRemove at: 0].
	^ base asOop: SmallInteger
! !
!GeniePlugin methodsFor: 'version' stamp: 'sr 6/25/2001 20:39'!
primVersionNO
	"majorNO * 1000 + minorNO"
	self
		primitive: 'primVersionNO'
		parameters: #()
		receiver: #Oop.
	^ (self majorNO * 1000 + self minorNO) asOop: SmallInteger! !

SmartSyntaxInterpreterPlugin subclass: #HostWindowPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!HostWindowPlugin commentStamp: 'tpr 10/14/2004 15:57' prior: 0!
This plugin provides access to creating, destroying and manipulating host OS windows. See the Cross/plugins/HostWindowPlugin/HostWindowPlugin.h file for documented declarations for the C functions you need to provide.!
!HostWindowPlugin class methodsFor: 'translation' stamp: 'JMM 8/17/2004 20:24'!
hasHeaderFile
	^true! !
!HostWindowPlugin class methodsFor: 'translation' stamp: 'tpr 7/20/2004 13:09'!
requiresPlatformFiles
	^true! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'tpr 9/20/2004 12:32'!
primitiveCloseHostWindow: windowIndex
"Close a host window. windowIndex is the SmallInt handle returned previously by primitiveCreateHostWindow. Fail if the index is invalid or the platform code fails"
	| ok |
	self primitive: 'primitiveCloseHostWindow'
		parameters: #(SmallInteger).
	
	ok := self closeWindow: windowIndex.
	ok ifFalse:[interpreterProxy primitiveFail].
! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'tpr 10/3/2004 10:34'!
primitiveCreateHostWindowWidth: w height: h originX: x y: y attributes: list
"Create a host window of width 'w' pixels, height 'h' with the origin of the
user area at 'x@y' from the topleft corner of the screen.
Return the SmallInt value of the internal index to the window description block
- which is whatever the host platform code needs it to be."
	| windowIndex listLength |
	self primitive: 'primitiveCreateHostWindow'
		parameters: #(SmallInteger SmallInteger SmallInteger SmallInteger ByteArray).

	"createWindowWidthheightoriginXyattr(int w, int h, int x, int y, int*
attributeList) must create a hostwindow and return an integer index. Return 0 if
failed"
	listLength := interpreterProxy slotSizeOf: list cPtrAsOop.
	windowIndex := self createWindowWidth: w height: h originX: x y: y attr: list
length: listLength.
	windowIndex > 0 ifTrue:[^windowIndex asSmallIntegerObj]
		ifFalse:[^interpreterProxy primitiveFail].
! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'tpr 10/14/2004 15:58'!
primitiveHostWindowPosition: windowIndex 
	"Return the origin position of the user area of the window in pixels from the topleft corner of the screen. Fail if the windowIndex is invalid or the platform routine returns -1 to indicate failure"
	| pos |
	self primitive: 'primitiveHostWindowPosition'
		parameters: #(SmallInteger ).
	pos := self ioPositionOfWindow: windowIndex.
	pos = -1
		ifTrue: [^ interpreterProxy primitiveFail]
		ifFalse: [^ interpreterProxy makePointwithxValue: pos >> 16  yValue: (pos bitAnd: 16rFFFF)]! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'tpr 10/14/2004 15:58'!
primitiveHostWindowPositionSet: windowIndex x:  x y: y
	"Set the origin position of the user area of the window  in pixels from the topleft corner of the screen- return the position actually set by the OS/GUI/window manager. Fail if the windowIndex is invalid or the platform routine returns -1 to indicate failure"
	| pos |
	self primitive: 'primitiveHostWindowPositionSet'
		parameters: #(SmallInteger SmallInteger SmallInteger).
	pos := self ioPositionOfWindowSet: windowIndex x: x y: y.
	pos = -1
		ifTrue: [^ interpreterProxy primitiveFail]
		ifFalse: [^ interpreterProxy makePointwithxValue: pos >> 16  yValue: (pos bitAnd: 16rFFFF)]! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'tpr 10/14/2004 15:59'!
primitiveHostWindowSize: windowIndex 
	"Return the size of the user area of the window in pixels. Fail if the windowIndex is invalid or the platform routine returns -1 to indicate failure"
	| size |
	self primitive: 'primitiveHostWindowSize'
		parameters: #(SmallInteger ).
	size := self ioSizeOfWindow: windowIndex.
	size = -1
		ifTrue: [^ interpreterProxy primitiveFail]
		ifFalse: [^ interpreterProxy makePointwithxValue: size >> 16  yValue: (size bitAnd: 16rFFFF)]! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'tpr 10/14/2004 15:59'!
primitiveHostWindowSizeSet: windowIndex x: x y: y
	"Set the size of the user area of the window in pixels - return what is actually set by the OS/GUI/window manager. Fail if the windowIndex is invalid or the platform routine returns -1 to indicate failure"
	| size |
	self primitive: 'primitiveHostWindowSizeSet'
		parameters: #(SmallInteger SmallInteger SmallInteger).
	size := self ioSizeOfWindowSet: windowIndex x: x y: y.
	size = -1
		ifTrue: [^ interpreterProxy primitiveFail]
		ifFalse: [^ interpreterProxy makePointwithxValue: size >> 16  yValue: (size bitAnd: 16rFFFF)]! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'tpr 9/20/2004 12:38'!
primitiveHostWindowTitle: id string: titleString
	"Set the title bar label of the window. Fail if the windowIndex is invalid or the platform routine returns -1 to indicate failure"
	| res titleLength |
	self primitive: 'primitiveHostWindowTitle'
		parameters: #(SmallInteger String).
	titleLength := interpreterProxy slotSizeOf: titleString cPtrAsOop.
	res := self cCode: 'ioSetTitleOfWindow(id, titleString, titleLength)'.
	res = -1
		ifTrue: [interpreterProxy primitiveFail]! !
!HostWindowPlugin methodsFor: 'system primitives' stamp: 'John M McIntosh 12/1/2009 21:44'!
primitiveShowHostWindow: windowIndex bits: dispBits width: w height: h depth: d
left: left right: right top: top bottom: bottom
"Host window analogue of DisplayScreen> primShowRectLeft:right:top:bottom:
(Interpreter>primitiveShowDisplayRect) which takes the window index, bitmap
details and the rectangle bounds. Fail if the windowIndex is invalid or the
platform routine returns false to indicate failure"
	|ok|
	self var: #dispBits type: 'unsigned char * '.
	self primitive: 'primitiveShowHostWindowRect'
		parameters: #(SmallInteger WordArray SmallInteger SmallInteger SmallInteger
SmallInteger SmallInteger SmallInteger SmallInteger).

	"Tell the vm to copy pixel's from dispBits to the screen - this is just
ioShowDisplay with the extra parameter of the windowIndex integer"
	ok := self cCode: 'ioShowDisplayOnWindow(dispBits, w, h, d, left, right, top,
bottom, windowIndex)'.
	ok ifFalse:[interpreterProxy primitiveFail]! !
!HostWindowPlugin methodsFor: 'initialize-release' stamp: 'tpr 9/17/2004 18:16'!
shutdownModule
"do any window related VM closing down work your platform requires."
	self export: true.
	^self cCode: 'ioCloseAllWindows()' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #InternetConfigPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!InternetConfigPlugin commentStamp: 'tpr 5/5/2003 12:05' prior: 0!
This plugin provides access to the Mac's internet configuration toolkit - so long as you are running on a Mac.!
!InternetConfigPlugin class methodsFor: 'translation' stamp: 'JMM 9/26/2001 12:21'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!InternetConfigPlugin class methodsFor: 'translation' stamp: 'JMM 9/26/2001 12:21'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!InternetConfigPlugin methodsFor: 'initialize' stamp: 'JMM (auto pragmas 12/08) 9/26/2001 12:22'!
initialiseModule
	<export: true>
	^self cCode: 'sqInternetConfigurationInit()' inSmalltalk:[true]! !
!InternetConfigPlugin methodsFor: 'system primitives' stamp: 'JMM 9/28/2001 13:06'!
primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName
	| oop ptr keyLength creator |

	self primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom'
		parameters: #(String).
	self var: #aFile declareC: 'char aFile[256]'.
	self var: #creator declareC: 'char creator[8]'.
	self var: #ptr type: 'char *'.
	
	keyLength := interpreterProxy byteSizeOf: aFileName cPtrAsOop.
	self sqInternetGetMacintoshFileTypeAndCreatorFrom: aFileName keySize: keyLength into: creator.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: 8.
	ptr := interpreterProxy firstIndexableField: oop.
	0 to: 7 do:[:i|
		ptr at: i put: (creator at: i)].
	^oop.
! !
!InternetConfigPlugin methodsFor: 'system primitives' stamp: 'JMM 10/5/2001 09:56'!
primitiveGetStringKeyedBy: aKey
	| oop ptr size aString keyLength |

	self primitive: 'primitiveGetStringKeyedBy'
		parameters: #(String).
	self var: #aString declareC: 'char aString[1025]'.
	self var: #ptr type: 'char *'.
	
	keyLength := interpreterProxy byteSizeOf: aKey cPtrAsOop.
	size := self sqInternetConfigurationGetStringKeyedBy: aKey keySize: keyLength into: aString.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: size.
	ptr := interpreterProxy firstIndexableField: oop.
	0 to: size-1 do:[:i|
		ptr at: i put: (aString at: i)].
	^oop.
! !
!InternetConfigPlugin methodsFor: 'initialize' stamp: 'JMM (auto pragmas 12/08) 9/26/2001 12:22'!
shutdownModule
	<export: true>
	^self cCode: 'sqInternetConfigurationShutdown()' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #JPEGReadWriter2Plugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!JPEGReadWriter2Plugin commentStamp: '<historical>' prior: 0!
This work is a Squeak VM Plugin version of LibJPEG.

The following sentence applies to this class:
  "This software is based in part on the work of the Independent JPEG Group".

You can read more about it at www.ijg.org

In addition to the code generated from this class, the plugin uses the following files (from LibJPEG ver. 6b):

jerror.c
jcmarker.c
jdmarker.c
jctrans.c
jcparam.c
jdapimin.c
jcapimin.c
jidctred.c
jidctflt.c
jidctfst.c
jidctint.c
jccoefct.c
jdinput.c
jdmaster.c
jdcoefct.c
jdhuff.c
jdphuff.c
jcphuff.c
jchuff.c
jcomapi.c
jcinit.c
jcmaster.c
jdcolor.c
jdtrans.c
jmemmgr.c
jutils.c
jddctmgr.c
jcdctmgr.c
jquant2.c
jquant1.c
jmemnobs.c
jfdctint.c
jfdctfst.c
jfdctflt.c
jdsample.c
jdpostct.c
jdmerge.c
jdmainct.c
jdapistd.c
jcsample.c
jcprepct.c
jcmainct.c
jccolor.c
jcapistd.c
jversion.h
jpeglib.h
jdhuff.h
jchuff.h
jerror.h
jmorecfg.h
jmemsys.h
jpegint.h
jdct.h
jinclude.h

!
!JPEGReadWriter2Plugin class methodsFor: 'translation' stamp: 'JMM 10/3/2001 11:44'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!JPEGReadWriter2Plugin class methodsFor: 'translation' stamp: 'tpr 3/1/2002 17:03'!
requiresCrossPlatformFiles
	"default is ok for most, any plugin needing cross platform files must say so"
	^true! !
!JPEGReadWriter2Plugin class methodsFor: 'translation' stamp: 'JMM 10/3/2001 11:48'!
requiresPlatformFiles
	"default is ok for most, any plugin needing platform specific files must say so"
	^true! !
!JPEGReadWriter2Plugin methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 12/25/2003 23:09'!
initialiseModule

	<export: true>
	^true! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'jmv (auto pragmas 12/08) 11/30/2001 00:17'!
primImageHeight: aJPEGDecompressStruct

	<export: true>

	self
		primitive: 'primImageHeight'
		parameters: #(ByteArray).

	"Various parameter checks"
	self cCode: '
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(0))) >= (sizeof(struct jpeg_decompress_struct))); 
		if (interpreterProxy->failed()) return null;
	' inSmalltalk: [].

	^(self cCode: '((j_decompress_ptr)aJPEGDecompressStruct)->image_height' inSmalltalk: [0])
		 asOop: SmallInteger! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'jmv (auto pragmas 12/08) 11/30/2001 00:17'!
primImageWidth: aJPEGDecompressStruct

	<export: true>

	self
		primitive: 'primImageWidth'
		parameters: #(ByteArray).

	"Various parameter checks"
	self cCode: '
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(0))) >= (sizeof(struct jpeg_decompress_struct))); 
		if (interpreterProxy->failed()) return null;
	' inSmalltalk: [].

	^(self cCode: '((j_decompress_ptr)aJPEGDecompressStruct)->image_width' inSmalltalk: [0])
		asOop: SmallInteger! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'jmv (auto pragmas 12/08) 11/30/2001 00:17'!
primJPEGCompressStructSize
	<export: true>

	self
		primitive: 'primJPEGCompressStructSize'
		parameters: #().

	^(self cCode: 'sizeof(struct jpeg_compress_struct)' inSmalltalk: [0])
		asOop: SmallInteger! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'jmv (auto pragmas 12/08) 11/30/2001 00:17'!
primJPEGDecompressStructSize
	<export: true>

	self
		primitive: 'primJPEGDecompressStructSize'
		parameters: #().

	^(self cCode: 'sizeof(struct jpeg_decompress_struct)' inSmalltalk: [0])
		asOop: SmallInteger! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'jmv (auto pragmas 12/08) 11/30/2001 00:17'!
primJPEGErrorMgr2StructSize
	<export: true>
	self
		primitive: 'primJPEGErrorMgr2StructSize'
		parameters: #().

	^(self cCode: 'sizeof(struct error_mgr2)' inSmalltalk: [0])
		asOop: SmallInteger! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 11/27/2001 00:45'!
primJPEGPluginIsPresent
	<export: true>
	self
		primitive: 'primJPEGPluginIsPresent'
		parameters: #().
	^true asOop: Boolean! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:54'!
primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct

	| pcinfo pjerr sourceSize |
	<export: true>
	<var: #pcinfo type: 'j_decompress_ptr '>
	<var: #pjerr type: 'error_ptr2 '>
	self
		primitive: 'primJPEGReadHeaderfromByteArrayerrorMgr'
		parameters: #(ByteArray ByteArray ByteArray).
 

		pcinfo := nil. pjerr := nil. sourceSize := nil.
		pcinfo. pjerr. sourceSize.

	"Various parameter checks"
	self cCode: '
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(2))) >= (sizeof(struct jpeg_decompress_struct)));
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(0))) >= (sizeof(struct error_mgr2))); 
		if (interpreterProxy->failed()) return null;
	' inSmalltalk: [].

	self cCode: '
		sourceSize = interpreterProxy->stSizeOf(interpreterProxy->stackValue(1));
		pcinfo = (j_decompress_ptr)aJPEGDecompressStruct;
		pjerr = (error_ptr2)aJPEGErrorMgr2Struct;
		if (sourceSize) {
			pcinfo->err = jpeg_std_error(&pjerr->pub);
			pjerr->pub.error_exit = error_exit;
			if (setjmp(pjerr->setjmp_buffer)) {
				jpeg_destroy_decompress(pcinfo);
				sourceSize = 0;
			}
			if (sourceSize) {
				jpeg_create_decompress(pcinfo);
				jpeg_mem_src(pcinfo, source, sourceSize);
				jpeg_read_header(pcinfo, TRUE);
			}
		}
	' inSmalltalk: [].! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'dtl 10/9/2010 09:13'!
primJPEGReadImage: aJPEGDecompressStruct fromByteArray: source onForm: form doDithering: ditherFlag errorMgr: aJPEGErrorMgr2Struct

	| pcinfo pjerr buffer rowStride formBits formDepth i j formPix ok rOff gOff bOff rOff2 gOff2 bOff2 formWidth formHeight pixPerWord formPitch formBitsSize sourceSize r1 r2 g1 g2 b1 b2 formBitsOops dmv1 dmv2 di dmi dmo |
	<export: true>
	<var: #pcinfo type: 'j_decompress_ptr '>
	<var: #pjerr type: 'error_ptr2 '>
	<var: #buffer type: 'JSAMPARRAY '>
	<var: #formBits type: 'unsigned * '>

	self
		primitive: 'primJPEGReadImagefromByteArrayonFormdoDitheringerrorMgr'
		parameters: #(ByteArray ByteArray Form Boolean ByteArray).

	"Avoid warnings when saving method"
	 pcinfo := nil. pjerr := nil. buffer := nil. rowStride := nil.
		formDepth := nil. formBits := nil. i := nil. j := nil. formPix := nil.
		ok := nil. rOff := nil. gOff := nil. bOff := nil. rOff2 := nil. gOff2 := nil. bOff2 := nil. sourceSize := nil.
		r1 := nil. r2 := nil. g1 := nil. g2 := nil. b1 := nil. b2 := nil.
		dmv1 := nil. dmv2 := nil. di := nil. dmi := nil. dmo := nil.
		pcinfo. pjerr. buffer. rowStride. formBits. formDepth. i. j. formPix. ok.
		rOff. gOff. bOff. rOff2. gOff2. bOff2. sourceSize.
		r1. r2. g1.g2. b1. b2. dmv1. dmv2. di. dmi. dmo.

	formBitsOops := interpreterProxy fetchPointer: 0 ofObject: form.
	formDepth := interpreterProxy fetchInteger: 3 ofObject: form.

	"Various parameter checks"
	self cCode: '
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(4))) >= (sizeof(struct jpeg_decompress_struct)));
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(0))) >= (sizeof(struct error_mgr2))); 
		if (interpreterProxy->failed()) return null;
	' inSmalltalk: [].
	formWidth := (self cCode: '((j_decompress_ptr)aJPEGDecompressStruct)->image_width' inSmalltalk: [0]).
	formHeight := (self cCode: '((j_decompress_ptr)aJPEGDecompressStruct)->image_height' inSmalltalk: [0]).
	pixPerWord := 32 // formDepth.
	formPitch := formWidth + (pixPerWord-1) // pixPerWord * 4.
	formBitsSize := interpreterProxy byteSizeOf: formBitsOops.
	interpreterProxy success: 
		((interpreterProxy isWordsOrBytes: formBitsOops)
			and: [formBitsSize = (formPitch * formHeight)]).
	interpreterProxy failed ifTrue: [^ nil].
	formBits := interpreterProxy firstIndexableField: formBitsOops.

	self cCode: '
		sourceSize = interpreterProxy->stSizeOf(interpreterProxy->stackValue(3));
		if (sourceSize == 0) {
			interpreterProxy->success(false);
			return null;
		}
		pcinfo = (j_decompress_ptr)aJPEGDecompressStruct;
		pjerr = (error_ptr2)aJPEGErrorMgr2Struct;
		pcinfo->err = jpeg_std_error(&pjerr->pub);
		pjerr->pub.error_exit = error_exit;
		ok = 1;
		if (setjmp(pjerr->setjmp_buffer)) {
			jpeg_destroy_decompress(pcinfo);
			ok = 0;
		}
		if (ok) {
			ok = jpeg_mem_src_newLocationOfData(pcinfo, source, sourceSize);
			if (ok) {
				/* Dither Matrix taken from Form>>orderedDither32To16, but rewritten for this method. */
				int ditherMatrix1[] = { 2, 0, 14, 12, 1, 3, 13, 15 };
				int ditherMatrix2[] = { 10, 8, 6, 4, 9, 11, 5, 7 };
 				jpeg_start_decompress(pcinfo);
				rowStride = pcinfo->output_width * pcinfo->output_components;
				if (pcinfo->out_color_components == 3) {
					rOff = 0; gOff = 1; bOff = 2;
					rOff2 = 3; gOff2 = 4; bOff2 = 5;
				} else {
					rOff = 0; gOff = 0; bOff = 0;
					rOff2 = 1; gOff2 = 1; bOff2 = 1;
				}
				/* Make a one-row-high sample array that will go away when done with image */
				buffer = (*(pcinfo->mem)->alloc_sarray)
					((j_common_ptr) pcinfo, JPOOL_IMAGE, rowStride, 1);

				/* Step 6: while (scan lines remain to be read) */
				/*           jpeg_read_scanlines(...); */

				/* Here we use the library state variable cinfo.output_scanline as the
				 * loop counter, so that we dont have to keep track ourselves.
				 */
				while (pcinfo->output_scanline < pcinfo->output_height) {
					/* jpeg_read_scanlines expects an array of pointers to scanlines.
					 * Here the array is only one element long, but you could ask for
					 * more than one scanline at a time if thats more convenient.
					 */
					(void) jpeg_read_scanlines(pcinfo, buffer, 1);

					switch (formDepth) {
						case 32:
							for(i = 0, j = 0; i < rowStride; i +=(pcinfo->out_color_components), j++) {
								formPix = (255 << 24) | (buffer[0][i+rOff] << 16) | (buffer[0][i+gOff] << 8) | buffer[0][i+bOff];
								if (formPix == 0) formPix = 1;
								formBits [ ((pcinfo->output_scanline - 1) * (pcinfo->image_width)) + j ] = formPix;
							}
							break;

						case 16:
							for(i = 0, j = 0; i < rowStride; i +=(pcinfo->out_color_components*2), j++) {
								r1 = buffer[0][i+rOff];
								r2 = buffer[0][i+rOff2];
								g1 = buffer[0][i+gOff];
								g2 = buffer[0][i+gOff2];
								b1 = buffer[0][i+bOff];
								b2 = buffer[0][i+bOff2];

								if (!!ditherFlag) {
									r1 = r1 >> 3;
									r2 = r2 >> 3;
									g1 = g1 >> 3;
									g2 = g2 >> 3;
									b1 = b1 >> 3;
									b2 = b2 >> 3;
								} else {
									/* Do 4x4 ordered dithering. Taken from Form>>orderedDither32To16 */
									dmv1 = ditherMatrix1[ ((pcinfo->output_scanline & 3 )<< 1) | (j&1) ];
									dmv2 = ditherMatrix2[ ((pcinfo->output_scanline & 3 )<< 1) | (j&1) ];

									di = (r1 * 496) >> 8; dmi = di & 15; dmo = di >> 4;
									if(dmv1 < dmi) { r1 = dmo+1; } else { r1 = dmo; };
									di = (g1 * 496) >> 8; dmi = di & 15; dmo = di >> 4;
									if(dmv1 < dmi) { g1 = dmo+1; } else { g1 = dmo; };
									di = (b1 * 496) >> 8; dmi = di & 15; dmo = di >> 4;
									if(dmv1 < dmi) { b1 = dmo+1; } else { b1 = dmo; };

									di = (r2 * 496) >> 8; dmi = di & 15; dmo = di >> 4;
									if(dmv2 < dmi) { r2 = dmo+1; } else { r2 = dmo; };
									di = (g2 * 496) >> 8; dmi = di & 15; dmo = di >> 4;
									if(dmv2 < dmi) { g2 = dmo+1; } else { g2 = dmo; };
									di = (b2 * 496) >> 8; dmi = di & 15; dmo = di >> 4;
									if(dmv2 < dmi) { b2 = dmo+1; } else { b2 = dmo; };
								}

								formPix = (r1 << 10) | (g1 << 5) | b1;
								if (!!formPix) formPix = 1;
								formPix = (formPix << 16) | (r2 << 10) | (g2 << 5) | b2;
								if (!!(formPix & 65535)) formPix = formPix | 1;
								formBits [ ((pcinfo->output_scanline - 1) * (pcinfo->image_width)) / 2 + j ] = formPix;
							}
							break;
					}
				}
				jpeg_finish_decompress(pcinfo);
			}
			jpeg_destroy_decompress(pcinfo);
		}
	' inSmalltalk: [].! !
!JPEGReadWriter2Plugin methodsFor: 'primitives' stamp: 'dtl 10/9/2010 13:28'!
primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct

	| pcinfo pjerr buffer rowStride formBits formWidth formHeight formDepth i j formPix destinationSize pixPerWord formPitch formBitsSize formBitsOops |
	<export: true>
	<var: #pcinfo type: 'j_compress_ptr '>
	<var: #pjerr type: 'error_ptr2 '>
	<var: #buffer type: 'JSAMPARRAY '>
	<var: #formBits type: 'unsigned * '>
	<var: #destinationSize type: 'unsigned int'>

	self
		primitive: 'primJPEGWriteImageonByteArrayformqualityprogressiveJPEGerrorMgr'
		parameters: #(ByteArray ByteArray Form SmallInteger Boolean ByteArray).

	pcinfo := nil. pjerr := nil. buffer :=nil. rowStride := nil. formBits := nil. 
	formWidth := nil. formHeight := nil. formDepth := nil. i := nil. j := nil. formPix := nil. destinationSize := nil.
	pcinfo. pjerr. buffer. rowStride. formBits. formWidth. formHeight. formDepth. i. j. formPix. destinationSize.

	formBitsOops := interpreterProxy fetchPointer: 0 ofObject: form.
	formWidth := interpreterProxy fetchInteger: 1 ofObject: form.
	formHeight := interpreterProxy fetchInteger: 2 ofObject: form.
	formDepth := interpreterProxy fetchInteger: 3 ofObject: form.

	"Various parameter checks"
	self cCode: '
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(5))) >= (sizeof(struct jpeg_compress_struct)));
		interpreterProxy->success
			((interpreterProxy->stSizeOf(interpreterProxy->stackValue(0))) >= (sizeof(struct error_mgr2))); 
		if (interpreterProxy->failed()) return null;
	' inSmalltalk: [].
	pixPerWord := 32 // formDepth.
	formPitch := formWidth + (pixPerWord-1) // pixPerWord * 4.
	formBitsSize := interpreterProxy byteSizeOf: formBitsOops.
	interpreterProxy success: 
		((interpreterProxy isWordsOrBytes: formBitsOops)
			and: [formBitsSize = (formPitch * formHeight)]).
	interpreterProxy failed ifTrue: [^ nil].
	formBits := interpreterProxy firstIndexableField: formBitsOops.
	self cCode: '
		destinationSize = interpreterProxy->stSizeOf(interpreterProxy->stackValue(4));
		pcinfo = (j_compress_ptr)aJPEGCompressStruct;
		pjerr = (error_ptr2)aJPEGErrorMgr2Struct;
		if (destinationSize) {
			pcinfo->err = jpeg_std_error(&pjerr->pub);
			pjerr->pub.error_exit = error_exit;
			if (setjmp(pjerr->setjmp_buffer)) {
				jpeg_destroy_compress(pcinfo);
				destinationSize = 0;
			}
			if (destinationSize) {
				jpeg_create_compress(pcinfo);
				jpeg_mem_dest(pcinfo, destination, &destinationSize);
				pcinfo->image_width = formWidth;
				pcinfo->image_height = formHeight;
				pcinfo->input_components = 3;
				pcinfo->in_color_space = JCS_RGB;
				jpeg_set_defaults(pcinfo);
				if (quality > 0)
					jpeg_set_quality (pcinfo, quality, 1);
				if (progressiveFlag)
					jpeg_simple_progression(pcinfo);
				jpeg_start_compress(pcinfo, TRUE);
				rowStride = formWidth * 3;

				/* Make a one-row-high sample array that will go away 
				  when done with image */
				buffer = (*(pcinfo->mem)->alloc_sarray)
					((j_common_ptr) pcinfo, JPOOL_IMAGE, rowStride, 1);

				while (pcinfo->next_scanline < pcinfo->image_height) {
					switch (formDepth) {
						case 32:
							for(i = 0, j = 0; i < rowStride; i +=3, j++) {
								formPix = formBits [ ((pcinfo->next_scanline) * formWidth) + j ];
								buffer[0][i] = (formPix >> 16) & 255;
								buffer[0][i+1] = (formPix >> 8) & 255;
								buffer[0][i+2] = formPix & 255;
							}
							break;
						case 16:
							for(i = 0, j = 0; i < rowStride; i +=6, j++) {
								formPix = formBits [ ((pcinfo->next_scanline) * formWidth) / 2 + j ];
								buffer[0][i] = (formPix >> 23) & 248;
								buffer[0][i+1] = (formPix >> 18) & 248;
								buffer[0][i+2] = (formPix >> 13) & 248;
								buffer[0][i+3] = (formPix >> 7) & 248;
								buffer[0][i+4] = (formPix >> 2) & 248;
								buffer[0][i+5] = (formPix << 3) & 248;
							}
							break;
					}
					(void) jpeg_write_scanlines(pcinfo, buffer, 1);

				}
				jpeg_finish_compress(pcinfo);
				jpeg_destroy_compress(pcinfo);
			}
		}
	' inSmalltalk: [].
	^(self cCode: 'destinationSize' inSmalltalk: [0])
		asOop: SmallInteger! !
!JPEGReadWriter2Plugin methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 12/25/2003 23:11'!
shutdownModule

	<export: true>
	^true! !

SmartSyntaxInterpreterPlugin subclass: #JoystickTabletPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!JoystickTabletPlugin commentStamp: 'tpr 5/2/2003 15:48' prior: 0!
This plugin implements the interface to the joystick and tablet input devices, if you have one.  Since it requires platform support it will only be built when supported on your platform!
!JoystickTabletPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:08'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!JoystickTabletPlugin class methodsFor: 'translation' stamp: 'tpr 3/26/2002 15:22'!
requiresPlatformFiles
	" this plugin requires platform specific files in order to work"
	^true! !
!JoystickTabletPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:53'!
initialiseModule
	<export: true>
	^self cCode: 'joystickInit()' inSmalltalk:[true]! !
!JoystickTabletPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:35'!
primitiveGetTabletParameters: cursorIndex
	"Get information on the pen tablet attached to this machine. Fail if there is no tablet. If successful, the result is an array of integers; see the Smalltalk call on this primitive for its interpretation."

	| resultSize result resultPtr |
	<var: #resultPtr type: 'int * '>
	self primitive: 'primitiveGetTabletParameters'
		parameters: #(SmallInteger).
	resultSize := self tabletResultSize.
	result := interpreterProxy instantiateClass: interpreterProxy classBitmap indexableSize: resultSize.
	resultPtr := result asIntPtr.
	interpreterProxy success: (self cCode: 'tabletGetParameters(cursorIndex, resultPtr)').
	^result! !
!JoystickTabletPlugin methodsFor: 'primitives' stamp: 'TPR 3/24/2000 18:33'!
primitiveReadJoystick: index
	"Read an input word from the joystick with the given index."

	self primitive: 'primitiveReadJoystick'
		parameters: #(SmallInteger).
	^(self joystickRead: index) asPositiveIntegerObj! !
!JoystickTabletPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:36'!
primitiveReadTablet: cursorIndex
	"Get the current state of the cursor of the pen tablet specified by my argument. Fail if there is no tablet. If successful, the result is an array of integers; see the Smalltalk call on this primitive for its interpretation."

	| resultSize result resultPtr|
	<var: #resultPtr type: 'int * '>
	self primitive: 'primitiveReadTablet'
		parameters: #(SmallInteger).
	resultSize := self tabletResultSize.
	result := interpreterProxy instantiateClass: interpreterProxy classBitmap indexableSize: resultSize.
	resultPtr := result asIntPtr.
	interpreterProxy success: (self cCode: 'tabletRead(cursorIndex, resultPtr)').
	^result! !
!JoystickTabletPlugin methodsFor: 'initialize-release' stamp: 'tpr (auto pragmas 12/08) 3/26/2002 15:22'!
shutdownModule
	<export: true>
	^self cCode: 'joystickShutdown()' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #LargeIntegersPlugin
	instanceVariableNames: 'andOpIndex orOpIndex xorOpIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!LargeIntegersPlugin commentStamp: 'sr 6/14/2004 14:04' prior: 0!
LargeIntegersPlugin provides functions for speeding up LargeInteger arithmetics. Usually it is part of your installation as 'LargeIntegers' plugin (a C-compiled binary).


Correctly installed?
----------------------
Probably you are just working with it.

To be really sure try
	100 factorial. "to force plugin loading"
	SmalltalkImage current listLoadedModules.
Then you should see 'LargeIntegers' somewhere in the output strings. If this should not be the case, you probably have a problem.


Variables
-----------

Inst vars:
	andOpIndex			C constant
	orOpIndex			C constant
	xorOpIndex 			C constant
Used like an enum, in ST one would use symbols instead.

Class vars:
	none


History
--------

v1.5

- no code change at all compared to v1.4
- made to outsource testing code (LargeIntegersPluginTest) introduced in earlier versions
- updated class comment: reference to LargeIntegersPluginTest removed

v1.4

- no semantic change compared to v1.3
- >>cHighBit: improved (could be faster now)
- fix: class comment
- improved class comment
- >>flag: introduced to allow #flag: messages (does nothing)
- new: class>>buildCodeGeneratorUpTo: as hook for switching debugMode (default is not to change anything)
- removed: class>>new (obsolete)
- minor cleanup of source code layout

v1.3

- fix: >>primDigitDiv:negative: now checks if its Integer args are normalized; without this change the plugin crashes, if a division by zero through a non normalized - filled with zero bytes - arg occurs. This can happen through printing by the inspector windows after changing the bytes of a LargeInteger manually.

v1.2

- fix: >>anyBitOfBytes: aBytesOop from: start to: stopArg

v1.1

- >>primGetModuleName for checking the version of the plugin;

- >>primDigitBitShiftMagnitude and >>primAnyBitFrom:to: for supporting - not installing!! - unification of shift semantics of negative Integers;

v1.0

- speeds up digitDiv:neg: at about 20%.
	In >>cCoreDigitDivDiv:len:rem:len:quo:len: the 'nibble' arithmetic is removed.
!
!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'sr 6/8/2004 18:48'!
buildCodeGeneratorUpTo: someClass 
	"A hook to control generation of the plugin. Don't know how to set the 
	debug mode otherwise if using the VMMaker gui. Possibly there is a better way."
	| cg |
	cg := super buildCodeGeneratorUpTo: someClass.
	"example: cg generateDebugCode: true."
	^ cg! !
!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'sr 4/8/2000 05:40'!
declareCVarsIn: cg 
	cg var: 'andOpIndex' declareC: 'const int  andOpIndex = 0'.
	cg var: 'orOpIndex' declareC: 'const int  orOpIndex = 1'.
	cg var: 'xorOpIndex' declareC: 'const int  xorOpIndex = 2'! !
!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'ar 5/17/2000 16:08'!
moduleName
	^'LargeIntegers'! !
!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'eem 2/10/2009 14:48'!
moduleNameAndVersion
	"Answer the receiver's module name and version info that is used for the plugin's C code. The default is to append the code generation date, but any useful text is ok (keep it short)"

	^ self moduleName, ' ', self version! !
!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'sr 6/14/2004 13:52'!
version
	"Answer the receiver's version info as String."

	^ 'v1.5'! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 11/29/2000 13:41'!
anyBitOfBytes: aBytesOop from: start to: stopArg 
	"Argument has to be aBytesOop!!"
	"Tests for any magnitude bits in the interval from start to stopArg."
	| magnitude rightShift leftShift stop firstByteIx lastByteIx |
	self
		debugCode: [self msg: 'anyBitOfBytes: aBytesOop from: start to: stopArg'].
	start < 1 | (stopArg < 1)
		ifTrue: [^ interpreterProxy primitiveFail].
	magnitude := aBytesOop.
	stop := stopArg
				min: (self highBitOfBytes: magnitude).
	start > stop
		ifTrue: [^ false].
	firstByteIx := start - 1 // 8 + 1.
	lastByteIx := stop - 1 // 8 + 1.
	rightShift := 0 - (start - 1 \\ 8).
	leftShift := 7 - (stop - 1 \\ 8).
	firstByteIx = lastByteIx
		ifTrue: [| digit mask | 
			mask := (255 bitShift: 0 - rightShift)
						bitAnd: (255 bitShift: 0 - leftShift).
			digit := self digitOfBytes: magnitude at: firstByteIx.
			^ (digit bitAnd: mask)
				~= 0].
	((self digitOfBytes: magnitude at: firstByteIx)
			bitShift: rightShift)
			~= 0
		ifTrue: [^ true].
	firstByteIx + 1
		to: lastByteIx - 1
		do: [:ix | (self digitOfBytes: magnitude at: ix)
					~= 0
				ifTrue: [^ true]].
	(((self digitOfBytes: magnitude at: lastByteIx)
			bitShift: leftShift)
			bitAnd: 255)
			~= 0
		ifTrue: [^ true].
	^ false! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 6/8/2004 05:10'!
byteSizeOfBytes: bytesOop 
	"Precondition: bytesOop is not anInteger and a bytes object."
	"Function #byteSizeOf: is used by the interpreter, be careful with name
	clashes..."
	^ interpreterProxy slotSizeOf: bytesOop! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 6/8/2004 05:07'!
bytes: aBytesOop Lshift: shiftCount 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at return."
	"Does not normalize."
	| newBytes highBit newLen oldLen |
	oldLen := self byteSizeOfBytes: aBytesOop.
	(highBit := self cBytesHighBit: (interpreterProxy firstIndexableField: aBytesOop)
				len: oldLen) = 0 ifTrue: [^ 0 asOop: SmallInteger].
	newLen := highBit + shiftCount + 7 // 8.
	self remapOop: aBytesOop in: [newBytes := interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesOop)
					indexableSize: newLen].
	self
		cBytesLshift: shiftCount
		from: (interpreterProxy firstIndexableField: aBytesOop)
		len: oldLen
		to: (interpreterProxy firstIndexableField: newBytes)
		len: newLen.
	^ newBytes! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 6/8/2004 05:06'!
bytes: aBytesOop Rshift: anInteger bytes: b lookfirst: a 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at return."
	"Shift right 8*b+anInteger bits, 0<=n<8.         
	Discard all digits beyond a, and all zeroes at or below a."
	"Does not normalize."
	| n x f m digit i oldLen newLen newBytes |
	n := 0 - anInteger.
	x := 0.
	f := n + 8.
	i := a.
	m := 255 bitShift: 0 - f.
	digit := self digitOfBytes: aBytesOop at: i.
	[((digit bitShift: n)
		bitOr: x)
		= 0 and: [i ~= 1]]
		whileTrue: 
			[x := digit bitShift: f.
			"Can't exceed 8 bits"
			i := i - 1.
			digit := self digitOfBytes: aBytesOop at: i].
	i <= b ifTrue: [^ interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesOop)
			indexableSize: 0"Integer new: 0 neg: self negative"].
	"All bits lost"
	oldLen := self byteSizeOfBytes: aBytesOop.
	newLen := i - b.
	self remapOop: aBytesOop in: [newBytes := interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesOop)
					indexableSize: newLen].
	"r := Integer new: i - b neg: self negative."
	"	count := i.       
	"
	self
		cCoreBytesRshiftCount: i
		n: n
		m: m
		f: f
		bytes: b
		from: (interpreterProxy firstIndexableField: aBytesOop)
		len: oldLen
		to: (interpreterProxy firstIndexableField: newBytes)
		len: newLen.
	^ newBytes! !
!LargeIntegersPlugin methodsFor: 'oop util' stamp: 'sr 6/8/2004 05:06'!
bytes: aBytesObject growTo: newLen 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at return."
	"Does not normalize."
	| newBytes oldLen copyLen |
	self remapOop: aBytesObject in: [newBytes := interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesObject)
					indexableSize: newLen].
	oldLen := self byteSizeOfBytes: aBytesObject.
	oldLen < newLen
		ifTrue: [copyLen := oldLen]
		ifFalse: [copyLen := newLen].
	self
		cBytesCopyFrom: (interpreterProxy firstIndexableField: aBytesObject)
		to: (interpreterProxy firstIndexableField: newBytes)
		len: copyLen.
	^ newBytes! !
!LargeIntegersPlugin methodsFor: 'oop util' stamp: 'sr 6/8/2004 05:05'!
bytesOrInt: oop growTo: len 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at return."
	| newBytes val class |
	(interpreterProxy isIntegerObject: oop)
		ifTrue: 
			[val := interpreterProxy integerValueOf: oop.
			val < 0
				ifTrue: [class := interpreterProxy classLargeNegativeInteger]
				ifFalse: [class := interpreterProxy classLargePositiveInteger].
			newBytes := interpreterProxy instantiateClass: class indexableSize: len.
			self cCopyIntVal: val toBytes: newBytes]
		ifFalse: [newBytes := self bytes: oop growTo: len].
	^ newBytes! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:58'!
cByteOp: opIndex short: pByteShort len: shortLen long: pByteLong len: longLen into: pByteRes 
	"pByteRes len = longLen."
	| limit |
	<var: #pByteShort type: 'unsigned char * '>
	<var: #pByteLong type: 'unsigned char * '>
	<var: #pByteRes type: 'unsigned char * '>
	limit := shortLen - 1.
	opIndex = andOpIndex
		ifTrue: 
			[0 to: limit do: [:i | pByteRes at: i put: ((pByteShort at: i)
						bitAnd: (pByteLong at: i))].
			limit := longLen - 1.
			shortLen to: limit do: [:i | pByteRes at: i put: 0].
			^ 0].
	opIndex = orOpIndex
		ifTrue: 
			[0 to: limit do: [:i | pByteRes at: i put: ((pByteShort at: i)
						bitOr: (pByteLong at: i))].
			limit := longLen - 1.
			shortLen to: limit do: [:i | pByteRes at: i put: (pByteLong at: i)].
			^ 0].
	opIndex = xorOpIndex
		ifTrue: 
			[0 to: limit do: [:i | pByteRes at: i put: ((pByteShort at: i)
						bitXor: (pByteLong at: i))].
			limit := longLen - 1.
			shortLen to: limit do: [:i | pByteRes at: i put: (pByteLong at: i)].
			^ 0].
	^ interpreterProxy primitiveFail! !
!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:58'!
cBytesCopyFrom: pFrom to: pTo len: len 
	| limit |
	<returnTypeC: 'int'>
	<var: #pFrom type: 'unsigned char * '>
	<var: #pTo type: 'unsigned char * '>

	self cCode: '' inSmalltalk: [
		(interpreterProxy isKindOf: InterpreterSimulator) ifTrue: [
			"called from InterpreterSimulator"
				limit := len - 1.
				0 to: limit do: [:i |
					interpreterProxy byteAt: pTo + i
						put: (interpreterProxy byteAt: pFrom + i)
				].
			^ 0
		].
	].	
	limit := len - 1.
	0 to: limit do: [:i | pTo at: i put: (pFrom at: i)].
	^ 0! !
!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:55'!
cBytesHighBit: pByte len: len 
	"Answer the index (in bits) of the high order bit of the receiver, or zero if the    
	 receiver is zero. This method is allowed (and needed) for     
	LargeNegativeIntegers as well, since Squeak's LargeIntegers are     
	sign/magnitude."
	| realLength lastDigit |
	<var: #pByte type: 'unsigned char *  '>
	realLength := len.
	[(lastDigit := pByte at: realLength - 1) = 0]
		whileTrue: [(realLength := realLength - 1) = 0 ifTrue: [^ 0]].
	^  (self cHighBit: lastDigit) + (8 * (realLength - 1))! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:59'!
cBytesLshift: shiftCount from: pFrom len: lenFrom to: pTo len: lenTo 
	"C indexed!!"
	| byteShift bitShift carry rShift mask limit digit lastIx |
	<returnTypeC: 'int'>
	<var: #pTo type: 'unsigned char * '>
	<var: #pFrom type: 'unsigned char * '>
	byteShift := shiftCount // 8.
	bitShift := shiftCount \\ 8.
	bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts"
		"C indexed!!"
		^ self
			cBytesReplace: pTo
			from: byteShift
			to: lenTo - 1
			with: pFrom
			startingAt: 0].
	carry := 0.
	rShift := bitShift - 8.
	mask := 255 bitShift: 0 - bitShift.
	limit := byteShift - 1.
	0 to: limit do: [:i | pTo at: i put: 0].
	limit := lenTo - byteShift - 2.
	self sqAssert: limit < lenFrom.
	0 to: limit do: 
		[:i | 
		digit := pFrom at: i.
		pTo at: i + byteShift put: (((digit bitAnd: mask)
				bitShift: bitShift)
				bitOr: carry).
		carry := digit bitShift: rShift].
	lastIx := limit + 1.
	lastIx > (lenFrom - 1)
		ifTrue: [digit := 0]
		ifFalse: [digit := pFrom at: lastIx].
	pTo at: lastIx + byteShift put: (((digit bitAnd: mask)
			bitShift: bitShift)
			bitOr: carry).
	carry := digit bitShift: rShift.
	self sqAssert: carry = 0! !
!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:59'!
cBytesReplace: pTo from: start to: stop with: pFrom startingAt: repStart 
	"C indexed!!"
	<returnTypeC: 'int'>
	<var: #pTo type: 'unsigned char * '>
	<var: #pFrom type: 'unsigned char * '>
	^ self
		cBytesCopyFrom: pFrom + repStart
		to: pTo + start
		len: stop - start + 1! !
!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:56'!
cCopyIntVal: val toBytes: bytes 
	| pByte |
	<var: #pByte type: 'unsigned char *  '>
	pByte := interpreterProxy firstIndexableField: bytes.
	1 to: (self cDigitLengthOfCSI: val)
		do: [:ix | pByte at: ix - 1 put: (self cDigitOfCSI: val at: ix)]! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:56'!
cCoreBytesRshiftCount: count n: n m: m f: f bytes: b from: pFrom len: fromLen to: pTo len: toLen 
	| x digit |
	<var: #pTo type: 'unsigned char * '>
	<var: #pFrom type: 'unsigned char * '>
	self sqAssert: b < fromLen.
	x := (pFrom at: b)
				bitShift: n.
	self sqAssert: count - 1 < fromLen.
	b + 1 to: count - 1 do: 
		[:j | 
		digit := pFrom at: j.
		pTo at: j - b - 1 put: (((digit bitAnd: m)
				bitShift: f)
				bitOr: x).
		"Avoid values > 8 bits"
		x := digit bitShift: n].
	count = fromLen
				ifTrue: [digit := 0]
				ifFalse: [digit := pFrom at: count].
	pTo at: count - b - 1 put: (((digit bitAnd: m)
			bitShift: f)
			bitOr: x)! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:56'!
cCoreDigitDivDiv: pDiv len: divLen rem: pRem len: remLen quo: pQuo len: quoLen 
	| dl ql dh dnh j t hi lo r3 l a cond q r1r2 mul |
	<var: #pDiv type: 'unsigned char * '>
	<var: #pRem type: 'unsigned char * '>
	<var: #pQuo type: 'unsigned char * '>
	dl := divLen - 1.
	"Last actual byte of data (ST ix)"
	ql := quoLen.
	dh := pDiv at: dl - 1.
	dl = 1
		ifTrue: [dnh := 0]
		ifFalse: [dnh := pDiv at: dl - 2].
	1 to: ql do: 
		[:k | 
		"maintain quo*arg+rem=self"
		"Estimate rem/div by dividing the leading two bytes of rem by dh."
		"The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles."
		"Nibbles are kicked off!! We use full 16 bits now, because we are in  
		the year 2000 ;-) [sr]"
		j := remLen + 1 - k.
		"r1 := rem digitAt: j."
		(pRem at: j - 1)
			= dh
			ifTrue: [q := 255]
			ifFalse: 
				["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.                
				Note that r1,r2 are bytes, not nibbles.                
				Be careful not to generate intermediate results exceeding 13  
				            bits."
				"r2 := (rem digitAt: j - 2)."
				r1r2 := ((pRem at: j - 1)
							bitShift: 8)
							+ (pRem at: j - 2).
				t := r1r2 \\ dh.
				q := r1r2 // dh.
				"Next compute (hi,lo) := q*dnh"
				mul := q * dnh.
				hi := mul bitShift: -8.
				lo := mul bitAnd: 255.
				"Correct overestimate of q.                
				Max of 2 iterations through loop -- see Knuth vol. 2"
				j < 3
					ifTrue: [r3 := 0]
					ifFalse: [r3 := pRem at: j - 3].
				
				[(t < hi
					or: [t = hi and: [r3 < lo]])
					ifTrue: 
						["i.e. (t,r3) < (hi,lo)"
						q := q - 1.
						lo := lo - dnh.
						lo < 0
							ifTrue: 
								[hi := hi - 1.
								lo := lo + 256].
						cond := hi >= dh]
					ifFalse: [cond := false].
				cond]
					whileTrue: [hi := hi - dh]].
		"Subtract q*div from rem"
		l := j - dl.
		a := 0.
		1 to: divLen do: 
			[:i | 
			hi := (pDiv at: i - 1)
						* (q bitShift: -8).
			lo := a + (pRem at: l - 1) - ((pDiv at: i - 1)
							* (q bitAnd: 255)).
			"pRem at: l - 1 put: lo - (lo // 256 * 256)."
			"sign-tolerant form of (lo bitAnd: 255) -> obsolete..."
			pRem at: l - 1 put: (lo bitAnd: 255).
			"... is sign-tolerant!! [sr]"
			a := lo // 256 - hi.
			l := l + 1].
		a < 0
			ifTrue: 
				["Add div back into rem, decrease q by 1"
				q := q - 1.
				l := j - dl.
				a := 0.
				1 to: divLen do: 
					[:i | 
					a := (a bitShift: -8)
								+ (pRem at: l - 1) + (pDiv at: i - 1).
					pRem at: l - 1 put: (a bitAnd: 255).
					l := l + 1]].
		pQuo at: quoLen - k put: q]! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:58'!
cDigitAdd: pByteShort len: shortLen with: pByteLong len: longLen into: pByteRes 
	"pByteRes len = longLen; returns over.."
	| accum limit |
	<returnTypeC: 'unsigned char'>
	<var: #pByteShort type: 'unsigned char * '>
	<var: #pByteLong type: 'unsigned char * '>
	<var: #pByteRes type: 'unsigned char * '>
	accum := 0.
	limit := shortLen - 1.
	0 to: limit do: 
		[:i | 
		accum := (accum bitShift: -8)
					+ (pByteShort at: i) + (pByteLong at: i).
		pByteRes at: i put: (accum bitAnd: 255)].
	limit := longLen - 1.
	shortLen to: limit do: 
		[:i | 
		accum := (accum bitShift: -8)
					+ (pByteLong at: i).
		pByteRes at: i put: (accum bitAnd: 255)].
	^ accum bitShift: -8! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:57'!
cDigitCompare: pFirst with: pSecond len: len 
	"Precondition: pFirst len = pSecond len."
	| secondDigit ix firstDigit |
	<var: #pFirst type: 'unsigned char * '>
	<var: #pSecond type: 'unsigned char * '>
	ix := len - 1.
	[ix >= 0]
		whileTrue: 
			[(secondDigit := pSecond at: ix) ~= (firstDigit := pFirst at: ix)
				ifTrue: [secondDigit < firstDigit
						ifTrue: [^ 1]
						ifFalse: [^ -1]].
			ix := ix - 1].
	^ 0! !
!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'tpr 12/29/2005 16:59'!
cDigitLengthOfCSI: csi 
	"Answer the number of indexable fields of a CSmallInteger. This value is 
	   the same as the largest legal subscript."
	(csi < 256 and: [csi > -256])
		ifTrue: [^ 1].
	(csi < 65536 and: [csi > -65536])
		ifTrue: [^ 2].
	(csi < 16777216 and: [csi > -16777216])
		ifTrue: [^ 3].
	^ 4! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:58'!
cDigitMultiply: pByteShort len: shortLen with: pByteLong len: longLen into: pByteRes 
	| limitLong digit k carry limitShort ab |
	<returnTypeC: 'unsigned char'>
	<var: #pByteShort type: 'unsigned char * '>
	<var: #pByteLong type: 'unsigned char * '>
	<var: #pByteRes type: 'unsigned char * '>
	(shortLen = 1 and: [(pByteShort at: 0)
			= 0])
		ifTrue: [^ 0].
	(longLen = 1 and: [(pByteLong at: 0)
			= 0])
		ifTrue: [^ 0].
	"prod starts out all zero"
	limitShort := shortLen - 1.
	0 to: limitShort do: [:i | (digit := pByteShort at: i) ~= 0
			ifTrue: 
				[k := i.
				carry := 0.
				"Loop invariant: 0<=carry<=0377, k=i+j-1 (ST)"
				"-> Loop invariant: 0<=carry<=0377, k=i+j (C) (?)"
				limitLong := longLen - 1.
				0 to: limitLong do: 
					[:j | 
					ab := (pByteLong at: j)
								* digit + carry + (pByteRes at: k).
					carry := ab bitShift: -8.
					pByteRes at: k put: (ab bitAnd: 255).
					k := k + 1].
				pByteRes at: k put: carry]].
	^ 0! !
!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'sr 12/23/1999 15:12'!
cDigitOfCSI: csi at: ix 
	"Answer the value of an indexable field in the receiver.              
	LargePositiveInteger uses bytes of base two number, and each is a       
	      'digit' base 256."
	"ST indexed!!"
	ix < 0 ifTrue: [interpreterProxy primitiveFail].
	ix > 4 ifTrue: [^ 0].
	csi < 0
		ifTrue: 
			[self cCode: ''
				inSmalltalk: [csi = -1073741824 ifTrue: ["SmallInteger minVal"
						"Can't negate minVal -- treat specially"
						^ #(0 0 0 64 ) at: ix]].
			^ (0 - csi bitShift: 1 - ix * 8)
				bitAnd: 255]
		ifFalse: [^ (csi bitShift: 1 - ix * 8)
				bitAnd: 255]! !
!LargeIntegersPlugin methodsFor: 'C core' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:59'!
cDigitSub: pByteSmall
		len: smallLen
		with: pByteLarge
		len: largeLen
		into: pByteRes
	| z limit |
	<var: #pByteSmall type: 'unsigned char * '>
	<var: #pByteLarge type: 'unsigned char * '>
	<var: #pByteRes type: 'unsigned char * '>

	z := 0.
	"Loop invariant is -1<=z<=1"
	limit := smallLen - 1.
	0 to: limit do: 
		[:i | 
		z := z + (pByteLarge at: i) - (pByteSmall at: i).
		pByteRes at: i put: z - (z // 256 * 256).
		"sign-tolerant form of (z bitAnd: 255)"
		z := z // 256].
	limit := largeLen - 1.
	smallLen to: limit do: 
		[:i | 
		z := z + (pByteLarge at: i) .
		pByteRes at: i put: z - (z // 256 * 256).
		"sign-tolerant form of (z bitAnd: 255)"
		z := z // 256].
! !
!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:00'!
cHighBit: uint 
	"Answer the index of the high order bit of the argument, or zero if the  
	argument is zero."
	"For 64 bit uints there could be added a 32-shift."
	| shifted bitNo |

	<var: #shifted type: 'unsigned int  '>
	shifted := uint.
	bitNo := 0.
	shifted < (1 << 16)
		ifFalse: [shifted := shifted bitShift: -16.
			bitNo := bitNo + 16].
	shifted < (1 << 8)
		ifFalse: [shifted := shifted bitShift: -8.
			bitNo := bitNo + 8].
	shifted < (1 << 4)
		ifFalse: [shifted := shifted bitShift: -4.
			bitNo := bitNo + 4].
	shifted < (1 << 2)
		ifFalse: [shifted := shifted bitShift: -2.
			bitNo := bitNo + 2].
	shifted < (1 << 1)
		ifFalse: [shifted := shifted bitShift: -1.
			bitNo := bitNo + 1].
	"shifted 0 or 1 now"
	^ bitNo + shifted! !
!LargeIntegersPlugin methodsFor: 'oop util' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:00'!
createLargeFromSmallInteger: anOop 
	"anOop has to be a SmallInteger!!"
	| val class size res pByte |
	<var: #pByte type: 'unsigned char *  '>
	val := interpreterProxy integerValueOf: anOop.
	val < 0
		ifTrue: [class := interpreterProxy classLargeNegativeInteger]
		ifFalse: [class := interpreterProxy classLargePositiveInteger].
	size := self cDigitLengthOfCSI: val.
	res := interpreterProxy instantiateClass: class indexableSize: size.
	pByte := interpreterProxy firstIndexableField: res.
	1 to: size do: [:ix | pByte at: ix - 1 put: (self cDigitOfCSI: val at: ix)].
	^ res! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:00'!
digitAddLarge: firstInteger with: secondInteger 
	"Does not need to normalize!!"
	| over firstLen secondLen shortInt shortLen longInt longLen sum newSum resClass |
	<var: #over type: 'unsigned char  '>
	firstLen := self byteSizeOfBytes: firstInteger.
	secondLen := self byteSizeOfBytes: secondInteger.
	resClass := interpreterProxy fetchClassOf: firstInteger.
	firstLen <= secondLen
		ifTrue: 
			[shortInt := firstInteger.
			shortLen := firstLen.
			longInt := secondInteger.
			longLen := secondLen]
		ifFalse: 
			[shortInt := secondInteger.
			shortLen := secondLen.
			longInt := firstInteger.
			longLen := firstLen].
	"	sum := Integer new: len neg: firstInteger negative."
	self remapOop: #(shortInt longInt ) in: [sum := interpreterProxy instantiateClass: resClass indexableSize: longLen].
	over := self
				cDigitAdd: (interpreterProxy firstIndexableField: shortInt)
				len: shortLen
				with: (interpreterProxy firstIndexableField: longInt)
				len: longLen
				into: (interpreterProxy firstIndexableField: sum).
	over > 0
		ifTrue: 
			["sum := sum growby: 1."
			interpreterProxy remapOop: sum in: [newSum := interpreterProxy instantiateClass: resClass indexableSize: longLen + 1].
			self
				cBytesCopyFrom: (interpreterProxy firstIndexableField: sum)
				to: (interpreterProxy firstIndexableField: newSum)
				len: longLen.
			sum := newSum.
			"C index!!"
			(self cCoerce: (interpreterProxy firstIndexableField: sum)
				to: 'unsigned char *')
				at: longLen put: over].
	^ sum! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 6/8/2004 05:09'!
digitBitLogic: firstInteger with: secondInteger opIndex: opIx 
	"Bit logic here is only implemented for positive integers or Zero;
	if rec or arg is negative, it fails."
	| firstLarge secondLarge firstLen secondLen shortLen shortLarge longLen longLarge result |
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: 
			[(interpreterProxy integerValueOf: firstInteger)
				< 0 ifTrue: [^ interpreterProxy primitiveFail].
			"convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: 
			[(interpreterProxy fetchClassOf: firstInteger)
				= interpreterProxy classLargeNegativeInteger ifTrue: [^ interpreterProxy primitiveFail].
			firstLarge := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: 
			[(interpreterProxy integerValueOf: secondInteger)
				< 0 ifTrue: [^ interpreterProxy primitiveFail].
			"convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: 
			[(interpreterProxy fetchClassOf: secondInteger)
				= interpreterProxy classLargeNegativeInteger ifTrue: [^ interpreterProxy primitiveFail].
			secondLarge := secondInteger].
	firstLen := self byteSizeOfBytes: firstLarge.
	secondLen := self byteSizeOfBytes: secondLarge.
	firstLen < secondLen
		ifTrue: 
			[shortLen := firstLen.
			shortLarge := firstLarge.
			longLen := secondLen.
			longLarge := secondLarge]
		ifFalse: 
			[shortLen := secondLen.
			shortLarge := secondLarge.
			longLen := firstLen.
			longLarge := firstLarge].
	self remapOop: #(shortLarge longLarge ) in: [result := interpreterProxy instantiateClass: interpreterProxy classLargePositiveInteger indexableSize: longLen].
	self
		cByteOp: opIx
		short: (interpreterProxy firstIndexableField: shortLarge)
		len: shortLen
		long: (interpreterProxy firstIndexableField: longLarge)
		len: longLen
		into: (interpreterProxy firstIndexableField: result).
	interpreterProxy failed ifTrue: [^ 0].
	^ self normalizePositive: result! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:45'!
digitCompareLarge: firstInteger with: secondInteger 
	"Compare the magnitude of firstInteger with that of secondInteger.      
	Return a code of 1, 0, -1 for firstInteger >, = , < secondInteger"
	| firstLen secondLen |
	firstLen := self byteSizeOfBytes: firstInteger.
	secondLen := self byteSizeOfBytes: secondInteger.
	secondLen ~= firstLen
		ifTrue: [secondLen > firstLen
				ifTrue: [^ -1 asOop: SmallInteger]
				ifFalse: [^ 1 asOop: SmallInteger]].
	^ (self
		cDigitCompare: (interpreterProxy firstIndexableField: firstInteger)
		with: (interpreterProxy firstIndexableField: secondInteger)
		len: firstLen)
		asOop: SmallInteger! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:45'!
digitDivLarge: firstInteger with: secondInteger negative: neg 
	"Does not normalize."
	"Division by zero has to be checked in caller."
	| firstLen secondLen resultClass l d div rem quo result |
	firstLen := self byteSizeOfBytes: firstInteger.
	secondLen := self byteSizeOfBytes: secondInteger.
	neg
		ifTrue: [resultClass := interpreterProxy classLargeNegativeInteger]
		ifFalse: [resultClass := interpreterProxy classLargePositiveInteger].
	l := firstLen - secondLen + 1.
	l <= 0
		ifTrue: 
			[self remapOop: firstInteger in: [result := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 2].
			result stAt: 1 put: (0 asOop: SmallInteger).
			result stAt: 2 put: firstInteger.
			^ result].
	"set rem and div to copies of firstInteger and secondInteger, respectively. 
	  However,  
	 to facilitate use of Knuth's algorithm, multiply rem and div by 2 (that 
	 is, shift)   
	 until the high byte of div is >=128"
	d := 8 - (self cHighBit: (self unsafeByteOf: secondInteger at: secondLen)).
	self remapOop: firstInteger
		in: 
			[div := self bytes: secondInteger Lshift: d.
			div := self bytesOrInt: div growTo: (self digitLength: div)
							+ 1].
	self remapOop: div
		in: 
			[rem := self bytes: firstInteger Lshift: d.
			(self digitLength: rem)
				= firstLen ifTrue: [rem := self bytesOrInt: rem growTo: firstLen + 1]].
	self remapOop: #(div rem ) in: [quo := interpreterProxy instantiateClass: resultClass indexableSize: l].
	self
		cCoreDigitDivDiv: (interpreterProxy firstIndexableField: div)
		len: (self digitLength: div)
		rem: (interpreterProxy firstIndexableField: rem)
		len: (self digitLength: rem)
		quo: (interpreterProxy firstIndexableField: quo)
		len: (self digitLength: quo).
	self remapOop: #(quo ) in: [rem := self
					bytes: rem
					Rshift: d
					bytes: 0
					lookfirst: (self digitLength: div)
							- 1].
	"^ Array with: quo with: rem"
	self remapOop: #(quo rem ) in: [result := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 2].
	result stAt: 1 put: quo.
	result stAt: 2 put: rem.
	^ result! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 3/11/2000 19:46'!
digitLength: oop 
	(interpreterProxy isIntegerObject: oop)
		ifTrue: [^ self cDigitLengthOfCSI: (interpreterProxy integerValueOf: oop)]
		ifFalse: [^ self byteSizeOfBytes: oop]! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:46'!
digitMultiplyLarge: firstInteger with: secondInteger negative: neg 
	"Normalizes."
	| firstLen secondLen shortInt shortLen longInt longLen prod resultClass |
	firstLen := self byteSizeOfBytes: firstInteger.
	secondLen := self byteSizeOfBytes: secondInteger.
	firstLen <= secondLen
		ifTrue: 
			[shortInt := firstInteger.
			shortLen := firstLen.
			longInt := secondInteger.
			longLen := secondLen]
		ifFalse: 
			[shortInt := secondInteger.
			shortLen := secondLen.
			longInt := firstInteger.
			longLen := firstLen].
	neg
		ifTrue: [resultClass := interpreterProxy classLargeNegativeInteger]
		ifFalse: [resultClass := interpreterProxy classLargePositiveInteger].
	self remapOop: #(shortInt longInt ) in: [prod := interpreterProxy instantiateClass: resultClass indexableSize: longLen + shortLen].
	self
		cDigitMultiply: (interpreterProxy firstIndexableField: shortInt)
		len: shortLen
		with: (interpreterProxy firstIndexableField: longInt)
		len: longLen
		into: (interpreterProxy firstIndexableField: prod).
	^ self normalize: prod! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 1/23/2000 18:10'!
digitOf: oop at: ix 
	(interpreterProxy isIntegerObject: oop)
		ifTrue: [^ self cDigitOfCSI: (interpreterProxy integerValueOf: oop)
				at: ix]
		ifFalse: [^ self digitOfBytes: oop at: ix]! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 3/11/2000 19:46'!
digitOfBytes: aBytesOop at: ix 
	"Argument has to be aLargeInteger!!"
	ix > (self byteSizeOfBytes: aBytesOop)
		ifTrue: [^ 0]
		ifFalse: [^ self unsafeByteOf: aBytesOop at: ix]! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'eem 10/4/2010 10:19'!
digitSubLarge: firstInteger with: secondInteger 
	"Normalizes."
	| firstLen secondLen larger largerLen smaller smallerLen neg resLen res firstNeg |
	firstNeg := (interpreterProxy fetchClassOf: firstInteger)
				= interpreterProxy classLargeNegativeInteger.
	firstLen := self byteSizeOfBytes: firstInteger.
	secondLen := self byteSizeOfBytes: secondInteger.
	firstLen = secondLen ifTrue: 
		[[firstLen > 1
		  and: [(self digitOfBytes: firstInteger at: firstLen) = (self digitOfBytes: secondInteger at: firstLen)]]
			whileTrue: [firstLen := firstLen - 1].
		secondLen := firstLen].
	(firstLen < secondLen
	 or: [firstLen = secondLen
		 and: [(self digitOfBytes: firstInteger at: firstLen) < (self digitOfBytes: secondInteger at: firstLen)]])
		ifTrue: 
			[larger := secondInteger.
			largerLen := secondLen.
			smaller := firstInteger.
			smallerLen := firstLen.
			neg := firstNeg == false]
		ifFalse: 
			[larger := firstInteger.
			largerLen := firstLen.
			smaller := secondInteger.
			smallerLen := secondLen.
			neg := firstNeg].
	resLen := largerLen.
	self remapOop: #(smaller larger)
		in: [res := interpreterProxy
					instantiateClass: (neg
										ifTrue: [interpreterProxy classLargeNegativeInteger]
										ifFalse: [interpreterProxy classLargePositiveInteger])
					indexableSize: resLen].
	self
		cDigitSub: (interpreterProxy firstIndexableField: smaller)
		len: smallerLen
		with: (interpreterProxy firstIndexableField: larger)
		len: largerLen
		into: (interpreterProxy firstIndexableField: res).
	^neg 
		ifTrue: [self normalizeNegative: res]
		ifFalse: [self normalizePositive: res]! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 6/9/2000 00:24'!
highBitOfBytes: aBytesOop 
	^ self cBytesHighBit: (interpreterProxy firstIndexableField: aBytesOop)
		len: (self byteSizeOfBytes: aBytesOop)! !
!LargeIntegersPlugin methodsFor: 'ST initialize' stamp: 'sr (auto pragmas 12/08) 3/15/2000 00:57'!
initialize
	"Initializes ST constants; C's are set by class>>declareCVarsIn:."
	<returnTypeC: 'void'>
	self cCode: '"nothing to do here"'
		inSmalltalk: 
			[andOpIndex := 0.
			orOpIndex := 1.
			xorOpIndex := 2]! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 5/28/2004 16:25'!
isNormalized: anInteger 
	| len maxVal minVal sLen |
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: [^ true].
	"Check for leading zero of LargeInteger"
	len := self digitLength: anInteger.
	len = 0
		ifTrue: [^ false].
	(self unsafeByteOf: anInteger at: len)
			= 0
		ifTrue: [^ false].
	"no leading zero, now check if anInteger is in SmallInteger range or not"
	sLen := 4.
	"maximal digitLength of aSmallInteger"
	len > sLen
		ifTrue: [^ true].
	len < sLen
		ifTrue: [^ false].
	"len = sLen"
	(interpreterProxy fetchClassOf: anInteger)
			= interpreterProxy classLargePositiveInteger
		ifTrue: [maxVal := 1073741823. "SmallInteger maxVal"
				"all bytes of maxVal but the highest one are just FF's"
				^ (self unsafeByteOf: anInteger at: sLen)
					> (self cDigitOfCSI: maxVal at: sLen)]
		ifFalse: [minVal := -1073741824. "SmallInteger minVal"
				"all bytes of minVal but the highest one are just 00's"
			(self unsafeByteOf: anInteger at: sLen)
					< (self cDigitOfCSI: minVal at: sLen)
				ifTrue: [^ false]
				ifFalse: ["if just one digit differs, then anInteger < minval (the corresponding digit byte is greater!!)
						and therefore a LargeNegativeInteger"
					1
						to: sLen
						do: [:ix | (self unsafeByteOf: anInteger at: ix)
									= (self cDigitOfCSI: minVal at: ix)
								ifFalse: [^ true]]]].
	^ false! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 6/9/2000 00:31'!
negative: aLarge 
	^ (interpreterProxy fetchClassOf: aLarge)
		= interpreterProxy classLargeNegativeInteger! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 6/9/2000 04:02'!
normalize: aLargeInteger 
	"Check for leading zeroes and return shortened copy if so."
	self debugCode: [self msg: 'normalize: aLargeInteger'].
	(interpreterProxy fetchClassOf: aLargeInteger)
		= interpreterProxy classLargePositiveInteger
		ifTrue: [^ self normalizePositive: aLargeInteger]
		ifFalse: [^ self normalizeNegative: aLargeInteger]! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 6/8/2004 05:08'!
normalizeNegative: aLargeNegativeInteger 
	"Check for leading zeroes and return shortened copy if so."
	"First establish len = significant length."
	| sLen val len oldLen minVal |
	len := oldLen := self digitLength: aLargeNegativeInteger.
	[len ~= 0 and: [(self unsafeByteOf: aLargeNegativeInteger at: len)
			= 0]]
		whileTrue: [len := len - 1].
	len = 0 ifTrue: [^ 0 asOop: SmallInteger].
	"Now check if in SmallInteger range"
	sLen := 4.
	"SmallInteger minVal digitLength"
	len <= sLen
		ifTrue: 
			["SmallInteger minVal"
			minVal := -1073741824.
			(len < sLen or: [(self digitOfBytes: aLargeNegativeInteger at: sLen)
					< (self cDigitOfCSI: minVal at: sLen)
				"minVal lastDigit"])
				ifTrue: 
					["If high digit less, then can be small"
					val := 0.
					len
						to: 1
						by: -1
						do: [:i | val := val * 256 - (self unsafeByteOf: aLargeNegativeInteger at: i)].
					^ val asOop: SmallInteger].
			1 to: sLen do: [:i | "If all digits same, then = minVal (sr: minVal digits 1 to 3 are 
				          0)"
				(self digitOfBytes: aLargeNegativeInteger at: i)
					= (self cDigitOfCSI: minVal at: i)
					ifFalse: ["Not so; return self shortened"
						len < oldLen
							ifTrue: ["^ self growto: len"
								^ self bytes: aLargeNegativeInteger growTo: len]
							ifFalse: [^ aLargeNegativeInteger]]].
			^ minVal asOop: SmallInteger].
	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: ["^ self growto: len"
			^ self bytes: aLargeNegativeInteger growTo: len]
		ifFalse: [^ aLargeNegativeInteger]! !
!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 6/8/2004 05:08'!
normalizePositive: aLargePositiveInteger 
	"Check for leading zeroes and return shortened copy if so."
	"First establish len = significant length."
	| sLen val len oldLen |
	len := oldLen := self digitLength: aLargePositiveInteger.
	[len ~= 0 and: [(self unsafeByteOf: aLargePositiveInteger at: len)
			= 0]]
		whileTrue: [len := len - 1].
	len = 0 ifTrue: [^ 0 asOop: SmallInteger].
	"Now check if in SmallInteger range"
	sLen := 4.
	"SmallInteger maxVal digitLength."
	(len <= sLen and: [(self digitOfBytes: aLargePositiveInteger at: sLen)
			<= (self cDigitOfCSI: 1073741823 at: sLen)
		"SmallInteger maxVal"])
		ifTrue: 
			["If so, return its SmallInt value"
			val := 0.
			len
				to: 1
				by: -1
				do: [:i | val := val * 256 + (self unsafeByteOf: aLargePositiveInteger at: i)].
			^ val asOop: SmallInteger].
	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: ["^ self growto: len"
			^ self bytes: aLargePositiveInteger growTo: len]
		ifFalse: [^ aLargePositiveInteger]! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/9/2000 10:25'!
primAnyBitFrom: from to: to 
	| integer large |
	self debugCode: [self msg: 'primAnyBitFrom: from to: to'].
	integer := self
				primitive: 'primAnyBitFromTo'
				parameters: #(#SmallInteger #SmallInteger )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: integer)
		ifTrue: ["convert it to a not normalized LargeInteger"
			large := self createLargeFromSmallInteger: integer]
		ifFalse: [large := integer].
	^ (self
		anyBitOfBytes: large
		from: from
		to: to)
		asOop: Boolean! !
!LargeIntegersPlugin methodsFor: 'control & support primitives' stamp: 'sr 4/8/2000 02:13'!
primAsLargeInteger: anInteger
	"Converts a SmallInteger into a - non normalized!! - LargeInteger;          
	 aLargeInteger will be returned unchanged."
	"Do not check for forced fail, because we need this conversion to test the 
	plugin in ST during forced fail, too."
	self debugCode: [self msg: 'primAsLargeInteger: anInteger'].
	self
		primitive: 'primAsLargeInteger'
		parameters: #(Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: [^ self createLargeFromSmallInteger: anInteger]
		ifFalse: [^ anInteger]! !
!LargeIntegersPlugin methodsFor: 'obsolete' stamp: 'sr 12/27/1999 19:00'!
primCheckIfCModuleExists
	"If calling this primitive fails, then C module does not exist. Do not check for forced fail, because we want to know if module exists during forced fail, too."
	self
		primitive: 'primCheckIfCModuleExists'
		parameters: #()
		receiver: #Oop.
	^ true asOop: Boolean! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'ar 4/4/2006 20:56'!
primDigit: anInteger bitShift: shiftCount 
	| rShift aLarge |
	self debugCode: [self msg: 'primDigit: anInteger bitShift: shiftCount'].
	self
		primitive: '_primDigitBitShift'
		parameters: #(Integer SmallInteger )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			aLarge := self createLargeFromSmallInteger: anInteger]
		ifFalse: [aLarge := anInteger].
	shiftCount >= 0
		ifTrue: [^ self bytes: aLarge Lshift: shiftCount]
		ifFalse: 
			[rShift := 0 - shiftCount.
			^ self normalize: (self
					bytes: aLarge
					Rshift: (rShift bitAnd: 7)
					bytes: (rShift bitShift: -3)
					lookfirst: (self byteSizeOfBytes: aLarge))]! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/8/2004 04:49'!
primDigitAdd: secondInteger
	| firstLarge secondLarge firstInteger |
	self debugCode: [self msg: 'primDigitAdd: secondInteger'].
	firstInteger := self
				primitive: 'primDigitAdd'
				parameters: #(Integer )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge := secondInteger].
	^ self digitAddLarge: firstLarge with: secondLarge! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 6/8/2004 04:59'!
primDigitAdd: firstInteger with: secondInteger 
	| firstLarge secondLarge |
	self debugCode: [self msg: 'primDigitAdd: firstInteger with: secondInteger'].
	self
		primitive: 'primDigitAddWith'
		parameters: #(Integer Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge := secondInteger].
	^ self digitAddLarge: firstLarge with: secondLarge! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:07'!
primDigitBitAnd: secondInteger 
	"Bit logic here is only implemented for positive integers or Zero; if rec 
	or arg is negative, it fails."
	| firstInteger |
	self debugCode: [self msg: 'primDigitBitAnd: secondInteger'].
	firstInteger := self
				primitive: 'primDigitBitAnd'
				parameters: #(Integer )
				receiver: #Integer.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: andOpIndex! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:07'!
primDigitBitLogic: firstInteger with: secondInteger op: opIndex 
	"Bit logic here is only implemented for positive integers or Zero; if any arg is negative, it fails."
	self debugCode: [self msg: 'primDigitBitLogic: firstInteger with: secondInteger op: opIndex'].
	self
		primitive: 'primDigitBitLogicWithOp'
		parameters: #(Integer Integer SmallInteger )
		receiver: #Oop.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: opIndex! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:07'!
primDigitBitOr: secondInteger 
	"Bit logic here is only implemented for positive integers or Zero; if rec 
	or arg is negative, it fails."
	| firstInteger |
	self debugCode: [self msg: 'primDigitBitOr: secondInteger'].
	firstInteger := self
				primitive: 'primDigitBitOr'
				parameters: #(Integer )
				receiver: #Integer.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: orOpIndex! !
!LargeIntegersPlugin methodsFor: 'obsolete' stamp: 'sr 4/8/2000 02:08'!
primDigitBitShift: shiftCount 
	| rShift aLarge anInteger |
	self debugCode: [self msg: 'primDigitBitShift: shiftCount'].
	anInteger := self
				primitive: 'primDigitBitShift'
				parameters: #(SmallInteger )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			aLarge := self createLargeFromSmallInteger: anInteger]
		ifFalse: [aLarge := anInteger].
	shiftCount >= 0
		ifTrue: [^ self bytes: aLarge Lshift: shiftCount]
		ifFalse: 
			[rShift := 0 - shiftCount.
			^ self normalize: (self
					bytes: aLarge
					Rshift: (rShift bitAnd: 7)
					bytes: (rShift bitShift: -3)
					lookfirst: (self byteSizeOfBytes: aLarge))]! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/9/2000 10:49'!
primDigitBitShiftMagnitude: shiftCount 
	| rShift aLarge anInteger |
	self debugCode: [self msg: 'primDigitBitShiftMagnitude: shiftCount'].
	anInteger := self
				primitive: 'primDigitBitShiftMagnitude'
				parameters: #(#SmallInteger )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			aLarge := self createLargeFromSmallInteger: anInteger]
		ifFalse: [aLarge := anInteger].
	shiftCount >= 0
		ifTrue: [^ self bytes: aLarge Lshift: shiftCount]
		ifFalse: 
			[rShift := 0 - shiftCount.
			^ self normalize: (self
					bytes: aLarge
					Rshift: (rShift bitAnd: 7)
					bytes: (rShift bitShift: -3)
					lookfirst: (self byteSizeOfBytes: aLarge))]! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:08'!
primDigitBitXor: secondInteger 
	"Bit logic here is only implemented for positive integers or Zero; if rec 
	or arg is negative, it fails."
	| firstInteger |
	self debugCode: [self msg: 'primDigitBitXor: secondInteger'].
	firstInteger := self
				primitive: 'primDigitBitXor'
				parameters: #(Integer )
				receiver: #Integer.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: xorOpIndex! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/8/2004 04:50'!
primDigitCompare: secondInteger 
	| firstVal secondVal firstInteger |
	self debugCode: [self msg: 'primDigitCompare: secondInteger'].
	firstInteger := self
				primitive: 'primDigitCompare'
				parameters: #(#Integer )
				receiver: #Integer.
	"shortcut: aSmallInteger has to be smaller in Magnitude as aLargeInteger"
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["first"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second"
					(firstVal := interpreterProxy integerValueOf: firstInteger) > (secondVal := interpreterProxy integerValueOf: secondInteger)
						ifTrue: [^ 1 asOop: SmallInteger"first > second"]
						ifFalse: [firstVal < secondVal
								ifTrue: [^ -1 asOop: SmallInteger"first < second"]
								ifFalse: [^ 0 asOop: SmallInteger"first = second"]]]
				ifFalse: ["SECOND"
					^ -1 asOop: SmallInteger"first < SECOND"]]
		ifFalse: ["FIRST"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second"
					^ 1 asOop: SmallInteger"FIRST > second"]
				ifFalse: ["SECOND"
					^ self digitCompareLarge: firstInteger with: secondInteger]]! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:08'!
primDigitCompare: firstInteger with: secondInteger 
	| firstVal secondVal |
	self debugCode: [self msg: 'primDigitCompare: firstInteger with: secondInteger'].
	self
		primitive: 'primDigitCompareWith'
		parameters: #(Integer Integer )
		receiver: #Oop.
	"shortcut: aSmallInteger has to be smaller in Magnitude as aLargeInteger"
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["first"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second"
					(firstVal := interpreterProxy integerValueOf: firstInteger) > (secondVal := interpreterProxy integerValueOf: secondInteger)
						ifTrue: [^ 1 asOop: SmallInteger"first > second"]
						ifFalse: [firstVal < secondVal
								ifTrue: [^ -1 asOop: SmallInteger"first < second"]
								ifFalse: [^ 0 asOop: SmallInteger"first = second"]]]
				ifFalse: ["SECOND" ^ -1 asOop: SmallInteger"first < SECOND"]]
		ifFalse: ["FIRST"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second" ^ 1 asOop: SmallInteger"FIRST > second"]
				ifFalse: ["SECOND"
					^ self digitCompareLarge: firstInteger with: secondInteger]]! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/8/2004 04:51'!
primDigitDiv: secondInteger negative: neg 
	"Answer the result of dividing firstInteger by secondInteger. 
	Fail if parameters are not integers, not normalized or secondInteger is 
	zero. "
	| firstAsLargeInteger secondAsLargeInteger firstInteger |
	self debugCode: [self msg: 'primDigitDiv: secondInteger negative: neg'].
	firstInteger := self
				primitive: 'primDigitDivNegative'
				parameters: #(#Integer #Boolean )
				receiver: #Integer.
	"Avoid crashes in case of getting unnormalized args."
	(self isNormalized: firstInteger)
		ifFalse: [self
				debugCode: [self msg: 'ERROR in primDigitDiv: secondInteger negative: neg'.
					self msg: '------> receiver *not* normalized!!'].
			^ interpreterProxy primitiveFail].
	(self isNormalized: secondInteger)
		ifFalse: [self
				debugCode: [self msg: 'ERROR in primDigitDiv: secondInteger negative: neg'.
					self msg: '------> argument *not* normalized!!'].
			^ interpreterProxy primitiveFail].
	"Coerce SmallIntegers to corresponding (not normalized) large integers  
	and check for zerodivide."
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert to LargeInteger"
			self
				remapOop: secondInteger
				in: [firstAsLargeInteger := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstAsLargeInteger := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["check for zerodivide and convert to LargeInteger"
			(interpreterProxy integerValueOf: secondInteger)
					= 0
				ifTrue: [^ interpreterProxy primitiveFail].
			self
				remapOop: firstAsLargeInteger
				in: [secondAsLargeInteger := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondAsLargeInteger := secondInteger].
	^ self
		digitDivLarge: firstAsLargeInteger
		with: secondAsLargeInteger
		negative: neg! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 6/8/2004 04:59'!
primDigitDiv: firstInteger with: secondInteger negative: neg 
	"Answer the result of dividing firstInteger by secondInteger.
	Fail if parameters are not integers or secondInteger is zero."
	| firstAsLargeInteger secondAsLargeInteger |
	self debugCode: [self msg: 'primDigitDiv: firstInteger with: secondInteger negative: neg'].
	self
		primitive: 'primDigitDivWithNegative'
		parameters: #(Integer Integer Boolean )
		receiver: #Oop.
	"Coerce SmallIntegers to corresponding (not normalized) large integers    
	 and check for zerodivide."
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert to LargeInteger"
			self remapOop: secondInteger in: [firstAsLargeInteger := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstAsLargeInteger := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: 
			["check for zerodivide and convert to LargeInteger"
			(interpreterProxy integerValueOf: secondInteger)
				= 0 ifTrue: [^ interpreterProxy primitiveFail].
			self remapOop: firstAsLargeInteger in: [secondAsLargeInteger := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondAsLargeInteger := secondInteger].
	^ self
		digitDivLarge: firstAsLargeInteger
		with: secondAsLargeInteger
		negative: neg! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/8/2004 04:53'!
primDigitMultiply: secondInteger negative: neg 
	| firstLarge secondLarge firstInteger |
	self debugCode: [self msg: 'primDigitMultiply: secondInteger negative: neg'].
	firstInteger := self
				primitive: 'primDigitMultiplyNegative'
				parameters: #(#Integer #Boolean )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self
				remapOop: secondInteger
				in: [firstLarge := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self
				remapOop: firstLarge
				in: [secondLarge := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge := secondInteger].
	^ self
		digitMultiplyLarge: firstLarge
		with: secondLarge
		negative: neg! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 6/8/2004 04:58'!
primDigitMultiply: firstInteger with: secondInteger negative: neg
	| firstLarge secondLarge |
	self debugCode: [self msg: 'primDigitMultiply: firstInteger with: secondInteger negative: neg'].
	self
		primitive: 'primDigitMultiplyWithNegative'
		parameters: #(Integer Integer Boolean )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge := secondInteger].
	^ self
		digitMultiplyLarge: firstLarge
		with: secondLarge
		negative: neg! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/8/2004 05:01'!
primDigitSubtract: secondInteger 
	| firstLarge secondLarge firstInteger |
	self debugCode: [self msg: 'primDigitSubtract: secondInteger'].
	firstInteger := self
				primitive: 'primDigitSubtract'
				parameters: #(#Integer )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self
				remapOop: secondInteger
				in: [firstLarge := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self
				remapOop: firstLarge
				in: [secondLarge := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge := secondInteger].
	^ self digitSubLarge: firstLarge with: secondLarge! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 6/8/2004 04:58'!
primDigitSubtract: firstInteger with: secondInteger
	| firstLarge secondLarge |
	self debugCode: [self msg: 'primDigitSubtract: firstInteger with: secondInteger'].
	self
		primitive: 'primDigitSubtractWith'
		parameters: #(Integer Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge := self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge := firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge := self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge := secondInteger].
	^ self digitSubLarge: firstLarge with: secondLarge! !
!LargeIntegersPlugin methodsFor: 'control & support primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:00'!
primGetModuleName
	"If calling this primitive fails, then C module does not exist."
	| strLen strOop strPtr |
	<var: #cString type: 'char *'>
	<var: #strPtr type: 'char *'>
	self debugCode: [self msg: 'primGetModuleName'].
	self
		primitive: 'primGetModuleName'
		parameters: #()
		receiver: #Oop.
	strLen := self strlen: self getModuleName.
	strOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: strLen.
	strPtr := interpreterProxy firstIndexableField: strOop.
	0 to: strLen - 1 do: [:i | strPtr at: i put: (self getModuleName at: i)].
	^ strOop! !
!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:11'!
primNormalize: anInteger 
"Parameter specification #(Integer) doesn't convert!!"
	self debugCode: [self msg: 'primNormalize: anInteger'].
	self
		primitive: 'primNormalize'
		parameters: #(Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: [^ anInteger].
	^ self normalize: anInteger! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/8/2004 05:01'!
primNormalizeNegative
	| rcvr |
	self debugCode: [self msg: 'primNormalizeNegative'].
	rcvr := self
				primitive: 'primNormalizeNegative'
				parameters: #()
				receiver: #LargeNegativeInteger.
	^ self normalizeNegative: rcvr! !
!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/8/2004 05:01'!
primNormalizePositive
	| rcvr |
	self debugCode: [self msg: 'primNormalizePositive'].
	rcvr := self
				primitive: 'primNormalizePositive'
				parameters: #()
				receiver: #LargePositiveInteger.
	^ self normalizePositive: rcvr! !
!LargeIntegersPlugin methodsFor: 'debugging' stamp: 'tpr 11/1/2004 20:20'!
think
	"Flag for marking methods for later thinking."
	self debugCode: [self msg: '#think should not be called'].
	^nil! !
!LargeIntegersPlugin methodsFor: 'util' stamp: 'eem 10/2/2010 13:17'!
unsafeByteOf: bytesOop at: ix
	"Argument bytesOop must not be aSmallInteger!!"
	<inline: true>
	| pointer |
	<var: #pointer type: #'unsigned char *'>
	^(pointer := interpreterProxy firstIndexableField: bytesOop) at: ix - 1! !

SmartSyntaxInterpreterPlugin subclass: #LocalePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!LocalePlugin commentStamp: '<historical>' prior: 0!
LocalePlugin provides access to some localization info.
primLanguage - returns a string describing the language in use as per ISO 639
primCountry - returns a string with country tag as per ISO 639
primVMOffsetToUTC - returns offset from UTC to time as provided by the VM. integer of minutes to allow for those odd places with halkf-hour offeset.
primTimeZone - returns UTC offset (? why two?)
primDST - returns boolean to indicate DST in use
primDecimalSymbol - return string with '.' or ',' etc
primDigitGrouping - return string with ',' or '.' etc for thousands type separation
primTimeFormat - return string with time dispaly format string - eg 'hh:mm:ss' etc
primLongDateFOrmat - return string with long date formatting - eg 'dd/mm/yyyy'
primShortDateFOrmat - similar but shortform
primCurrencySymbol - return string of currency name
primCurrencyNotation - return boolean for pre or postfix currency symbol
primMeasurement - return boolean for imperial or metric

!
!LocalePlugin class methodsFor: 'translation' stamp: 'tpr 5/31/2005 18:41'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!LocalePlugin class methodsFor: 'translation' stamp: 'tpr 5/31/2005 17:00'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!LocalePlugin methodsFor: 'initialize' stamp: 'tpr (auto pragmas 12/08) 6/1/2005 18:20'!
initialiseModule
	<export: true>
	^self sqLocInitialize! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 5/31/2005 18:59'!
primitiveCountry
	"return a 3 char string describing the country in use. ISO 3166 is the relevant source here; see http://www.unicode.org/onlinedat/countries.html for details. Using the 3 character Alpha-3 codes"
	| oop |
	self primitive:'primitiveCountry'.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: 3.
	self sqLocGetCountryInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 5/31/2005 18:25'!
primitiveCurrencyNotation
	"return a boolean specifying whether the currency symbol is pre or post fix. true -> pre"
	self primitive:'primitiveCurrencyNotation'.
	^self sqLocCurrencyNotation asOop: Boolean! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 13:22'!
primitiveCurrencySymbol
	"return a string describing the currency symbol used 
Still need to find details on standard symbols - ISO 4217 is supposed to be it but cannot find on web"
	| oop length |
	self primitive:'primitiveCurrencySymbol'.
	length := self sqLocCurrencySymbolSize.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: length.
	self sqLocGetCurrencySymbolInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 5/31/2005 18:24'!
primitiveDaylightSavings
	"return a boolean specifying the DST setting. true -> active"
	self primitive:'primitiveDaylightSavings'.
	^self sqLocDaylightSavings asOop: Boolean! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 12:23'!
primitiveDecimalSymbol
	"return a 1 char string describing the decimal symbol used - usually a . or a ,"
	| oop |
	self primitive:'primitiveDecimalSymbol'.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: 1.
	self sqLocGetDecimalSymbolInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 12:24'!
primitiveDigitGroupingSymbol
	"return a 1 char string describing the digitGrouping symbol used - usually a . or a , between triples of digits"
	| oop |
	self primitive:'primitiveDigitGroupingSymbol'.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: 1.
	self sqLocGetDigitGroupingSymbolInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 12:24'!
primitiveLanguage
	"return a 3 char string describing the language in use. ISO 639 is the relevant source here; see http://www.w3.org/WAI/ER/IG/ert/iso639.html for details"
	| oop |
	self primitive:'primitiveLanguage'.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: 3.
	self sqLocGetLanguageInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 12:24'!
primitiveLongDateFormat
	"return a string describing the long date formatting.
Format is made up of
d day, m month, y year,
double symbol is null padded, single not padded (m=6, mm=06)
dddd weekday
mmmm month name
"
	| oop length |
	self primitive:'primitiveLongDateFormat'.
	length := self sqLocLongDateFormatSize.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: length.
	self sqLocGetLongDateFormatInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 5/31/2005 18:28'!
primitiveMeasurementMetric
	"return a boolean specifying whether the currency symbol is pre or post fix. true -> pre"
	self primitive:'primitiveMeasurementMetric'.
	^self sqLocMeasurementMetric asOop: Boolean! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 12:25'!
primitiveShortDateFormat
	"return a string describing the long date formatting.
Format is made up of
d day, m month, y year,
double symbol is null padded, single not padded (m=6, mm=06)
dddd weekday
mmmm month name
"
	| oop length |
	self primitive:'primitiveShortDateFormat'.
	length := self sqLocShortDateFormatSize.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: length.
	self sqLocGetShortDateFormatInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 12:25'!
primitiveTimeFormat
	"return a string describing the time formatting.
Format is made up of
h hour (h 12, H 24), m minute, s seconds, x (am/pm String)
double symbol is null padded, single not padded (h=6, hh=06)"
	| oop length |
	self primitive:'primitiveTimeFormat'.
	length := self sqLocTimeFormatSize.
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: length.
	self sqLocGetTimeFormatInto: (interpreterProxy firstIndexableField: oop).
	^oop
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 19:43'!
primitiveTimezoneOffset
	"return the number of minutes this VM's time value is offset from UTC"

	self primitive:'primitiveTimezoneOffset'.
	^self sqLocGetTimezoneOffset asSmallIntegerObj
! !
!LocalePlugin methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 19:04'!
primitiveVMOffsetToUTC
	"return the number of minutes this VM's time value is offset from UTC"

	self primitive:'primitiveVMOffsetToUTC'.
	^self sqLocGetVMOffsetToUTC asSmallIntegerObj
! !

SmartSyntaxInterpreterPlugin subclass: #MIDIPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!MIDIPlugin commentStamp: 'tpr 5/5/2003 12:15' prior: 0!
Provide MIDI support, if your platform provides it. !
!MIDIPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:10'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!MIDIPlugin class methodsFor: 'translation' stamp: 'tpr 11/29/2000 22:38'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!MIDIPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:53'!
initialiseModule
	<export: true>
	^self cCode: 'midiInit()' inSmalltalk:[true]! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIClosePort: portNum

	self primitive: 'primitiveMIDIClosePort'
		parameters: #(SmallInteger).
	self sqMIDIClosePort: portNum! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIGetClock
	"Return the value of the MIDI clock as a SmallInteger. The range is limited to SmallInteger maxVal / 2 to allow scheduling MIDI events into the future without overflowing a SmallInteger. The sqMIDIGetClock function is assumed to wrap at or before 16r20000000."

	| clockValue |
	self primitive: 'primitiveMIDIGetClock'.
	clockValue := self sqMIDIGetClock bitAnd: 16r1FFFFFFF.
	^clockValue asSmallIntegerObj! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIGetPortCount

	| n |
	self primitive: 'primitiveMIDIGetPortCount'.
	n := self sqMIDIGetPortCount.
	^n asSmallIntegerObj
! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIGetPortDirectionality: portNum

	|  dir |
	self primitive: 'primitiveMIDIGetPortDirectionality'
		parameters: #(SmallInteger).
	dir := self sqMIDIGetPortDirectionality: portNum.
	^dir asSmallIntegerObj! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-28) 12/1/2009 21:40'!
primitiveMIDIGetPortName: portNum

	| portName sz nameObj namePtr |
	<var: #portName declareC: 'char portName[256]'>
	<var: #namePtr type: 'char * '>
	self primitive: 'primitiveMIDIGetPortName'
		parameters: #(SmallInteger).

	sz := self cCode: 'sqMIDIGetPortName(portNum, &portName, 255)'.
	nameObj := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: sz.
	interpreterProxy failed ifTrue:[^nil].
	namePtr := nameObj asValue: String .
	self cCode: 'memcpy(namePtr, portName, sz)'.
	^nameObj! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIOpenPort: portNum sema: semaIndex speed: clockRate

	self primitive: 'primitiveMIDIOpenPort'
		parameters: #(SmallInteger SmallInteger SmallInteger).
	self cCode: 'sqMIDIOpenPort(portNum, semaIndex, clockRate)'! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIParameterGet: whichParameter

	|  currentValue |
	"read parameter"
	self primitive: 'primitiveMIDIParameterGet'
		parameters: #(SmallInteger).
	currentValue := self cCode: 'sqMIDIParameterGet(whichParameter)'.
	^currentValue asSmallIntegerObj! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 5/12/2000 17:15'!
primitiveMIDIParameterGetOrSet
	"Backward compatibility"
	<export: true>
	interpreterProxy methodArgumentCount = 1
		ifTrue:[^self primitiveMIDIParameterGet]
		ifFalse:[^self primitiveMIDIParameterSet]! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIParameterSet: whichParameter value: newValue

	"write parameter"
	self primitive:'primitiveMIDIParameterSet'
		parameters:#(SmallInteger SmallInteger).
	self cCode: 'sqMIDIParameterSet(whichParameter, newValue)'! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIRead: portNum into: array

	| arrayLength bytesRead |
	self primitive: 'primitiveMIDIRead'
		parameters: #(SmallInteger ByteArray).
	arrayLength := interpreterProxy byteSizeOf: array cPtrAsOop.
	bytesRead := self sqMIDIPort: portNum
			Read: arrayLength
			Into: array asInteger.
	^bytesRead asSmallIntegerObj! !
!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIWrite: portNum from: array at: time

	| arrayLength bytesWritten |
	self primitive: 'primitiveMIDIWrite'
		parameters: #(SmallInteger ByteArray SmallInteger).
	arrayLength := interpreterProxy byteSizeOf: array cPtrAsOop.
	bytesWritten := self sqMIDIPort: portNum
			Write: arrayLength
			From: array asInteger
			At: time.
	^bytesWritten asSmallIntegerObj! !
!MIDIPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:55'!
shutdownModule
	<export: true>
	^self cCode: 'midiShutdown()' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #MacMenubarPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!MacMenubarPlugin class methodsFor: 'translation' stamp: 'JMM 8/27/2004 12:50'!
hasHeaderFile
	^true! !
!MacMenubarPlugin class methodsFor: 'translation' stamp: 'JMM 8/27/2004 12:50'!
requiresCrossPlatformFiles
	^false! !
!MacMenubarPlugin class methodsFor: 'translation' stamp: 'JMM 8/16/2004 13:17'!
requiresPlatformFiles
	^true! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:54'!
primitiveAppendMenu: menuHandleOop data: str255
	| menuHandle constStr255 |
	self primitive: 'primitiveAppendMenu'
		parameters: #(Oop ByteArray).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'constStr255' type: 'ConstStr255Param'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	constStr255 := self cCoerce: str255 to: 'ConstStr255Param'.	
	self cCode: 'AppendMenu(menuHandle,constStr255)' inSmalltalk:[menuHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:55'!
primitiveAppendMenuItemText: menuHandleOop data: str255
	| menuHandle constStr255 |
	self primitive: 'primitiveAppendMenuItemText'
		parameters: #(Oop ByteArray).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'constStr255' type: 'ConstStr255Param'.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	constStr255 := self cCoerce: str255 to: 'ConstStr255Param'.	
	self cCode: 'AppendMenuItemText(menuHandle,constStr255)' inSmalltalk:[menuHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:55'!
primitiveCheckMenuItem: menuHandleOop item: anInteger checked: aBoolean
	| menuHandle |
	self primitive: 'primitiveCheckMenuItem'
		parameters: #(Oop SmallInteger Boolean).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'CheckMenuItem(menuHandle,anInteger,aBoolean)' inSmalltalk:[menuHandle].
	^nil

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/16/2004 13:51'!
primitiveClearMenuBar 
	self primitive: 'primitiveClearMenuBar'
		parameters: #().
	
	self cCode: 'ClearMenuBar()' inSmalltalk:[].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:55'!
primitiveCountMenuItems: menuHandleOop 
	| menuHandle returnValue |
	self primitive: 'primitiveCountMenuItems'
		parameters: #(Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	returnValue := self cCode: 'CountMenuItems(menuHandle)' inSmalltalk:[0].
	^returnValue asSmallIntegerObj
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 6/5/2005 20:58'!
primitiveCreateStandardWindowMenu: inOptions 

	| menuHandle result |
	self primitive: 'primitiveCreateStandardWindowMenu'
		parameters: #(SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	self cCode: '#if TARGET_API_MAC_CARBON
'.
	result := self cCode: 'CreateStandardWindowMenu(inOptions,&menuHandle);
#endif' inSmalltalk:[0].
	^interpreterProxy positive32BitIntegerFor: (self cCoerce: menuHandle to: 'long')! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 16:55'!
primitiveDeleteMenu: menuID 
	self primitive: 'primitiveDeleteMenu'
		parameters: #(SmallInteger).
	
	self var: 'menuID' type: 'MenuID'.
	self cCode: 'DeleteMenu(menuID)' inSmalltalk:[].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:55'!
primitiveDeleteMenuItem: menuHandleOop item: anInteger
	| menuHandle |
	self primitive: 'primitiveDeleteMenuItem'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'DeleteMenuItem(menuHandle,anInteger)' inSmalltalk:[menuHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 22:41'!
primitiveDisableMenuCommand: menuHandleOop item: anInteger
	| menuHandle commandID |
	self primitive: 'primitiveDisableMenuCommand'
		parameters: #(Oop Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'commandID' type: 'MenuCommand'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	commandID := self cCoerce: (interpreterProxy positive32BitValueOf: anInteger) to: 'MenuCommand'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: '#if TARGET_API_MAC_CARBON
DisableMenuCommand(menuHandle,commandID);
#endif' inSmalltalk:[menuHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:56'!
primitiveDisableMenuItem: menuHandleOop item: anInteger
	| menuHandle |
	self primitive: 'primitiveDisableMenuItem'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'DisableMenuItem(menuHandle,anInteger)' inSmalltalk:[menuHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:56'!
primitiveDisableMenuItemIcon: menuHandleOop item: anInteger
	| menuHandle |
	self primitive: 'primitiveDisableMenuItemIcon'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'DisableMenuItemIcon(menuHandle,anInteger)' inSmalltalk:[menuHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:56'!
primitiveDisposeMenu: menuHandleOop 
	| menuHandle |
	self primitive: 'primitiveDisposeMenu'
		parameters: #(Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'DisposeMenu(menuHandle)' inSmalltalk:[menuHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:21'!
primitiveDisposeMenuBar: menuHandleOop 
	| menuBarHandle |
	self primitive: 'primitiveDisposeMenuBar'
		parameters: #(Oop).
	self var: 'menuBarHandle' type: 'Handle'.
	
	menuBarHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'Handle'.
	self cCode: '#if TARGET_API_MAC_CARBON
	DisposeMenuBar(menuBarHandle);
	#else
	DisposeHandle(menuBarHandle);
	#endif
	' 
		inSmalltalk:[menuBarHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/16/2004 13:53'!
primitiveDrawMenuBar
	self primitive: 'primitiveDrawMenuBar'
		parameters: #().
	
	self cCode: 'DrawMenuBar()' inSmalltalk:[].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 22:42'!
primitiveEnableMenuCommand: menuHandleOop item: anInteger
	| menuHandle commandID |
	self primitive: 'primitiveEnableMenuCommand'
		parameters: #(Oop Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'commandID' type: 'MenuCommand'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	commandID := self cCoerce: (interpreterProxy positive32BitValueOf: anInteger) to: 'MenuCommand'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: '#if TARGET_API_MAC_CARBON
EnableMenuCommand(menuHandle,commandID);
#endif' inSmalltalk:[menuHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:56'!
primitiveEnableMenuItem: menuHandleOop item: anInteger
	| menuHandle |
	self primitive: 'primitiveEnableMenuItem'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'EnableMenuItem(menuHandle,anInteger)' inSmalltalk:[menuHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:56'!
primitiveEnableMenuItemIcon: menuHandleOop item: anInteger
	| menuHandle |
	self primitive: 'primitiveEnableMenuItemIcon'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'EnableMenuItemIcon(menuHandle,anInteger)' inSmalltalk:[menuHandle].
	^nil
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 22:42'!
primitiveGetIndMenuItemWithCommandID: menuHandleOop commandID: aCommandID
	| menuHandle MenuItemIndex commandID applicationMenu outIndex |
	self primitive: 'primitiveGetIndMenuItemWithCommandID'
		parameters: #(Oop Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'commandID' type: 'MenuCommand'.
	self var: 'applicationMenu' type: 'MenuHandle'.
	self var: 'outIndex' type: 'MenuItemIndex'.

	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	commandID := self cCoerce: (interpreterProxy positive32BitValueOf: aCommandID) to: 'MenuCommand'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: '#if TARGET_API_MAC_CARBON
GetIndMenuItemWithCommandID(menuHandle, kHICommandHide, 1,
                   &applicationMenu, &outIndex);
#endif' inSmalltalk:[menuHandle].
	^outIndex asSmallIntegerObj
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 22:42'!
primitiveGetIndMenuWithCommandID: menuHandleOop commandID: aCommandID
	| menuHandle MenuItemIndex commandID applicationMenu outIndex |
	self primitive: 'primitiveGetIndMenuWithCommandID'
		parameters: #(Oop Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'commandID' type: 'MenuCommand'.
	self var: 'applicationMenu' type: 'MenuHandle'.
	self var: 'outIndex' type: 'MenuItemIndex'.

	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	commandID := self cCoerce: (interpreterProxy positive32BitValueOf: aCommandID) to: 'MenuCommand'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: '#if TARGET_API_MAC_CARBON
GetIndMenuItemWithCommandID(menuHandle, kHICommandHide, 1,
                   &applicationMenu, &outIndex);
#endif ' inSmalltalk:[menuHandle].
	^interpreterProxy positive32BitIntegerFor: (self cCoerce: applicationMenu to: 'long')

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'tpr 12/29/2005 17:00'!
primitiveGetItemCmd: menuHandleOop item: anInteger
	| menuHandle aCharacter |
	self primitive: 'primitiveGetItemCmd'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: #aCharacter type: 'CharParameter '.
	self var: #ptr type: 'char *'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	aCharacter := 0.
	self cCode: 'GetItemCmd(menuHandle,anInteger,&aCharacter)' inSmalltalk:[menuHandle].
	^aCharacter asSmallIntegerObj

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:57'!
primitiveGetItemIcon: menuHandleOop item: anInteger
	| menuHandle iconIndex |
	self primitive: 'primitiveGetItemIcon'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'iconIndex' type: 'short'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	iconIndex := 0.
	self cCode: 'GetItemIcon(menuHandle,anInteger,&iconIndex)' inSmalltalk:[menuHandle].
	^iconIndex asSmallIntegerObj
! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'tpr 12/29/2005 17:01'!
primitiveGetItemMark: menuHandleOop item: anInteger
	| menuHandle aCharacter |
	self primitive: 'primitiveGetItemMark'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: #aCharacter type: 'CharParameter '.
	self var: #ptr type: 'char *'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	aCharacter := 0.
	self cCode: 'GetItemMark(menuHandle,anInteger,&aCharacter)' inSmalltalk:[menuHandle].
	^aCharacter asSmallIntegerObj

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:57'!
primitiveGetItemStyle: menuHandleOop item: anInteger 
	| menuHandle chStyle |
	self primitive: 'primitiveGetItemStyle'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'chStyle' type: 'Style'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	chStyle := 0.
	self cCode: 'GetItemStyle(menuHandle,anInteger,&chStyle)' inSmalltalk:[menuHandle].
	^chStyle asSmallIntegerObj

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/17/2004 20:18'!
primitiveGetMenuBar 
	| menuHandle |
	self primitive: 'primitiveGetMenuBar'
		parameters: #().
	self var: 'menuHandle' type: 'Handle'.
	menuHandle := self cCode: 'GetMenuBar()' inSmalltalk:[0].
	^interpreterProxy positive32BitIntegerFor: (self cCoerce: menuHandle to: 'long')! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 16:56'!
primitiveGetMenuHandle: menuID 
	| menuHandle |
	self primitive: 'primitiveGetMenuHandle'
		parameters: #(SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'menuID' type: 'MenuID'.
	menuHandle := self cCode: 'GetMenuHandle(menuID)' inSmalltalk:[0].
	^interpreterProxy positive32BitIntegerFor: (self cCoerce: menuHandle to: 'long')! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:57'!
primitiveGetMenuID: menuHandleOop 
	| menuHandle menuID |
	
	self primitive: 'primitiveGetMenuID'
		parameters: #(Oop ).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'menuID' type: 'MenuID'.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'menuID = GetMenuID(menuHandle)' inSmalltalk:[menuHandle].
	^menuID asSmallIntegerObj
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:57'!
primitiveGetMenuItemCommandID: menuHandleOop item: anInteger 
	| menuHandle outCommandID |
	self primitive: 'primitiveGetMenuItemCommandID'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'outCommandID' type: 'MenuCommand'.
	outCommandID := 0.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'GetMenuItemCommandID(menuHandle,anInteger,&outCommandID)' inSmalltalk:[menuHandle].
	^interpreterProxy positive32BitIntegerFor: outCommandID
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:57'!
primitiveGetMenuItemFontID: menuHandleOop item: anInteger 
	| menuHandle outFontID |
	self primitive: 'primitiveGetMenuItemFontID'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'outFontID' type: 'SInt16'.
	outFontID := 0.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'GetMenuItemFontID(menuHandle,anInteger,&outFontID)' inSmalltalk:[menuHandle].
	^outFontID asSmallIntegerObj
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:58'!
primitiveGetMenuItemHierarchicalID: menuHandleOop item: anInteger 
	| menuHandle outHierID |
	self primitive: 'primitiveGetMenuItemHierarchicalID'
		parameters: #(Oop SmallInteger ).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'outHierID' type: 'MenuID'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	outHierID := 0.
	self cCode: 'GetMenuItemHierarchicalID(menuHandle,anInteger,&outHierID)' inSmalltalk:[menuHandle].
	^outHierID asSmallIntegerObj

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:58'!
primitiveGetMenuItemKeyGlyph: menuHandleOop item: anInteger 
	| menuHandle outGlyph |
	self primitive: 'primitiveGetMenuItemKeyGlyph'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'outGlyph' type: 'SInt16'.
	outGlyph := 0.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'GetMenuItemKeyGlyph(menuHandle,anInteger,&outGlyph)' inSmalltalk:[menuHandle].
	^interpreterProxy positive32BitIntegerFor: outGlyph
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:58'!
primitiveGetMenuItemModifiers: menuHandleOop item: anInteger 
	| menuHandle outModifers |
	self primitive: 'primitiveGetMenuItemModifiers'
		parameters: #(Oop SmallInteger ).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'outModifers' type: 'Style'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	outModifers := 0.
	self cCode: 'GetMenuItemModifiers(menuHandle,anInteger,&outModifers)' inSmalltalk:[menuHandle].
	^outModifers asSmallIntegerObj
	

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'tpr 12/29/2005 17:01'!
primitiveGetMenuItemText: menuHandleOop item: anInteger
	| menuHandle size oop ptr aString |
	self primitive: 'primitiveGetMenuItemText'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: #aString type: 'Str255 '.
	self var: #ptr type: 'char *'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	aString at: 0 put: 0.
	self cCode: 'GetMenuItemText(menuHandle,anInteger,aString)' inSmalltalk:[menuHandle].
	size := self cCode: 'aString[0]' inSmalltalk: [0].
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize:  size.
	ptr := interpreterProxy firstIndexableField: oop.
	0 to: size-1 do:[:i|
		ptr at: i put: (aString at: (i+1))].
	^oop

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:58'!
primitiveGetMenuItemTextEncoding: menuHandleOop item: anInteger
	| menuHandle outScriptID |
	self primitive: 'primitiveGetMenuItemTextEncoding'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'outScriptID' type: 'TextEncoding'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'GetMenuItemTextEncoding(menuHandle,anInteger,&outScriptID)' inSmalltalk:[menuHandle].
	^interpreterProxy positive32BitIntegerFor: outScriptID! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'tpr 12/29/2005 17:01'!
primitiveGetMenuTitle: menuHandleOop
	| menuHandle size oop ptr aString |
	self primitive: 'primitiveGetMenuTitle'
		parameters: #(Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: #aString type: 'Str255 '.
	self var: #ptr type: 'char *'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	aString at: 0 put: 0.
	self cCode: 'GetMenuTitle(menuHandle,aString)' inSmalltalk:[menuHandle].
	size := self cCode: 'aString[0]' inSmalltalk: [0].
	oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize:  size.
	ptr := interpreterProxy firstIndexableField: oop.
	0 to: size-1 do:[:i|
		ptr at: i put: (aString at: (i+1))].
	^oop

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/17/2004 16:29'!
primitiveHideMenuBar 
	self primitive: 'primitiveHideMenuBar'
		parameters: #().
	
	self cCode: 'HideMenuBar()' inSmalltalk:[].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 16:56'!
primitiveHiliteMenu: menuID 
	self primitive: 'primitiveHiliteMenu'
		parameters: #(SmallInteger).
	self var: 'menuID' type: 'MenuID'.
	self cCode: 'HiliteMenu(menuID)' inSmalltalk:[].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:58'!
primitiveInsertFontResMenu: menuHandleOop afterItem: afterItemInteger scriptFilter:  scriptFilterInteger
	| menuHandle |
	self primitive: 'primitiveInsertFontResMenu'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'InsertFontResMenu(menuHandle,afterItemInteger,scriptFilterInteger)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:58'!
primitiveInsertIntlResMenu: menuHandleOop theType: aResType afterItem: afterItemInteger scriptFilter:  scriptFilterInteger
	| menuHandle resType |
	self primitive: 'primitiveInsertIntlResMenu'
		parameters: #(Oop SmallInteger SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'resType' type: 'ResType'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	resType := self cCoerce: (interpreterProxy positive32BitValueOf: aResType) to: 'ResType'.
	self cCode: 'InsertIntlResMenu(menuHandle,resType,afterItemInteger,scriptFilterInteger)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:58'!
primitiveInsertMenu: menuHandleOop beforeID: anInteger
	| menuHandle |
	self primitive: 'primitiveInsertMenu'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'anInteger' type: 'MenuID'.

	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'InsertMenu(menuHandle,anInteger)' inSmalltalk:[menuHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:59'!
primitiveInsertMenuItem: menuHandleOop itemString: str255 afterItem: anInteger
	| menuHandle constStr255 |
	self primitive: 'primitiveInsertMenuItem'
		parameters: #(Oop ByteArray SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'constStr255' type: 'ConstStr255Param'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	constStr255 := self cCoerce: str255 to: 'ConstStr255Param'.	
	self cCode: 'InsertMenuItem(menuHandle,constStr255,anInteger)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/16/2004 13:54'!
primitiveInvalMenuBar
	self primitive: 'primitiveInvalMenuBar'
		parameters: #().
	
	self cCode: 'InvalMenuBar()' inSmalltalk:[].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/17/2004 16:58'!
primitiveIsMenuBarVisible
	| result |
	self primitive: 'primitiveIsMenuBarVisible'
		parameters: #().
	result := self cCode: 'IsMenuBarVisible()' inSmalltalk:[true].
	^result asOop: Boolean! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:59'!
primitiveIsMenuItemEnabled: menuHandleOop item: anInteger

	| menuHandle result |
	self primitive: 'primitiveIsMenuItemEnabled'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	result := self cCode: 'IsMenuItemEnabled(menuHandle,anInteger)' inSmalltalk:[0].
	^result asOop: Boolean! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:03'!
primitiveIsMenuItemIconEnabled: menuHandleOop item: anInteger

	| menuHandle result |
	self primitive: 'primitiveIsMenuItemIconEnabled'
		parameters: #(Oop SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	result := self cCode: 'IsMenuItemIconEnabled(menuHandle,anInteger)' inSmalltalk:[0].
	^result asOop: Boolean! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 16:57'!
primitiveNewMenu: menuID menuTitle: menuTitle

	| menuHandle constStr255 |
	self primitive: 'primitiveNewMenu'
		parameters: #(SmallInteger ByteArray).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'constStr255' type: 'ConstStr255Param'.
	self var: 'menuID' type: 'MenuID'.
	
	constStr255 := self cCoerce: menuTitle to: 'ConstStr255Param'.	
	menuHandle := self cCode: 'NewMenu(menuID,constStr255)' inSmalltalk:[0].
	^interpreterProxy positive32BitIntegerFor: (self cCoerce: menuHandle to: 'long')! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'tpr 12/29/2005 17:01'!
primitiveSetItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar
	| menuHandle aCharacter |
	self primitive: 'primitiveSetItemCmd'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: #aCharacter type: 'CharParameter '.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	aCharacter := anIntegerCmdChar.
	self cCode: 'SetItemCmd(menuHandle,anInteger,aCharacter)' inSmalltalk:[menuHandle].
	^nil

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:59'!
primitiveSetItemIcon: menuHandleOop item: anInteger iconIndex: aIconIndexInteger
	| menuHandle |
	self primitive: 'primitiveSetItemIcon'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'SetItemIcon(menuHandle,anInteger,aIconIndexInteger)' inSmalltalk:[menuHandle].
	^nil

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'tpr 12/29/2005 17:02'!
primitiveSetItemMark: menuHandleOop item: anInteger markChar: aMarkChar
	| menuHandle aCharacter |
	self primitive: 'primitiveSetItemMark'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: #aCharacter type: 'CharParameter '.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	aCharacter := aMarkChar.
	self cCode: 'SetItemMark(menuHandle,anInteger,aCharacter)' inSmalltalk:[menuHandle].
	^nil

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:59'!
primitiveSetItemStyle: menuHandleOop item: anInteger styleParameter: chStyleInteger
	| menuHandle |
	self primitive: 'primitiveSetItemStyle'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'SetItemStyle(menuHandle,anInteger,chStyleInteger)' inSmalltalk:[menuHandle].
	^nil

! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:25'!
primitiveSetMenuBar: menuHandleOop

	| menuBarHandle |
	self primitive: 'primitiveSetMenuBar'
		parameters: #(Oop).
	self var: 'menuBarHandle' type: 'MenuBarHandle'.
	menuBarHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuBarHandle'.
	self cCode: 'SetMenuBar(menuBarHandle)' inSmalltalk:[menuBarHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 23:26'!
primitiveSetMenuItemCommandID: menuHandleOop item: anInteger menuCommand:  inCommandID
	| menuHandle commandID |
	self primitive: 'primitiveSetMenuItemCommandID'
		parameters: #(Oop SmallInteger Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'commandID' type: 'MenuCommand'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	commandID := self cCoerce: (interpreterProxy positive32BitValueOf: inCommandID) to: 'MenuCommand'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'SetMenuItemCommandID(menuHandle,anInteger,commandID)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 13:59'!
primitiveSetMenuItemFontID: menuHandleOop item: anInteger fontID: aFontIDInteger  
	| menuHandle |
	self primitive: 'primitiveSetMenuItemFontID'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'SetMenuItemFontID(menuHandle,anInteger,aFontIDInteger)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:00'!
primitiveSetMenuItemHierarchicalID: menuHandleOop item: anInteger hierID: aMenuID
	| menuHandle |
	self primitive: 'primitiveSetMenuItemHierarchicalID'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'menuID' type: 'MenuID'.

	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'SetMenuItemHierarchicalID(menuHandle,anInteger,aMenuID)' inSmalltalk:[menuHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:00'!
primitiveSetMenuItemKeyGlyph: menuHandleOop item: anInteger glyph:  inGlyphInteger
	| menuHandle |
	self primitive: 'primitiveSetMenuItemKeyGlyph'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'SetMenuItemKeyGlyph(menuHandle,anInteger,inGlyphInteger)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:00'!
primitiveSetMenuItemModifiers: menuHandleOop item: anInteger inModifiers: aUInt8
	| menuHandle |
	self primitive: 'primitiveSetMenuItemModifiers'
		parameters: #(Oop SmallInteger SmallInteger).
	self var: 'menuHandle' type: 'MenuHandle'.

	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	self cCode: 'SetMenuItemModifiers(menuHandle,anInteger,aUInt8)' inSmalltalk:[menuHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:00'!
primitiveSetMenuItemText: menuHandleOop item: anInteger itemString: str255
	| menuHandle constStr255 |
	self primitive: 'primitiveSetMenuItemText'
		parameters: #(Oop SmallInteger ByteArray).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'constStr255' type: 'ConstStr255Param'.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	constStr255 := self cCoerce: str255 to: 'ConstStr255Param'.	
	self cCode: 'SetMenuItemText(menuHandle,anInteger,constStr255)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:00'!
primitiveSetMenuItemTextEncoding: menuHandleOop item: anInteger inScriptID: aTextEncodingOop
	| menuHandle inScriptID |
	self primitive: 'primitiveSetMenuItemTextEncoding'
		parameters: #(Oop SmallInteger Oop).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'inScriptID' type: 'TextEncoding'.
	
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	inScriptID := self cCoerce: (interpreterProxy positive32BitValueOf: aTextEncodingOop) to: 'TextEncoding'.
	self cCode: 'SetMenuItemTextEncoding(menuHandle,anInteger,inScriptID)' inSmalltalk:[menuHandle].
	^nil! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 10/1/2004 14:00'!
primitiveSetMenuTitle: menuHandleOop  title: str255
	| menuHandle constStr255 |
	self primitive: 'primitiveSetMenuTitle'
		parameters: #(Oop ByteArray).
	self var: 'menuHandle' type: 'MenuHandle'.
	self var: 'constStr255' type: 'ConstStr255Param'.
	menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
	(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
	constStr255 := self cCoerce: str255 to: 'ConstStr255Param'.	
	self cCode: 'SetMenuTitle(menuHandle,constStr255)' inSmalltalk:[menuHandle].
	^nil
	! !
!MacMenubarPlugin methodsFor: 'system primitives' stamp: 'JMM 8/17/2004 16:29'!
primitiveShowMenuBar 
	self primitive: 'primitiveShowMenuBar'
		parameters: #().
	
	self cCode: 'ShowMenuBar()' inSmalltalk:[].
	^nil! !

SmartSyntaxInterpreterPlugin subclass: #Mpeg3Plugin
	instanceVariableNames: 'maximumNumberOfFilesToWatch mpegFiles'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!Mpeg3Plugin commentStamp: '<historical>' prior: 0!
/********************************************************
 * An interface to LibMPEG3
 * Author: Adam Williams <broadcast@earthling.net>
 * Page: heroine.linuxbox.com
 *
 * Changed for Squeak to work with Squeak and to work on the Macintosh
 * Sept 2000, by John M McIntosh johnmci@smalltalkconsulting.com
 * The smalltalk code and the C code it produces is released under the 
 * Squeak licence. The libmpeg3 C code is co-licenced under either the Squeak licence or
 * the GNU LGPL!
!Mpeg3Plugin class methodsFor: 'initialize-release' stamp: 'JMM 10/2/2000 12:56'!
declareCVarsIn: cg 
	super declareCVarsIn: cg.
	cg var: 'mpegFiles' declareC: 'mpeg3_t *mpegFiles[1024+1]'.
! !
!Mpeg3Plugin class methodsFor: 'initialize-release' stamp: 'tpr 5/23/2001 17:10'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!Mpeg3Plugin class methodsFor: 'initialize-release' stamp: 'tpr 7/4/2001 15:13'!
requiresCrossPlatformFiles
	"If there cross platform files to be associated with the plugin, here is where you want to flag"
	^true! !
!Mpeg3Plugin class methodsFor: 'initialize-release' stamp: 'tpr 3/13/2002 18:05'!
requiresPlatformFiles
	"If there platform files to be associated with the plugin, here is where you want to flag"
	^true! !
!Mpeg3Plugin methodsFor: 'support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:05'!
checkFileEntry: aMpegFile
	<var: #aMpegFile type: 'mpeg3_t * '>
	1 to: maximumNumberOfFilesToWatch do: 
		[:i | ((mpegFiles at: i) = aMpegFile) ifTrue: 
				[^true]].
	^false.
		
	! !
!Mpeg3Plugin methodsFor: 'support' stamp: 'JMM (auto pragmas 12/08) 10/2/2000 11:44'!
initialiseModule
	<export: true>
	maximumNumberOfFilesToWatch := 1024.
	1 to: maximumNumberOfFilesToWatch do: [:i | mpegFiles at: i put: 0].
	^self cCode: 'true' inSmalltalk:[true]! !
!Mpeg3Plugin methodsFor: 'support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:05'!
makeFileEntry: aMpegFile
	<var: #aMpegFile type: 'mpeg3_t * '>
	1 to: maximumNumberOfFilesToWatch do: 
		[:i | ((mpegFiles at: i) = 0) ifTrue: 
				[mpegFiles at: i put: aMpegFile.
				^true]].
	^false
	"Ok no room just ignore, we'll get a primitive failure later"
		
	! !
!Mpeg3Plugin methodsFor: 'support' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:02'!
mpeg3tValueOf: mpeg3tHandle 
	"Return a pointer to the first byte of of the mpeg3_t record within the  
	given Smalltalk object, or nil if socketOop is not a mpeg3_t record."
	| index check |

	<returnTypeC: 'mpeg3_t *'>
	<var: #index type: 'mpeg3_t ** '>
	interpreterProxy success: ((interpreterProxy isBytes: mpeg3tHandle)
			and: [(interpreterProxy byteSizeOf: mpeg3tHandle)
					= 4]).
	interpreterProxy failed
		ifTrue: [^ nil]
		ifFalse: 
			[index := self cCoerce: (interpreterProxy firstIndexableField: mpeg3tHandle)
						to: 'mpeg3_t **'.
			self cCode: 'check = checkFileEntry(*index)'.
			check = 0 ifTrue: [^nil]. 
			^ self cCode: '*index']! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:03'!
primitiveMPEG3AudioChannels: fileHandle stream: aNumber
	| file result |

	"int mpeg3_audio_channels(mpeg3_t *file,int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3AudioChannels'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^0].
	aNumber >= (self cCode: 'mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false. ^0.
	].

	result := self cCode: 'mpeg3_audio_channels(file,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:00'!
primitiveMPEG3AudioSamples: fileHandle stream: aNumber
	| file result |

	"long mpeg3_audio_samples(mpeg3_t *file, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3AudioSamples'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false. ^0.
	].

	self cCode: 'result = mpeg3_audio_samples(file,aNumber)'.
	^result asOop: Float
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 4/12/2006 12:08'!
primitiveMPEG3CheckSig: path
	| result sz storage |

	"int mpeg3_check_sig(char *path)"
	<var: #storage declareC: 'char storage[1024] '>
	self primitive: 'primitiveMPEG3CheckSig'
		parameters: #(String).
	sz := interpreterProxy byteSizeOf: path cPtrAsOop.
	interpreterProxy ioFilename: storage fromString: path ofLength: sz resolveAliases: true.
	self cCode: 'result = mpeg3_check_sig(storage)'.
	^result asOop: Boolean
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:00'!
primitiveMPEG3Close: fileHandle
	| file index |

	"int mpeg3_close(mpeg3_t *file)"
	<var: #file type: 'mpeg3_t * '>
	<var: #index type: 'mpeg3_t ** '>
	self primitive: 'primitiveMPEG3Close'
		parameters: #(Oop).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	self cCode: 'removeFileEntry(file); mpeg3_close(file)'.
	index := self cCoerce: (interpreterProxy firstIndexableField: fileHandle)
						to: 'mpeg3_t **'.
	self cCode: '*index = 0'.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:01'!
primitiveMPEG3DropFrames: fileHandle frames: aFrameNumber stream: aNumber
	| file result |

	"int mpeg3_drop_frames(mpeg3_t *file, long frames, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3DropFrames'
		parameters: #(Oop SmallInteger SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_drop_frames(file,aFrameNumber,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:03'!
primitiveMPEG3EndOfAudio: fileHandle stream: aNumber
	| file result |

	"int mpeg3_end_of_audio(mpeg3_t *file, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3EndOfAudio'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].

	self cCode: 'result = mpeg3_end_of_audio(file,aNumber)'.
	^result asOop: Boolean
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 4/12/2006 12:13'!
primitiveMPEG3EndOfVideo: fileHandle stream: aNumber
	| file result |

	"int mpeg3_end_of_video(mpeg3_t *file, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3EndOfVideo'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_end_of_video(file,aNumber)'.
	^result asOop: Boolean
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:03'!
primitiveMPEG3FrameRate: fileHandle stream: aNumber
	| file result |

	"float mpeg3_frame_rate(mpeg3_t *file, int stream)"
	<var: #result type: 'double '>
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3FrameRate'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result =  mpeg3_frame_rate(file,aNumber)'.
	^result asOop: Float
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:58'!
primitiveMPEG3GenerateToc: fileHandle useSearch: timecode doStreams: streams buffer: aString
	| file bufferSize |

	"int mpeg3_generate_toc_for_Squeak(FILE *output, char *path, int timecode_search, int print_streams, char *buffer)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3GenerateToc'
		parameters: #(Oop SmallInteger Boolean  String).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	bufferSize := interpreterProxy slotSizeOf: (interpreterProxy stackValue: 0).
	self cCode: 'mpeg3_generate_toc_for_Squeak(file,timecode,streams,aString,bufferSize)'.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:59'!
primitiveMPEG3GetFrame: fileHandle stream: aNumber
	| file result |

	"long mpeg3_get_frame(mpeg3_t *file,int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3GetFrame'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].

	self cCode: 'result = mpeg3_get_frame(file,aNumber)'.
	^result asOop: Float.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:59'!
primitiveMPEG3GetSample: fileHandle stream: aNumber
	| file result |

	"int mpeg3_video_width(mpeg3_t *file, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3GetSample'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_get_sample(file,aNumber)'.
	^result asOop: Float
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 4/12/2006 12:07'!
primitiveMPEG3GetTime: fileHandle 
	| file result |

	"double mpeg3_get_time(mpeg3_t *file)"
	<var: #result type: 'double '>
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3GetTime'
		parameters: #(Oop).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	self cCode: 'result = mpeg3_get_time(file)'.
	^result asOop: Float.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:01'!
primitiveMPEG3HasAudio: fileHandle
	| file result |

	"int mpeg3_has_audio(mpeg3_t *file)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3HasAudio'
		parameters: #(Oop).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	self cCode: 'result = mpeg3_has_audio(file)'.
	^result asOop: Boolean
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:59'!
primitiveMPEG3HasVideo: fileHandle
	| file result |

	"int mpeg3_has_video(mpeg3_t *file)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3HasVideo'
		parameters: #(Oop).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	self cCode: 'result = mpeg3_has_video(file)'.
	^result asOop: Boolean
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'JMM (auto pragmas dtl 2010-09-28) 3/29/2006 16:50'!
primitiveMPEG3Open: path
	| mpeg3Oop index sz storage |

	"mpeg3_t* mpeg3_open(char *path)"
	<var: #index declareC: 'mpeg3_t ** index'>
	<var: #storage declareC: 'char storage[1024]'>
	self primitive: 'primitiveMPEG3Open'
		parameters: #(String).
	sz := interpreterProxy byteSizeOf: path cPtrAsOop.
	interpreterProxy ioFilename: storage fromString: path ofLength: sz resolveAliases: true.
	mpeg3Oop := interpreterProxy instantiateClass: interpreterProxy classByteArray
					indexableSize: 4.
	index := self cCoerce: (interpreterProxy firstIndexableField: mpeg3Oop)
						to: 'mpeg3_t **'.
	self cCode: '*index = mpeg3_open(storage,0); makeFileEntry(*index)'.
	^mpeg3Oop.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'JMM (auto pragmas 12/08) 1/20/2006 18:38'!
primitiveMPEG3OpenABuffer: path size: size
	| mpeg3Oop index |

	<var: #index declareC: 'mpeg3_t ** index'>
	self primitive: 'primitiveMPEG3OpenABuffer'
		parameters: #(String SmallInteger).
	mpeg3Oop := interpreterProxy instantiateClass: interpreterProxy classByteArray
					indexableSize: 4.	
	index := self cCoerce: (interpreterProxy firstIndexableField: mpeg3Oop)
						to: 'mpeg3_t **'.
	self cCode: '*index = mpeg3_open(path,size); makeFileEntry(*index)'.
	^mpeg3Oop.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:01'!
primitiveMPEG3PreviousFrame: fileHandle stream: aNumber
	| file result |

	"int mpeg3_previous_frame(mpeg3_t *file, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3PreviousFrame'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	file = nil ifTrue: [^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_previous_frame(file,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:58'!
primitiveMPEG3ReReadAudio: fileHandle shortArray: anArray channel: aChannelNumber samples: aSampleNumber stream: aNumber
	| file result arrayBase |

	"int mpeg3_reread_audio(mpeg3_t *file, 
		float *output_f, 
		short *output_i, 
		int channel, 
		long samples,
		int stream)"
	<var: #file type: 'mpeg3_t * '>
	<var: #arrayBase type: 'short * '>
	self primitive: 'primitiveMPEG3ReReadAudio'
		parameters: #(Oop Array SmallInteger SmallInteger SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	arrayBase := self cCoerce: anArray to: 'short *'.
	interpreterProxy failed ifTrue: [^nil].
	self cCode: 'result = mpeg3_reread_audio(file,(float *) NULL,arrayBase,aChannelNumber,aSampleNumber,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:01'!
primitiveMPEG3ReadAudio: fileHandle shortArray: anArray channel: aChannelNumber samples: aSampleNumber stream: aNumber
	| file result arrayBase |

	"int mpeg3_read_audio(mpeg3_t *file, 
		float *output_f, 
		short *output_i, 
		int channel, 
		long samples,
		int stream)"
	<var: #file type: 'mpeg3_t * '>
	<var: #arrayBase type: 'short * '>
	self primitive: 'primitiveMPEG3ReadAudio'
		parameters: #(Oop Array SmallInteger SmallInteger SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].
	arrayBase := self cCoerce: anArray to: 'short *'.
	interpreterProxy failed ifTrue: [^nil].

	self cCode: 'result = mpeg3_read_audio(file,(float *) NULL,arrayBase,aChannelNumber,aSampleNumber,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'dtl 9/28/2010 19:17'!
primitiveMPEG3ReadFrame: fileHandle buffer: aBuffer bufferOffset: aBufferOffset x: xNumber y: yNumber w: width h: height ow: outWidth oh: outHeight colorModel: model stream: aNumber bytesPerRow: aByteNumber 
	| file result outputRowsPtr bufferBaseAddr |
	<var: #file declareC: 'mpeg3_t * file'>
	<var: #bufferBaseAddr declareC: 'unsigned char *bufferBaseAddr'>
	<var: #outputRowsPtr declareC: 'unsigned char  ** outputRowsPtr'>

	"int mpeg3_read_frame(mpeg3_t *file, 
		unsigned char **output_rows, 
		int in_x, 
		int in_y, 
		int in_w, 
		int in_h, 
		int out_w, 
		int out_h, 
		int color_model,
		int stream)"

	self primitive: 'primitiveMPEG3ReadFrameBufferOffset'
		parameters: #(Oop WordArray  SmallInteger SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [ interpreterProxy success: false.  ^nil ].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].

	bufferBaseAddr := self cCoerce: aBuffer to: 'unsigned char *'.
	self cCode: 'outputRowsPtr = (unsigned char **) memoryAllocate(1,sizeof(unsigned char*) * outHeight)'.

	0 to: outHeight-1 do: [:i | outputRowsPtr at: i put: (bufferBaseAddr + aBufferOffset + (aByteNumber*i))].
		
	self cCode: 'result = mpeg3_read_frame(file,outputRowsPtr,xNumber,yNumber,width,height,outWidth,outHeight,model,aNumber)'.
	self cCode: 'memoryFree(outputRowsPtr)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'dtl 9/28/2010 19:17'!
primitiveMPEG3ReadFrame: fileHandle buffer: aBuffer x: xNumber y: yNumber w: width h: height ow: outWidth oh: outHeight colorModel: model stream: aNumber bytesPerRow: aByteNumber 
	| file result outputRowsPtr bufferBaseAddr |
	<var: #file type: 'mpeg3_t * '>
	<var: #bufferBaseAddr type: 'unsigned char *'>
	<var: #outputRowsPtr type: 'unsigned char  ** '>

	"int mpeg3_read_frame(mpeg3_t *file, 
		unsigned char **output_rows, 
		int in_x, 
		int in_y, 
		int in_w, 
		int in_h, 
		int out_w, 
		int out_h, 
		int color_model,
		int stream)"

	self primitive: 'primitiveMPEG3ReadFrame'
		parameters: #(Oop WordArray  SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger  SmallInteger SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [ interpreterProxy success: false.  ^nil ].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].

	bufferBaseAddr := self cCoerce: aBuffer to: 'unsigned char *'.
	self cCode: 'outputRowsPtr = (unsigned char **) memoryAllocate(1,sizeof(unsigned char*) * outHeight)'.

	0 to: outHeight-1 do: [:i | outputRowsPtr at: i put: (bufferBaseAddr + (aByteNumber*i))].
		
	self cCode: 'result = mpeg3_read_frame(file,outputRowsPtr,xNumber,yNumber,width,height,outWidth,outHeight,model,aNumber)'.
	self cCode: 'memoryFree(outputRowsPtr)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:02'!
primitiveMPEG3SampleRate: fileHandle stream: aNumber
	| file result |

	"int mpeg3_sample_rate(mpeg3_t *file,int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3SampleRate'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_sample_rate(file,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:03'!
primitiveMPEG3SeekPercentage: fileHandle percentage: aNumber
	| file result |

	"int mpeg3_seek_percentage(mpeg3_t *file, double percentage)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3SeekPercentage'
		parameters: #(Oop Float).
	file := self mpeg3tValueOf: fileHandle.
	aNumber < 0.0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber > 1.0 ifTrue: [interpreterProxy success: false. ^nil].
	file = nil ifTrue: [^nil].
	self cCode: 'result = mpeg3_seek_percentage(file,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:00'!
primitiveMPEG3SetCpus: fileHandle number: cpus
	| file |

	"int mpeg3_set_cpus(mpeg3_t *file, int cpus)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3SetCpus'
		parameters: #(Oop SmallInteger).
	file := self mpeg3tValueOf: fileHandle.
	cpus < 0 ifTrue: [interpreterProxy success: false. ^nil].
	file = nil ifTrue: [^nil].
	self cCode: 'mpeg3_set_cpus(file,cpus)'.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:58'!
primitiveMPEG3SetFrame: fileHandle frame: aFrameNumber stream: aNumber
	| file result |

	"int mpeg3_set_frame(mpeg3_t *file, long frame, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3SetFrame'
		parameters: #(Oop Float SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_set_frame(file,(long) aFrameNumber,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:59'!
primitiveMPEG3SetMmx: fileHandle useMmx: mmx
	| file |

	"int mpeg3_set_mmx(mpeg3_t *file, int use_mmx)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3SetMmx'
		parameters: #(Oop Boolean).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	self cCode: 'mpeg3_set_mmx(file,mmx)'.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:02'!
primitiveMPEG3SetSample: fileHandle sample: aSampleNumber stream: aNumber
	| file result |

	"int mpeg3_set_sample(mpeg3_t *file, long sample, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3SetSample'
		parameters: #(Oop Float SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_astreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	aSampleNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	self cCode: 'result = mpeg3_set_sample(file,aSampleNumber,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 4/12/2006 12:11'!
primitiveMPEG3TellPercentage: fileHandle
	| file result |

	"double mpeg3_tell_percentage(mpeg3_t *file)"
	<var: #result type: 'double '>
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3TellPercentage'
		parameters: #(Oop).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	self cCode: 'result = mpeg3_tell_percentage(file)'.
	^result asOop: Float.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:00'!
primitiveMPEG3TotalAStreams: fileHandle
	| file result |

	"int mpeg3_total_astreams(mpeg3_t *file)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3TotalAStreams'
		parameters: #(Oop).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	self cCode: 'result = mpeg3_total_astreams(file)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:03'!
primitiveMPEG3TotalVStreams: fileHandle
	| file result |

	"int mpeg3_total_vstreams(mpeg3_t *file)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3TotalVStreams'
		parameters: #(Oop).
	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^nil].
	self cCode: 'result = mpeg3_total_vstreams(file)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 20:58'!
primitiveMPEG3VideoFrames: fileHandle stream: aNumber
	| file result |

	"long mpeg3_video_frames(mpeg3_t *file, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3VideoFrames'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_video_frames(file,aNumber)'.
	^result asOop: Float.
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:01'!
primitiveMPEG3VideoHeight: fileHandle stream: aNumber
	| file result |

	"int mpeg3_video_height(mpeg3_t *file,int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3VideoHeight'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_video_height(file,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:01'!
primitiveMPEG3VideoWidth: fileHandle stream: aNumber
	| file result |

	"int mpeg3_video_width(mpeg3_t *file, int stream)"
	<var: #file type: 'mpeg3_t * '>
	self primitive: 'primitiveMPEG3VideoWidth'
		parameters: #(Oop SmallInteger).

	file := self mpeg3tValueOf: fileHandle.
	file = nil ifTrue: [^0].
	aNumber < 0 ifTrue: [interpreterProxy success: false. ^nil].
	aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
		interpreterProxy success: false.  ^0 ].


	self cCode: 'result = mpeg3_video_width(file,aNumber)'.
	^result asSmallIntegerObj
! !
!Mpeg3Plugin methodsFor: 'support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:12'!
removeFileEntry: aMpegFile
	<var: #aMpegFile type: 'mpeg3_t * '>
	1 to: maximumNumberOfFilesToWatch do: 
		[:i | ((mpegFiles at: i) = aMpegFile) ifTrue: 
				[mpegFiles at: i put: 0.
				^true]].
	"Just ignore"
	^false
		
	! !
!Mpeg3Plugin methodsFor: 'support' stamp: 'JMM (auto pragmas 12/08) 10/2/2000 12:03'!
shutdownModule
	<export: true>
	1 to: maximumNumberOfFilesToWatch do: 
		[:i | ((mpegFiles at: i) ~= 0) ifTrue:
			[self cCode: 'mpeg3_close(mpegFiles[i])'.
			mpegFiles at: i put: 0]].
	^self cCode:  'true' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #QuicktimePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!QuicktimePlugin class methodsFor: 'translation' stamp: 'JMM 1/17/2006 20:24'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!QuicktimePlugin class methodsFor: 'translation' stamp: 'JMM 1/17/2006 20:24'!
requiresCrossPlatformFiles
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM (auto pragmas 12/08) 1/17/2006 15:53'!
initialiseModule
	<export: true>
	^self sqQuicktimeInitialize ! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM (auto pragmas 12/08) 1/17/2006 15:53'!
moduleUnloaded: aModuleName 
	"The module with the given name was just unloaded. 
	Make sure we have no dangling references."
	<export: true>
	<var: #aModuleName type: 'char *'>
	(aModuleName strcmp: 'QuicktimePlugin') = 0
		ifTrue: [self sqQuicktimeShutdown]! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM 1/17/2006 23:05'!
primitiveClearFrameCompletedSemaphore: data

	self primitive: 'primitiveClearFrameCompletedSemaphore' parameters: #(SmallInteger).
	self stQuicktimeClearSemaphore: data.
	^nil! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM 1/17/2006 23:05'!
primitiveDestroyHandle: data 

	self primitive: 'primitiveDestroyHandle' parameters: #(SmallInteger).
	self stQuicktimeDestroy: data.
	^nil! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM 3/16/2006 09:32'!
primitiveDestroySurface: data 

	self primitive: 'primitiveDestroySurface' parameters: #(SmallInteger).
	self stQuicktimeDestroySurface: data.
	^nil! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM 1/17/2006 23:06'!
primitiveSetFrameCompletedSemaphore: semaIndex for: data

	self primitive: 'primitiveSetFrameCompletedSemaphore'  parameters:#(SmallInteger SmallInteger).
	self stQuicktimeSetSemaphore: semaIndex for: data.
	^nil! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM 3/16/2006 11:30'!
primitiveSetGWorldPtrOntoExistingSurface: surfaceID gWorld: bitMapPtr width: width height: height rowBytes: rowBytes depth: depth movie: moviePtr
	| buffer movie |

	self primitive: 'primitiveSetGWorldPtrOntoExistingSurface'  parameters:#(SmallInteger Oop SmallInteger SmallInteger SmallInteger SmallInteger Oop).
	buffer := self cCoerce: (interpreterProxy positive32BitValueOf: bitMapPtr) to: 'char *'.
	movie := self cCoerce: (interpreterProxy positive32BitValueOf: moviePtr) to: 'long'.
	self stQuicktimeSetToExistingSurface: surfaceID gworld: buffer width: width height: height rowBytes: rowBytes depth: depth movie: movie.
	! !
!QuicktimePlugin methodsFor: 'system primitives' stamp: 'JMM 3/16/2006 11:30'!
primitiveSetGWorldPtrOntoSurface: bitMapPtr width: width height: height rowBytes: rowBytes depth: depth movie: moviePtr
	| buffer movie results |

	self primitive: 'primitiveSetGWorldPtrOntoSurface'  parameters:#(Oop SmallInteger SmallInteger SmallInteger SmallInteger Oop).
	buffer := self cCoerce: (interpreterProxy positive32BitValueOf: bitMapPtr) to: 'char *'.
	movie := self cCoerce: (interpreterProxy positive32BitValueOf: moviePtr) to: 'long'.
	results := self stQuicktimeSetSurface: buffer width: width height: height rowBytes: rowBytes depth: depth movie: movie.
	^results asOop: SmallInteger ! !

SmartSyntaxInterpreterPlugin subclass: #RePlugin
	instanceVariableNames: 'netMemory numAllocs numFrees lastAlloc patternStr rcvr compileFlags pcrePtr extraPtr errorStr errorOffset matchFlags patternStrPtr errorStrBuffer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!RePlugin commentStamp: '<historical>' prior: 0!
/*	Regular Expression Plugin (This class comment becomes part of rePlugin.c)

	RePlugin translate: 'RePlugin.c' doInlining: true.

See documentation and source code for the PCRE C Library Code.  This plugin is designed to serve an object such as RePattern:

	patternStr		A 0-terminated string comprising the pattern to be compiled.
	compileFlags	An Integer representing re compiler options
	PCREBuffer		A ByteArray of regular expression bytecodes
	extraPtr			A ByteArray of match optimization data (or nil)
	errorString		A String Object For Holding an Error Message (when compile failed)
	errorOffset		The index in patternStr (0-based) where the error ocurred (when compile failed)
	matchFlags		An Integer representing re matcher options
	matchSpaceObj	An Integer array for match results and workspace during matching.

The instance variables must appear in the preceding order.  MatchSpaceObj must be allocated by the calling routine and contain at least 6*(numGroups+1) bytes.
*/
#include "pcre.h"
#include "internal.h"

/* Slight machine-specific hack for MacOS Memory Management */
#ifdef TARGET_OS_MAC
#define	malloc(ptr) NewPtr(ptr)
#define free(ptr) DisposePtr(aPointer)
#endif

/* Adjust malloc and free routines as used by PCRE */
void rePluginFree(void * aPointer);
void * rePluginMalloc(size_t anInteger);
void *(*pcre_malloc)(size_t) = rePluginMalloc;
void  (*pcre_free)(void *) = rePluginFree;
!
!RePlugin class methodsFor: 'plugin code generation' stamp: 'tpr 12/29/2005 17:16'!
declareCVarsIn: cg

	cg addHeaderFile:'"rePlugin.h"'.

	"Memory Management Error Checking"
	cg var: 'netMemory' 	declareC: 'int netMemory = 0'.
	cg var: 'numAllocs' 	declareC: 'int numAllocs = 0'.
	cg var: 'numFrees' 		declareC: 'int numFrees = 0'.
	cg var: 'lastAlloc'		declareC: 'int lastAlloc = 0'.

	"Support Variables for Access to Receiver Instance Variables"
	cg var: 'patternStrPtr' type: 'const char * '.
	cg var: 'errorStrBuffer'	type: 'const char * '.! !
!RePlugin class methodsFor: 'plugin code generation' stamp: 'acg 8/16/2002 22:51'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!RePlugin class methodsFor: 'plugin code generation' stamp: 'nk 11/21/2002 15:54'!
moduleName

	^'RePlugin'! !
!RePlugin class methodsFor: 'plugin code generation' stamp: 'acg 7/27/2002 20:09'!
requiresCrossPlatformFiles
	"default is ok for most, any plugin needing cross platform files must say so"
	^true! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:07'!
allocateByteArrayAndSetRcvrExtraPtrFrom: anExtraPtr

	| extraObject extraByteArrayPtr |
	<var: #extraByteArrayPtr type: 'void *'>

	anExtraPtr
		ifFalse: [extraObject := interpreterProxy nilObject]
		ifTrue: [
			"Allocate a Smalltalk ByteArray -- lastAlloc contains the length"
			extraObject := interpreterProxy
						instantiateClass: (interpreterProxy classByteArray) 
						indexableSize: (self cCode: 'sizeof(real_pcre_extra)').
			self loadRcvrFromStackAt: 0. "Assume garbage collection after instantiation"

			"Copy from the C bytecode buffer to the Smalltalk ByteArray"
			extraByteArrayPtr := interpreterProxy arrayValueOf: extraObject.	
			self cCode:'memcpy(extraByteArrayPtr, (void *) anExtraPtr, sizeof(real_pcre_extra))'].
 
	"Set rcvrErrorStr from errorStr and Return"
	self rcvrExtraPtrFrom: extraObject.
	self touch: extraByteArrayPtr.	
	^extraObject.
! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:13'!
allocateByteArrayAndSetRcvrPCREPtrFromPCRE: aPCREPtr

	| patObject patByteArrayPtr |
	<var: #patByteArrayPtr type: 'void *'>

	"Allocate a Smalltalk ByteArray -- lastAlloc contains the length"
	patObject := interpreterProxy
				instantiateClass: (interpreterProxy classByteArray) 
				indexableSize: lastAlloc.
	self loadRcvrFromStackAt: 0. "Assume garbage collection after instantiation"

	"Copy from the C bytecode buffer to the Smalltalk ByteArray"
	patByteArrayPtr := interpreterProxy arrayValueOf: patObject.	
	self cCode:'memcpy(patByteArrayPtr, (void *) aPCREPtr, lastAlloc)'.
 
	"Set rcvrErrorStr from errorStr and Return"
	self rcvrPCREBufferFrom: patObject.
	self touch: patByteArrayPtr.	
	^patObject.
! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:13'!
allocateStringAndSetRcvrErrorStrFromCStr: aCStrBuffer

	|length errorStrObj errorStrObjPtr |
	<var: #aCStrBuffer type: 'const char *'>
	<var: #errorStrObjPtr type: 'void *'>
	"Allocate errorStrObj"
	length := self cCode: 'strlen(aCStrBuffer)'.
	errorStrObj := interpreterProxy
				instantiateClass: (interpreterProxy classString) 
				indexableSize: length.
	self loadRcvrFromStackAt: 0. "Assume garbage collection after instantiation"

	"Copy aCStrBuffer to errorStrObj's buffer"
	errorStrObjPtr := interpreterProxy arrayValueOf: errorStrObj.	
	self cCode:'memcpy(errorStrObjPtr,aCStrBuffer,length)'.
	self touch: errorStrObjPtr; touch: errorStrObj.
	"Set rcvrErrorStr from errorStrObj and Return"
	self rcvrErrorStrFrom: errorStrObj.
	^errorStrObj.! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas dtl 2010-09-28) 2/21/1999 22:58'!
loadRcvrFromStackAt: stackInteger

	<inline: true>
	rcvr := interpreterProxy stackObjectValue: stackInteger.
! !
!RePlugin methodsFor: 'memory management' stamp: 'acg (auto pragmas 12/08) 2/25/1999 08:36'!
primLastAlloc
	
	<export: true>
	interpreterProxy pop:1; pushInteger: lastAlloc
! !
!RePlugin methodsFor: 'memory management' stamp: 'acg (auto pragmas 12/08) 2/21/1999 23:20'!
primNetMemory 
	
	<export: true>
	interpreterProxy pop:1; pushInteger: netMemory
! !
!RePlugin methodsFor: 'memory management' stamp: 'acg (auto pragmas 12/08) 2/21/1999 23:20'!
primNumAllocs

	<export: true>
	interpreterProxy pop:1; pushInteger: numAllocs
! !
!RePlugin methodsFor: 'memory management' stamp: 'acg (auto pragmas 12/08) 2/21/1999 23:20'!
primNumFrees 
	
	<export: true>
	interpreterProxy pop:1; pushInteger: numFrees
! !
!RePlugin methodsFor: 're primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:08'!
primPCRECompile

"<rcvr primPCRECompile>, where rcvr is an object with instance variables:

	'patternStr compileFlags pcrePtr extraPtr errorStr errorOffset matchFlags'	

Compile the regular expression in patternStr, and if the compilation is successful, attempt to optimize the compiled expression.  Store the results in <pcrePtr> and <extratr>, or fill errorStr with a meaningful errorString and errorOffset with an indicator where the error was found, applying compileFlags throughout.  Answer nil with a clean compile (regardless of whether an optimization is possible, and answer with the string otherwise."


	<export: true>
	self loadRcvrFromStackAt: 0.
	patternStrPtr := self rcvrPatternStrPtr.
	compileFlags := self rcvrCompileFlags.
	interpreterProxy failed ifTrue:[^ nil].

	pcrePtr := self cCode: '(int) pcre_compile(patternStrPtr, compileFlags, 
					&errorStrBuffer, &errorOffset, NULL)'.
	pcrePtr
		ifTrue: [
			self allocateByteArrayAndSetRcvrPCREPtrFromPCRE: pcrePtr.
			extraPtr := self cCode: '(int) pcre_study((pcre *)pcrePtr, compileFlags, &errorStrBuffer)'.
			self allocateByteArrayAndSetRcvrExtraPtrFrom: extraPtr.
			self rePluginFree: (self cCoerce: pcrePtr to: 'void *').
			extraPtr ifTrue: [self rePluginFree: (self cCoerce: extraPtr to: 'void *')].
			interpreterProxy failed ifTrue:[^ nil].
			interpreterProxy pop: 1 thenPush: interpreterProxy nilObject]
		ifFalse: [
			errorStr := self allocateStringAndSetRcvrErrorStrFromCStr: errorStrBuffer.
			self rcvrErrorOffsetFrom: errorOffset.
			interpreterProxy failed ifTrue:[^ nil].
			interpreterProxy pop: 1 thenPush: errorStr].! !
!RePlugin methodsFor: 're primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 4/12/2006 12:15'!
primPCREExec

"<rcvr primPCREExec: searchObject>, where rcvr is an object with instance variables:

	'patternStr compileFlags pcrePtr extraPtr errorStr errorOffset matchFlags'	

Apply the regular expression (stored in <pcrePtr> and <extratr>, generated from calls to primPCRECompile), to smalltalk String searchObject using <matchOptions>.  If there is no match, answer nil.  Otherwise answer a ByteArray of offsets representing the results of the match."

	| searchObject searchBuffer length  result matchSpacePtr matchSpaceSize |
	<export: true>
	<var: #searchBuffer type: 'char *'>
	<var: #matchSpacePtr type: 'int *'>
	
	"Load Parameters"
	searchObject := interpreterProxy stackObjectValue: 0.	
	searchBuffer := interpreterProxy arrayValueOf: searchObject.
	length := interpreterProxy byteSizeOf: searchObject.
	self loadRcvrFromStackAt: 1.
	"Load Instance Variables"
	pcrePtr := self rcvrPCREBufferPtr.
	extraPtr := self rcvrExtraPtr.
	matchFlags := self rcvrMatchFlags.
	matchSpacePtr := self rcvrMatchSpacePtr.
	matchSpaceSize := self rcvrMatchSpaceSize.

	interpreterProxy failed ifTrue:[^ nil].
	
	result := self 
		cCode: 'pcre_exec((pcre *)pcrePtr, (pcre_extra *)extraPtr, 
				searchBuffer, length, 0, matchFlags, matchSpacePtr, matchSpaceSize)'.

	interpreterProxy pop: 2; pushInteger: result.

	"empty call so compiler doesn't bug me about variables not used"
	self touch: searchBuffer; touch: matchSpacePtr; touch: matchSpaceSize; touch: length
! !
!RePlugin methodsFor: 're primitives' stamp: 'tpr (auto pragmas dtl 2010-09-28) 4/12/2006 12:16'!
primPCREExecfromto

"<rcvr primPCREExec: searchObject> from: fromInteger to: toInteger>, where rcvr is an object with instance variables:

	'patternStr compileFlags pcrePtr extraPtr errorStr errorOffset matchFlags'	

Apply the regular expression (stored in <pcrePtr> and <extratr>, generated from calls to primPCRECompile), to smalltalk String searchObject using <matchOptions>, beginning at offset <fromInteger> and continuing until offset <toInteger>.  If there is no match, answer nil.  Otherwise answer a ByteArray of offsets representing the results of the match."

	| searchObject searchBuffer length  result matchSpacePtr matchSpaceSize fromInteger toInteger |
	<export: true>
	<var: #searchBuffer type: 'char *'>
	<var: #matchSpacePtr type: 'int *'>
	
	"Load Parameters"
	toInteger := interpreterProxy stackIntegerValue: 0.
	fromInteger := interpreterProxy stackIntegerValue: 1.
	searchObject := interpreterProxy stackObjectValue: 2.	
	searchBuffer := interpreterProxy arrayValueOf: searchObject.
	length := interpreterProxy byteSizeOf: searchObject.
	self loadRcvrFromStackAt: 3.

	"Validate parameters"
	interpreterProxy success: (1 <= fromInteger).
	interpreterProxy success: (toInteger<=length).
	fromInteger := fromInteger - 1. "Smalltalk offsets are 1-based"
	interpreterProxy success: (fromInteger<=toInteger).

	"adjust length, searchBuffer"
	length := toInteger - fromInteger.
	searchBuffer := searchBuffer + fromInteger.

	"Load Instance Variables"
	pcrePtr := self rcvrPCREBufferPtr.
	extraPtr := self rcvrExtraPtr.
	matchFlags := self rcvrMatchFlags.
	matchSpacePtr := self rcvrMatchSpacePtr.
	matchSpaceSize := self rcvrMatchSpaceSize.
	interpreterProxy failed ifTrue:[^ nil].
	
	result := self 
		cCode: 'pcre_exec((pcre *)pcrePtr, (pcre_extra *)extraPtr, 
				searchBuffer, length, 0, matchFlags, matchSpacePtr, matchSpaceSize)'.
	interpreterProxy pop: 2; pushInteger: result.

	"empty call so compiler doesn't bug me about variables not used"
	self touch: searchBuffer; touch: matchSpacePtr; touch: matchSpaceSize; touch: length
! !
!RePlugin methodsFor: 're primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:08'!
primPCRENumSubPatterns

"<rcvr primPCRENumSubPatterns>, where rcvr is an object with instance variables:

	'patternStr compileFlags pcrePtr extraPtr errorStr errorOffset matchFlags'	

Return the number of subpatterns captured by the compiled pattern."

	<export: true>
	
	"Load Parameters"
	self loadRcvrFromStackAt: 0.
	"Load Instance Variables"
	pcrePtr := self rcvrPCREBufferPtr.
	interpreterProxy pop: 1; pushInteger: (self cCode: 'pcre_info((pcre *)pcrePtr, NULL, NULL)').
! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas dtl 2010-09-28) 2/21/1999 21:20'!
rcvrCompileFlags

	<inline: true>
	^interpreterProxy fetchInteger: 1 ofObject: rcvr.
! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/21/1999 22:46'!
rcvrErrorOffsetFrom: anInteger

	<inline: true>
	interpreterProxy storeInteger: 5 ofObject: rcvr withValue: anInteger.
! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/24/1999 20:53'!
rcvrErrorStrFrom: aString

	<inline: true>
	interpreterProxy 
		storePointer: 4
		ofObject: rcvr 
		withValue: aString.
! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-28) 12/1/2009 21:40'!
rcvrExtraPtr

	|extraObj|
	<inline: true>
	extraObj := interpreterProxy fetchPointer: 3 ofObject: rcvr.
	(extraObj = (interpreterProxy nilObject))
		ifTrue: [^ self cCode: ' NULL'].
	^self 
		cCoerce:(interpreterProxy arrayValueOf: extraObj)
		to: 'int'.! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/27/1999 23:42'!
rcvrExtraPtrFrom: aByteArrayOrNilObject

	<inline: true>
	interpreterProxy 
		storePointer: 3 
		ofObject: rcvr 
		withValue: aByteArrayOrNilObject! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/21/1999 21:19'!
rcvrMatchFlags

	<inline: true>
	^interpreterProxy fetchInteger: 6 ofObject: rcvr.
! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/25/1999 00:49'!
rcvrMatchSpacePtr

	<inline: true>
	<returnTypeC: 'int *'>
	^self
		cCoerce: (interpreterProxy fetchArray: 7 ofObject: rcvr)
		to: 'int *'.! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/25/1999 00:52'!
rcvrMatchSpaceSize

	<inline: true>
	^(interpreterProxy byteSizeOf: (interpreterProxy fetchPointer: 7 ofObject: rcvr))//4.! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/24/1999 21:33'!
rcvrPCREBufferFrom: aByteArray

	<inline: true>
	interpreterProxy 
		storePointer: 2 
		ofObject: rcvr 
		withValue: aByteArray! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/24/1999 21:33'!
rcvrPCREBufferPtr

	<inline: true>
	^self
		cCoerce: (interpreterProxy fetchArray: 2 ofObject: rcvr)
		to: 'int'.! !
!RePlugin methodsFor: 'rcvr linkage' stamp: 'acg (auto pragmas 12/08) 2/24/1999 21:34'!
rcvrPatternStrPtr

	<inline: true>
	<returnTypeC: 'char *'>
	^self 
		cCoerce: (interpreterProxy fetchArray: 0 ofObject: rcvr) 
		to: 'char *'.! !
!RePlugin methodsFor: 'memory management' stamp: 'dtl (auto pragmas dtl 2010-09-28) 9/14/2008 21:41'!
rePluginFree: aPointer
	"Free a block of fixed memory allocated with rePluginMalloc.  Instrumented version of C free() to facilitate leak analysis from Smalltalk.   OS-specific variations on malloc/free, such as with MacOS, are handled by adding a C macro to the header file redefining malloc/free -- see the class comment"

	<inline: false>
	<var: #aPointer type: 'void * '>
	<returnTypeC: 'void'>

	numFrees := numFrees + 1.
	(aPointer)
		ifTrue: [self cCode: 'free(aPointer)']	! !
!RePlugin methodsFor: 'memory management' stamp: 'dtl (auto pragmas dtl 2010-09-28) 9/14/2008 21:42'!
rePluginMalloc: anInteger
	"Allocate a block of fixed memory using C calls to malloc().  Instrumented to facilitate leak analysis from Smalltalk.  Set global lastAlloc to anInteger.  OS-specific variations on malloc/free, such as with MacOS, are handled by adding a C macro to the header file redefining malloc/free -- see the class comment"

	| aPointer |
	<inline: false>
	<var: #anInteger type: 'size_t '>
	<var: #aPointer type: 'void *'>
	<returnTypeC: 'void *'>
	numAllocs := numAllocs + 1.
	(aPointer := self cCode: 'malloc(anInteger)')
		ifTrue: [lastAlloc := anInteger].
	^aPointer
! !

SmartSyntaxInterpreterPlugin subclass: #SerialPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!SerialPlugin commentStamp: 'tpr 5/2/2003 15:49' prior: 0!
Implement the serial port primitives.  Since it requires platform support it will only be built when supported on your platform!
!SerialPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:11'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!SerialPlugin class methodsFor: 'translation' stamp: 'tpr 11/29/2000 22:38'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!SerialPlugin methodsFor: 'private' stamp: 'dtl (auto pragmas dtl 2010-09-28) 4/21/2009 00:04'!
allocateTerminatedString: unterminatedCharactersInStringObject
	"Allocate a C string with contents of a String value. May cause garbage collection."

	| len terminatedString p |
	<inline: true>
	<returnTypeC: 'char *'>
	<var: #unterminatedCharactersInStringObject type: 'char *'>
	<var: #p type: 'char *'>
	len := interpreterProxy sizeOfSTArrayFromCPrimitive: unterminatedCharactersInStringObject.
	terminatedString := interpreterProxy
		instantiateClass: interpreterProxy classString
		indexableSize: len + 1.
	p := interpreterProxy arrayValueOf: terminatedString.
	p at: len put: 0. "null terminator"
	[len >= 0] whileTrue:
		[len := len - 1.
		p at: len put: (unterminatedCharactersInStringObject at: len)].
	^ p
! !
!SerialPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:53'!
initialiseModule
	<export: true>
	^self cCode: 'serialPortInit()' inSmalltalk:[true]! !
!SerialPlugin methodsFor: 'primitives' stamp: 'TPR 2/17/2000 18:16'!
primitiveSerialPortClose: portNum

	self primitive: 'primitiveSerialPortClose'
		parameters: #(SmallInteger).
	self serialPortClose: portNum! !
!SerialPlugin methodsFor: 'primitives' stamp: 'dtl 9/28/2010 19:48'!
primitiveSerialPortCloseByName: deviceName

	| cString |
	<var: #cString type: 'char *'>
	self primitive: 'primitiveSerialPortCloseByName'
		parameters: #(ByteArray).
	cString := self allocateTerminatedString: deviceName.
	self serialPortCloseByName: cString! !
!SerialPlugin methodsFor: 'primitives' stamp: 'TPR 2/11/2000 16:08'!
primitiveSerialPortOpen: portNum baudRate: baudRate stopBitsType: stopBitsType parityType: parityType dataBits: dataBits inFlowControlType: inFlowControl outFlowControlType: outFlowControl xOnByte: xOnChar xOffByte: xOffChar

	self primitive: 'primitiveSerialPortOpen'
		parameters: #(SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger ).

	self cCode: 'serialPortOpen(
			portNum, baudRate, stopBitsType, parityType, dataBits,
			inFlowControl, outFlowControl, xOnChar, xOffChar)'! !
!SerialPlugin methodsFor: 'primitives' stamp: 'dtl 9/28/2010 19:48'!
primitiveSerialPortOpenByName: deviceName baudRate: baudRate stopBitsType: stopBitsType parityType: parityType dataBits: dataBits inFlowControlType: inFlowControl outFlowControlType: outFlowControl xOnByte: xOnChar xOffByte: xOffChar

	| cString |
	<var: #cString type: 'char *'>
	self primitive: 'primitiveSerialPortOpenByName'
		parameters: #(ByteArray SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger ).
	cString := self allocateTerminatedString: deviceName.
	self cCode: 'serialPortOpenByName(
			cString, baudRate, stopBitsType, parityType, dataBits,
			inFlowControl, outFlowControl, xOnChar, xOffChar)'! !
!SerialPlugin methodsFor: 'primitives' stamp: 'dtl 4/20/2009 23:04'!
primitiveSerialPortRead: portNum into: array startingAt: startIndex count: count 
	| bytesRead |
	self primitive: 'primitiveSerialPortRead'
		parameters: #(SmallInteger ByteArray SmallInteger SmallInteger ).

	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
	"adjust for zero-origin indexing"
	bytesRead := self
			serialPort: portNum
			Read: count
			Into: array + startIndex - 1.
	^ bytesRead asSmallIntegerObj! !
!SerialPlugin methodsFor: 'primitives' stamp: 'dtl 9/28/2010 19:46'!
primitiveSerialPortReadByName: deviceName into: array startingAt: startIndex count: count 
	| bytesRead cString |
	<var: #cString type: 'char *'>
	self primitive: 'primitiveSerialPortReadByName'
		parameters: #(ByteArray ByteArray SmallInteger SmallInteger ).

	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
	cString := self allocateTerminatedString: deviceName.
	"adjust for zero-origin indexing"
	bytesRead := self
			serialPort: cString
			Read: count
			IntoByName: array + startIndex - 1.
	^ bytesRead asSmallIntegerObj! !
!SerialPlugin methodsFor: 'primitives' stamp: 'dtl 4/20/2009 23:02'!
primitiveSerialPortWrite: portNum from: array startingAt: startIndex count: count 
	| bytesWritten |
	self primitive: 'primitiveSerialPortWrite'
		parameters: #(SmallInteger ByteArray SmallInteger SmallInteger ).

	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
	interpreterProxy failed
		ifFalse: [bytesWritten := self
						serialPort: portNum
						Write: count
						From: array + startIndex - 1].
	^ bytesWritten asSmallIntegerObj! !
!SerialPlugin methodsFor: 'primitives' stamp: 'dtl 9/28/2010 19:47'!
primitiveSerialPortWriteByName: deviceName from: array startingAt: startIndex count: count 
	| bytesWritten cString |
	<var: #cString type: 'char *'>
	self primitive: 'primitiveSerialPortWriteByName'
		parameters: #(ByteArray ByteArray SmallInteger SmallInteger ).
	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
	interpreterProxy failed
		ifFalse: [cString := self allocateTerminatedString: deviceName.
				bytesWritten := self
						serialPort: cString
						Write: count
						FromByName: array + startIndex - 1].
	^ bytesWritten asSmallIntegerObj! !
!SerialPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:55'!
shutdownModule
	<export: true>
	^self cCode: 'serialPortShutdown()' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #SlangTestSupportSSIP
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Tests'!
!SlangTestSupportSSIP commentStamp: 'dtl 9/19/2010 11:38' prior: 0!
SlangTestSupportSSIP implements translatable methods for use in SlangTest unit tests.
It is a subclass of SmartSyntaxInterpreterPlugin, which requires additional
test coverage.

	"VMMaker clearCacheEntriesFor: SlangTestSupportSSIP.
	SlangTestSupportSSIP asCString"!
!SlangTestSupportSSIP methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:29'!
declareExportFalseByMethod
	"SlangTestSupportSSIP asCString: #declareExportFalseByMethod"

	self export: false
! !
!SlangTestSupportSSIP methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:29'!
declareExportFalseByPragma
	"SlangTestSupportSSIP asCString: #declareExportFalseByPragma"

	<export: false>
! !
!SlangTestSupportSSIP methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:21'!
declareExportTrueByMethod
	"SlangTestSupportSSIP asCString: #declareExportTrueByMethod"

	self export: true
! !
!SlangTestSupportSSIP methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:21'!
declareExportTrueByPragma
	"SlangTestSupportSSIP asCString: #declareExportTrueByPragma"

	<export: true>
! !
!SlangTestSupportSSIP methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:29'!
declareStaticFalseByMethod
	"SlangTestSupportSSIP asCString: #declareStaticFalseByMethod"

	self static: false
! !
!SlangTestSupportSSIP methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:30'!
declareStaticFalseByPragma
	"SlangTestSupportSSIP asCString: #declareStaticFalseByPragma"

	<static: false>
! !
!SlangTestSupportSSIP methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:29'!
declareStaticTrueByMethod
	"SlangTestSupportSSIP asCString: #declareStaticTrueByMethod"

	self static: true
! !
!SlangTestSupportSSIP methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:30'!
declareStaticTrueByPragma
	"SlangTestSupportSSIP asCString: #declareStaticTrueByPragma"

	<static: true>
! !
!SlangTestSupportSSIP methodsFor: 'inlining' stamp: 'dtl 9/19/2010 11:50'!
inlineByMethod
	"SlangTestSupportSSIP asCString: #inlineByMethod"
	"SlangTestSupportSSIP asInlinedCString: #inlineByMethod"

	| bar foo |
	foo := self methodThatShouldBeInlinedByMethod.
	bar := self methodThatShouldNotBeInlinedByMethod! !
!SlangTestSupportSSIP methodsFor: 'inlining' stamp: 'dtl 9/19/2010 11:50'!
inlineByPragma
	"SlangTestSupportSSIP asCString: #inlineByPragma"
	"SlangTestSupportSSIP asInlinedCString: #inlineByPragma"

	| bar foo |
	foo := self methodThatShouldBeInlinedByPragma.
	bar := self methodThatShouldNotBeInlinedByPragma! !
!SlangTestSupportSSIP methodsFor: 'inlining' stamp: 'dtl 9/18/2010 17:59'!
methodThatShouldBeInlinedByMethod

	self inline: true.
	^ #foo! !
!SlangTestSupportSSIP methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldBeInlinedByPragma

	<inline: true>
	^ #foo! !
!SlangTestSupportSSIP methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldNotBeInlinedByMethod

	self inline: false.
	^ #bar! !
!SlangTestSupportSSIP methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldNotBeInlinedByPragma

	<inline: false>
	^ #bar! !
!SlangTestSupportSSIP methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:50'!
returnTypeByMethod
	"SlangTestSupportSSIP asCString: #returnTypeByMethod"

	self returnTypeC: 'char *'.
! !
!SlangTestSupportSSIP methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:51'!
returnTypeByPragma
	"SlangTestSupportSSIP asCString: #returnTypeByPragma"

	<returnTypeC: 'char *'>
! !
!SlangTestSupportSSIP methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:51'!
varDefByMethod
	"SlangTestSupportSSIP asCString: #varDefByMethod"

	| foo bar |
	self var: #foo type: 'char *'.
	self var: #bar declareC: 'unsigned int * bar'
! !
!SlangTestSupportSSIP methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 22:25'!
varDefByMethodAndPragma
	"SlangTestSupportSSIP asCString: #varDefByMethodAndPragma"

	| foo bar baz fum |
	<var: #baz type: 'float'>
	<var: #fum declareC: 'double fum'>
	self var: #foo type: 'char *'.
	self var: #bar declareC: 'unsigned int * bar'
! !
!SlangTestSupportSSIP methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 12:05'!
varDefByPragma
	"SlangTestSupportSSIP asCString: #varDefByPragma"

	| foo bar |
	<var: #foo type: 'char *'>
	<var: #bar declareC: 'unsigned int * bar'>
! !
!SmartSyntaxInterpreterPlugin class methodsFor: 'private' stamp: 'tpr 6/9/2003 16:36'!
codeGeneratorClass
	"return the appropriate class of code generator for this kind ofplugin"

	^SmartSyntaxPluginCodeGenerator! !
!SmartSyntaxInterpreterPlugin class methodsFor: 'instance creation' stamp: 'tpr 6/28/2003 17:28'!
doPrimitive: primitiveName withArguments: argArray
	| proxy plugin |
	proxy := InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	plugin := (self simulatorClass ifNil: [self]) new.
	plugin setInterpreter: proxy.
	^plugin perform: primitiveName asSymbol withArguments: argArray! !
!SmartSyntaxInterpreterPlugin class methodsFor: 'translation' stamp: 'tpr 6/9/2003 16:44'!
shouldBeTranslated
"SmartSyntaxInterpreterPlugin should not be translated but its subclasses should"
	^self ~= SmartSyntaxInterpreterPlugin! !
!SmartSyntaxInterpreterPlugin class methodsFor: 'instance creation' stamp: 'tpr 6/28/2003 17:28'!
simulatorClass
	"For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code.
	By default SmartSyntaxInterpreterPlugin answers nil because methods in these plugins are intended to be embedded in code that pushes and pops from the stack and therefore cannot be run independently.  This wrapper code is generated when translated to C.  But, unfortunately, this code is missing during simulation.  There was an attempt to simulate this, but only the prologue code (getting arg from the stack) is simulated (see simulatePrologInContext:). The epologue code (popping args and pushing result) is not.  So I am making this nil until this can be fixed.
	Also, beware that primitive methods that take no args exactly match their primitive name (faking out InterpreterSimulator>>callExternalPrimitive:).  They should only be called from within wrapper code that simulates the prologue and epilogue.  Primitive method that take args don't have this accidental matching problem since their names contain colons while their primitive names do not. - ajh 8/21/2002"

	^ nil! !
!SmartSyntaxInterpreterPlugin class methodsFor: 'translation' stamp: 'sr 12/23/2001 22:24'!
translateDoInlining: inlineFlag locally: localFlag debug: debugFlag 
	^ self
		translate: self moduleName , '.c'
		doInlining: inlineFlag
		locally: localFlag
		debug: debugFlag! !
!SmartSyntaxInterpreterPlugin methodsFor: 'debugging' stamp: 'sr 12/24/2001 00:29'!
sqAssert: aBool 
	self
		debugCode: [aBool
				ifFalse: [self error: 'Assertion failed!!'].
			^ aBool]! !

SmartSyntaxInterpreterPlugin subclass: #SocketPlugin
	instanceVariableNames: 'sDSAfn sHSAfn sCCTPfn sCCLOPfn sCCSOTfn'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!SocketPlugin commentStamp: 'tpr 5/2/2003 15:49' prior: 0!
Implement the socket and resolver primitives.  Since it requires platform support it will only be built when supported on your platform!
!SocketPlugin class methodsFor: 'translation' stamp: 'ikp 3/31/2005 13:43'!
declareCVarsIn: aCCodeGenerator

	aCCodeGenerator var: 'sDSAfn'	type: 'void *'.
	aCCodeGenerator var: 'sHSAfn'	type: 'void *'.
	aCCodeGenerator var: 'sCCTPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCCLOPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCCSOTfn'	type: 'void *'.
	aCCodeGenerator addHeaderFile: '"SocketPlugin.h"'! !
!SocketPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:11'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!SocketPlugin class methodsFor: 'translation' stamp: 'tpr 11/29/2000 22:38'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!SocketPlugin methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 1/21/2002 11:09'!
initialiseModule
	<export: true>
	sDSAfn := interpreterProxy ioLoadFunction: 'secDisableSocketAccess' From: 'SecurityPlugin'.
	sHSAfn := interpreterProxy ioLoadFunction: 'secHasSocketAccess' From: 'SecurityPlugin'.
	sCCTPfn := interpreterProxy ioLoadFunction: 'secCanConnectToPort' From: 'SecurityPlugin'.
	sCCLOPfn := interpreterProxy ioLoadFunction: 'secCanListenOnPort' From: 'SecurityPlugin'.
	sCCSOTfn := interpreterProxy ioLoadFunction: 'secCanCreateSocketOfType' From: 'SecurityPlugin'.
	^self cCode: 'socketInit()' inSmalltalk:[true]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:16'!
intToNetAddress: addr
	"Convert the given 32-bit integer into an internet network address represented as a four-byte ByteArray."

	| netAddressOop naPtr |
	<var: #naPtr type: 'char * '>

	netAddressOop :=
		interpreterProxy instantiateClass: interpreterProxy classByteArray
			indexableSize: 4.
	naPtr := netAddressOop asCharPtr.
	naPtr at: 0 put: (self cCoerce: ((addr >> 24) bitAnd: 16rFF) to: 'char').
	naPtr at: 1 put: (self cCoerce: ((addr >> 16) bitAnd: 16rFF) to: 'char').
	naPtr at: 2 put: (self cCoerce: ((addr >> 8) bitAnd: 16rFF) to: 'char').
	naPtr at: 3 put: (self cCoerce: (addr bitAnd: 16rFF) to: 'char').
	^ netAddressOop! !
!SocketPlugin methodsFor: 'initialize-release' stamp: 'JMM (auto pragmas 12/08) 1/21/2002 11:10'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	<export: true>
	<var: #aModuleName type: 'char *'>
	(aModuleName strcmp: 'SecurityPlugin') = 0 ifTrue:[
		"The security plugin just shut down. How odd."
		sDSAfn := sHSAfn := sCCTPfn := sCCLOPfn := sCCSOTfn := 0.
	].! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:16'!
netAddressToInt: ptrToByteArray
	"Convert the given internet network address (represented as a four-byte ByteArray) into a 32-bit integer. Fail if the given ptrToByteArray does not appear to point to a four-byte ByteArray."

	| sz |
	<var: #ptrToByteArray type: 'unsigned char * '>
	sz := interpreterProxy byteSizeOf: ptrToByteArray cPtrAsOop.
	sz = 4 ifFalse: [^ interpreterProxy primitiveFail].
	^ (ptrToByteArray at: 3	) +
		((ptrToByteArray at: 2) <<8) +
		((ptrToByteArray at: 1) <<16) +
		((ptrToByteArray at: 0) <<24)! !
!SocketPlugin methodsFor: 'security primitives' stamp: 'eem 7/10/2009 12:11'!
primitiveDisableSocketAccess
	<export: true>
	"If the security plugin can be loaded, use it to turn off socket access
	 If not, assume it's ok"
	sDSAfn ~= 0 ifTrue:
		[self cCode: '((int (*) (void)) sDSAfn)()']! !
!SocketPlugin methodsFor: 'security primitives' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-28) 5/5/2009 11:03'!
primitiveHasSocketAccess
	|  hasAccess |
	<export: true>
	"If the security plugin can be loaded, use it to check . 
	If not, assume it's ok"
	sHSAfn ~= 0
		ifTrue: [hasAccess := self cCode: ' ((int (*) (void)) sHSAfn)()' inSmalltalk:[true]]
		ifFalse: [hasAccess := true].
	interpreterProxy pop: 1.
	interpreterProxy pushBool: hasAccess! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:39'!
primitiveInitializeNetwork: resolverSemaIndex

	| err |
	self primitive: 'primitiveInitializeNetwork'
		parameters: #(SmallInteger).
	err := self sqNetworkInit: resolverSemaIndex.
	interpreterProxy success: err = 0! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 11:47'!
primitiveResolverAbortLookup

	self primitive: 'primitiveResolverAbortLookup'.

	self sqResolverAbort! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:47'!
primitiveResolverAddressLookupResult
	| sz s |
	self primitive: 'primitiveResolverAddressLookupResult'.
	sz := self sqResolverAddrLookupResultSize.

	interpreterProxy failed
		ifFalse: [s := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: sz.
			self sqResolverAddrLookup: s asCharPtr Result: sz].
	^ s! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:10'!
primitiveResolverError

	self primitive: 'primitiveResolverError'.
	^ self sqResolverError asSmallIntegerObj! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:01'!
primitiveResolverGetAddressInfoFamily

	| family |
	self primitive: 'primitiveResolverGetAddressInfoFamily'
		parameters: #().
	interpreterProxy failed
		ifFalse:
			[family := self sqResolverGetAddressInfoFamily.
			 ^family asSmallIntegerObj]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 17:23'!
primitiveResolverGetAddressInfoHost: hostName service: servName flags: flags family: family type: type protocol: protocol

	| hostSize servSize |
	self primitive: 'primitiveResolverGetAddressInfo'
		parameters: #(String String SmallInteger SmallInteger SmallInteger SmallInteger).
	interpreterProxy failed
		ifFalse:
			[hostSize := interpreterProxy byteSizeOf: hostName cPtrAsOop.
			 servSize := interpreterProxy byteSizeOf: servName cPtrAsOop.
			 self
			 	sqResolverGetAddressInfoHost: hostName Size: hostSize Service: servName Size: servSize
					Flags: flags Family: family Type: type Protocol: protocol]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:17'!
primitiveResolverGetAddressInfoNext

	| more |
	self primitive: 'primitiveResolverGetAddressInfoNext'
		parameters: #().
	more := self sqResolverGetAddressInfoNext.
	interpreterProxy failed ifTrue: [^nil].
	^more asBooleanObj! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:01'!
primitiveResolverGetAddressInfoProtocol

	| protocol |
	self primitive: 'primitiveResolverGetAddressInfoProtocol'
		parameters: #().
	interpreterProxy failed
		ifFalse:
			[protocol := self sqResolverGetAddressInfoProtocol.
			 ^protocol asSmallIntegerObj]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 17:33'!
primitiveResolverGetAddressInfoResult: socketAddress

	| addrSize |
	self primitive: 'primitiveResolverGetAddressInfoResult'
		parameters: #(ByteArray).
	interpreterProxy failed
		ifFalse:
			[addrSize := interpreterProxy byteSizeOf: socketAddress cPtrAsOop.
			 self sqResolverGetAddressInfoResult: socketAddress Size: addrSize]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 17:40'!
primitiveResolverGetAddressInfoSize

	| size |
	self primitive: 'primitiveResolverGetAddressInfoSize'
		parameters: #().
	interpreterProxy failed
		ifFalse:
			[size := self sqResolverGetAddressInfoSize.
			 ^size asSmallIntegerObj]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:01'!
primitiveResolverGetAddressInfoType

	| type |
	self primitive: 'primitiveResolverGetAddressInfoType'
		parameters: #().
	interpreterProxy failed
		ifFalse:
			[type := self sqResolverGetAddressInfoType.
			 ^type asSmallIntegerObj]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/8/2007 18:59'!
primitiveResolverGetNameInfo: socketAddress flags: flags

	| addrSize addrBase |
	<var: #addrBase type: 'char *'>
	self primitive: 'primitiveResolverGetNameInfo'
		parameters: #(Oop SmallInteger).
	interpreterProxy failed
		ifFalse:
			[addrSize := interpreterProxy byteSizeOf: socketAddress.
			 addrBase := self cCoerce: (interpreterProxy firstIndexableField: socketAddress) to: 'char *'.
			 self sqResolverGetNameInfo: addrBase Size: addrSize Flags: flags]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:49'!
primitiveResolverGetNameInfoHostResult: socketName

	| addrSize |
	self primitive: 'primitiveResolverGetNameInfoHostResult'
		parameters: #(String).
	interpreterProxy failed
		ifFalse:
			[addrSize := interpreterProxy byteSizeOf: socketName cPtrAsOop.
			 self sqResolverGetNameInfoHostResult: socketName Size: addrSize]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:38'!
primitiveResolverGetNameInfoHostSize

	| size |
	self primitive: 'primitiveResolverGetNameInfoHostSize'
		parameters: #().
	interpreterProxy failed
		ifFalse:
			[size := self sqResolverGetNameInfoHostSize.
			 ^size asSmallIntegerObj]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:50'!
primitiveResolverGetNameInfoServiceResult: socketName

	| addrSize |
	self primitive: 'primitiveResolverGetNameInfoServiceResult'
		parameters: #(String).
	interpreterProxy failed
		ifFalse:
			[addrSize := interpreterProxy byteSizeOf: socketName cPtrAsOop.
			 self sqResolverGetNameInfoServiceResult: socketName Size: addrSize]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/8/2007 18:38'!
primitiveResolverGetNameInfoServiceSize

	| size |
	self primitive: 'primitiveResolverGetNameInfoServiceSize'
		parameters: #().
	interpreterProxy failed
		ifFalse:
			[size := self sqResolverGetNameInfoServiceSize.
			 ^size asSmallIntegerObj]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/9/2007 09:03'!
primitiveResolverHostNameResult: nameString

	| nameSize |
	self primitive: 'primitiveResolverHostNameResult'
		parameters: #(String).
	interpreterProxy failed
		ifFalse:
			[nameSize := interpreterProxy byteSizeOf: nameString cPtrAsOop.
			 self sqResolverHostNameResult: nameString Size: nameSize]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp 6/9/2007 09:00'!
primitiveResolverHostNameSize

	| size |
	self primitive: 'primitiveResolverHostNameSize'
		parameters: #().
	interpreterProxy failed
		ifFalse:
			[size := self sqResolverHostNameSize.
			 interpreterProxy failed ifFalse: [^size asSmallIntegerObj]]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:10'!
primitiveResolverLocalAddress

	| addr |
	self primitive: 'primitiveResolverLocalAddress'.
	addr := self sqResolverLocalAddress.
	^self intToNetAddress: addr! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:11'!
primitiveResolverNameLookupResult

	| addr |
	self primitive: 'primitiveResolverNameLookupResult'.
	addr := self sqResolverNameLookupResult.
	^self intToNetAddress: addr! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 4/25/2000 14:42'!
primitiveResolverStartAddressLookup: address

	| addr |
	self primitive: 'primitiveResolverStartAddressLookup'
		parameters: #(ByteArray).
	addr := self netAddressToInt: (self cCoerce: address to: 'unsigned char *').
	interpreterProxy failed ifFalse: [
		self sqResolverStartAddrLookup: addr]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:19'!
primitiveResolverStartNameLookup: name

	| sz |
	self primitive: 'primitiveResolverStartNameLookup'
		parameters: #(String).
	interpreterProxy failed ifFalse:  [
		sz := interpreterProxy byteSizeOf: name cPtrAsOop.
		self sqResolverStartName: name Lookup: sz]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:20'!
primitiveResolverStatus

	| status |
	self primitive: 'primitiveResolverStatus'.
	status := self sqResolverStatus.
	^status asSmallIntegerObj! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/9/2007 09:36'!
primitiveSocket: socket bindTo: socketAddress

	| addrSize addrBase s  |
	<var: #addrBase type: 'char *'>
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketBindTo' parameters: #(#Oop #Oop).
	s := self socketValueOf: socket.
	addrSize := interpreterProxy byteSizeOf: socketAddress.
	addrBase := self cCoerce: (interpreterProxy firstIndexableField: socketAddress) to: 'char *'.
	interpreterProxy failed ifFalse: [self sqSocket: s BindToAddress: addrBase Size: addrSize]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 3/26/2006 21:32'!
primitiveSocket: socket bindTo: address port: port 
	| addr s  |
	<var: #s declareC: 'SocketPtr s'>
	self primitive: 'primitiveSocketBindToPort' parameters: #(#Oop #ByteArray #SmallInteger ).
	addr := self
				netAddressToInt: (self cCoerce: address to: 'unsigned char *').
	s := self socketValueOf: socket.
	interpreterProxy failed 
		ifFalse:[self sqSocket: s BindTo: addr Port: port]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/8/2007 22:21'!
primitiveSocket: socket connectTo: socketAddress

	| addrSize addrBase s  |
	<var: #addrBase type: 'char *'>
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketConnectTo' parameters: #(#Oop #Oop).
	s := self socketValueOf: socket.
	addrSize := interpreterProxy byteSizeOf: socketAddress.
	addrBase := self cCoerce: (interpreterProxy firstIndexableField: socketAddress) to: 'char *'.
	interpreterProxy failed ifFalse: [self sqSocket: s ConnectToAddress: addrBase Size: addrSize]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:19'!
primitiveSocket: socket connectTo: address port: port 
	| addr s okToConnect  |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketConnectToPort' parameters: #(#Oop #ByteArray #SmallInteger ).
	addr := self netAddressToInt: (self cCoerce: address to: 'unsigned char *').
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCCTPfn ~= 0
		ifTrue: [okToConnect := self cCode: ' ((int (*) (int, int)) sCCTPfn)(addr, port)'.
			okToConnect
				ifFalse: [^ interpreterProxy primitiveFail]].
	s := self socketValueOf: socket.
	interpreterProxy failed
		ifFalse: [self
				sqSocket: s
				ConnectTo: addr
				Port: port]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:19'!
primitiveSocket: socket getOptions: optionName

	| s optionNameStart optionNameSize returnedValue errorCode results |
	<var: #s type: 'SocketPtr'>
	<var: #optionNameStart type: 'char *'>
	self primitive: 'primitiveSocketGetOptions'
		parameters: #(Oop Oop).

	s := self socketValueOf: socket.
	interpreterProxy success: (interpreterProxy isBytes: optionName).
	optionNameStart := self cCoerce: (interpreterProxy firstIndexableField: optionName) to: 'char *'.
	optionNameSize := interpreterProxy slotSizeOf: optionName.

	interpreterProxy failed ifTrue: [^nil].
	returnedValue := 0.

	errorCode := self sqSocketGetOptions: s 
			optionNameStart: optionNameStart 
			optionNameSize: optionNameSize
			returnedValue: (self cCode: '&returnedValue').

	interpreterProxy pushRemappableOop: returnedValue asSmallIntegerObj.
	interpreterProxy pushRemappableOop: errorCode asSmallIntegerObj.
	interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2).
	results := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
	^ results! !
!SocketPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas dtl 2010-09-28) 8/12/2009 21:25'!
primitiveSocket: socket listenOnPort: port 
	"one part of the wierdass dual prim primitiveSocketListenOnPort which 
	was warped by some demented evil person determined to twist the very 
	nature of reality"
	| s  okToListen |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketListenOnPort' parameters: #(#Oop #SmallInteger ).
	s := self socketValueOf: socket.
	"If the security plugin can be loaded, use it to check for permission.
	If  not, assume it's ok"
	sCCLOPfn ~= 0
		ifTrue: [okToListen := self cCode: ' ((int (*) (SocketPtr, int)) sCCLOPfn)(s, port)'.
			okToListen
				ifFalse: [^ interpreterProxy primitiveFail]].
	interpreterProxy failed ifFalse:[self sqSocket: s ListenOnPort: port]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:20'!
primitiveSocket: socket listenOnPort: port backlogSize: backlog 
	"second part of the wierdass dual prim primitiveSocketListenOnPort 
	which was warped by some demented evil person determined to twist the 
	very nature of reality"
	| s okToListen |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketListenOnPortBacklog' parameters: #(#Oop #SmallInteger #SmallInteger ).
	s := self socketValueOf: socket.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCCLOPfn ~= 0
		ifTrue: [okToListen := self cCode: ' ((int (*) (SocketPtr, int)) sCCLOPfn)(s, port)'.
			okToListen
				ifFalse: [^ interpreterProxy primitiveFail]].
	self
		sqSocket: s
		ListenOnPort: port
		BacklogSize: backlog! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:20'!
primitiveSocket: socket listenOnPort: port backlogSize: backlog interface: ifAddr
	"Bind a socket to the given port and interface address with no more than backlog pending connections.  The socket can be UDP, in which case the backlog should be specified as zero."

	| s okToListen addr |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketListenOnPortBacklogInterface' parameters: #(#Oop #SmallInteger #SmallInteger #ByteArray).
	s := self socketValueOf: socket.
	"If the security plugin can be loaded, use it to check for permission.
	If  not, assume it's ok"
	sCCLOPfn ~= 0
		ifTrue: [okToListen := self cCode: ' ((int (*) (SocketPtr, int)) sCCLOPfn)(s, port)'.
			okToListen
				ifFalse: [^ interpreterProxy primitiveFail]].
	addr := self netAddressToInt: (self cCoerce: ifAddr to: 'unsigned char *').
	self
		sqSocket: s
		ListenOnPort: port
		BacklogSize: backlog
		Interface: addr! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/9/2007 09:46'!
primitiveSocket: socket listenWithBacklog: backlogSize

	| s  |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketListenWithBacklog' parameters: #(#Oop #SmallInteger).
	s := self socketValueOf: socket.
	interpreterProxy failed ifFalse: [self sqSocket: s ListenBacklog: backlogSize]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/9/2007 10:26'!
primitiveSocket: socket localAddressResult: socketAddress

	| addrSize addrBase s  |
	<var: #addrBase type: 'char *'>
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketLocalAddressResult' parameters: #(#Oop #Oop).
	s := self socketValueOf: socket.
	addrSize := interpreterProxy byteSizeOf: socketAddress.
	addrBase := self cCoerce: (interpreterProxy firstIndexableField: socketAddress) to: 'char *'.
	interpreterProxy failed ifFalse: [self sqSocket: s LocalAddressResult: addrBase Size: addrSize]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:20'!
primitiveSocket: socket receiveDataBuf: array start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesReceived |
	<var: #s type: 'SocketPtr'>
	<var: #arrayBase type: 'char *'>
	<var: #bufStart type: 'char *'>
	self primitive: 'primitiveSocketReceiveDataBufCount'
		parameters: #(Oop Oop SmallInteger SmallInteger ).
	s := self socketValueOf: socket.

	"buffer can be any indexable words or bytes object"
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize := 4]
		ifFalse: [byteSize := 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase := self cCoerce: (interpreterProxy firstIndexableField: array) to: 'char *'.
			bufStart := arrayBase + (startIndex - 1 * byteSize).
			bytesReceived := self
						sqSocket: s
						ReceiveDataBuf: bufStart
						Count: count * byteSize].
	^ (bytesReceived // byteSize) asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:20'!
primitiveSocket: socket receiveUDPDataBuf: array start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesReceived results address port moreFlag |
	<var: #s type: 'SocketPtr'>
	<var: #arrayBase type: 'char *'>
	<var: #bufStart type: 'char *'>
	self primitive: 'primitiveSocketReceiveUDPDataBufCount'
		parameters: #(Oop Oop SmallInteger SmallInteger ).
	s := self socketValueOf: socket.

	"buffer can be any indexable words or bytes object"
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize := 4]
		ifFalse: [byteSize := 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase := self cCoerce: (interpreterProxy firstIndexableField: array) to: 'char *'.
			bufStart := arrayBase + (startIndex - 1 * byteSize).
			"allocate storage for results, remapping newly allocated
			 oops in case GC happens during allocation"
			address		  := 0.
			port			  := 0.
			moreFlag	  := 0.
			bytesReceived := self
						sqSocket: s
						ReceiveUDPDataBuf: bufStart
						Count: count * byteSize
						address: (self cCode: '&address')
						port: (self cCode: '&port')
						moreFlag: (self cCode: '&moreFlag').
				
			interpreterProxy pushRemappableOop: port asSmallIntegerObj.
			interpreterProxy pushRemappableOop: (self intToNetAddress: address).
			interpreterProxy pushRemappableOop: (bytesReceived // byteSize) asSmallIntegerObj.
			interpreterProxy pushRemappableOop:
				(interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 4).
			results         := interpreterProxy popRemappableOop.
			interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
			interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
			interpreterProxy storePointer: 2 ofObject: results withValue: interpreterProxy popRemappableOop.
			moreFlag
				ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ]
				ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ].
			].
	^ results! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/9/2007 10:26'!
primitiveSocket: socket remoteAddressResult: socketAddress

	| addrSize addrBase s  |
	<var: #addrBase type: 'char *'>
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketRemoteAddressResult' parameters: #(#Oop #Oop).
	s := self socketValueOf: socket.
	addrSize := interpreterProxy byteSizeOf: socketAddress.
	addrBase := self cCoerce: (interpreterProxy firstIndexableField: socketAddress) to: 'char *'.
	interpreterProxy failed ifFalse: [self sqSocket: s RemoteAddressResult: addrBase Size: addrSize]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:21'!
primitiveSocket: socket sendData: array start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesSent |
	<var: #s type: 'SocketPtr'>
	<var: #arrayBase type: 'char *'>
	<var: #bufStart type: 'char *'>
	self primitive: 'primitiveSocketSendDataBufCount'
		parameters: #(Oop Oop SmallInteger SmallInteger ).
	s := self socketValueOf: socket.

	"buffer can be any indexable words or bytes object except CompiledMethod "
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize := 4]
		ifFalse: [byteSize := 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase := self cCoerce: (interpreterProxy firstIndexableField: array) to: 'char *'.
			bufStart := arrayBase + (startIndex - 1 * byteSize).
			bytesSent := self
						sqSocket: s
						SendDataBuf: bufStart
						Count: count * byteSize].
	^ (bytesSent // byteSize) asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:21'!
primitiveSocket: socket sendUDPData: array toHost: hostAddress  port: portNumber start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesSent address |
	<var: #s type: 'SocketPtr'>
	<var: #arrayBase type: 'char *'>
	<var: #bufStart type: 'char *'>
	self primitive: 'primitiveSocketSendUDPDataBufCount'
		parameters: #(Oop Oop ByteArray SmallInteger SmallInteger SmallInteger ).
	s := self socketValueOf: socket.

	"buffer can be any indexable words or bytes object except CompiledMethod "
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize := 4]
		ifFalse: [byteSize := 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase := self cCoerce: (interpreterProxy firstIndexableField: array) to: 'char *'.
			bufStart := arrayBase + (startIndex - 1 * byteSize).
			address := self netAddressToInt: (self cCoerce: hostAddress to: 'unsigned char *').
			bytesSent := self
						sqSocket: s
						toHost: address
						port: portNumber
						SendDataBuf: bufStart
						Count: count * byteSize].
	^ (bytesSent // byteSize) asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:21'!
primitiveSocket: socket setOptions: optionName value: optionValue

	| s optionNameStart optionNameSize optionValueStart optionValueSize returnedValue errorCode results |
	<var: #s type: 'SocketPtr'>
	<var: #optionNameStart type: 'char *'>
	<var: #optionValueStart type: 'char *'>
	self primitive: 'primitiveSocketSetOptions'
		parameters: #(Oop Oop Oop).

	s := self socketValueOf: socket.
	interpreterProxy success: (interpreterProxy isBytes: optionName).
	optionNameStart := self cCoerce: (interpreterProxy firstIndexableField: optionName) to: 'char *'.
	optionNameSize := interpreterProxy slotSizeOf: optionName.
	interpreterProxy success: (interpreterProxy isBytes: optionValue).
	optionValueStart:= self cCoerce: (interpreterProxy firstIndexableField: optionValue) to: 'char *'.
	optionValueSize := interpreterProxy slotSizeOf: optionValue.

	interpreterProxy failed ifTrue: [^nil].
	returnedValue := 0.

	errorCode := self sqSocketSetOptions: s 
			optionNameStart: optionNameStart 
			optionNameSize: optionNameSize
			optionValueStart: optionValueStart
			optionValueSize: optionValueSize
			returnedValue: (self cCode: '&returnedValue').

	interpreterProxy pushRemappableOop: returnedValue asSmallIntegerObj.
	interpreterProxy pushRemappableOop: errorCode asSmallIntegerObj.
	interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2).
	results := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
	^ results! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:17'!
primitiveSocketAbortConnection: socket

	| s |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketAbortConnection'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		self sqSocketAbortConnection: s]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:17'!
primitiveSocketAcceptFrom: sockHandle rcvBufferSize: recvBufSize sndBufSize: sendBufSize semaIndex: semaIndex 
	| socketOop s serverSocket |
	<var: #s type: 'SocketPtr '>
	<var: #serverSocket type: 'SocketPtr '>
	self primitive: 'primitiveSocketAccept'
		parameters: #(Oop SmallInteger SmallInteger SmallInteger ).
	serverSocket := self socketValueOf: sockHandle.

	interpreterProxy failed
		ifFalse: [socketOop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self socketRecordSize.
			s := self socketValueOf: socketOop.
			self
				sqSocket: s
				AcceptFrom: serverSocket
				RecvBytes: recvBufSize
				SendBytes: sendBufSize
				SemaID: semaIndex].
	^ socketOop! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:17'!
primitiveSocketAcceptFrom: sockHandle rcvBufferSize: recvBufSize sndBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	| socketOop s serverSocket |
	<var: #s type: 'SocketPtr '>
	<var: #serverSocket type: 'SocketPtr '>
	self primitive: 'primitiveSocketAccept3Semaphores'
		parameters: #(Oop SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger).
	serverSocket := self socketValueOf: sockHandle.

	interpreterProxy failed
		ifFalse: [socketOop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self socketRecordSize.
			s := self socketValueOf: socketOop.
			self
				sqSocket: s
				AcceptFrom: serverSocket
				RecvBytes: recvBufSize
				SendBytes: sendBufSize
				SemaID: semaIndex
				ReadSemaID: aReadSema
				WriteSemaID: aWriteSema].
	^ socketOop! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'dtl (auto pragmas dtl 2010-09-28) 9/28/2010 20:15'!
primitiveSocketAddressGetPort

	| addr addrSize addrBase port |
	<var: #addrBase type: 'char *'>
	addr := self primitive: 'primitiveSocketAddressGetPort' parameters: #() receiver: #Oop.
	addrSize := interpreterProxy byteSizeOf: addr.
	addrBase := self cCoerce: (interpreterProxy firstIndexableField: addr) to: 'char *'.
	interpreterProxy failed
		ifFalse:
			[port := self sqSocketAddress: addrBase SizeGetPort: addrSize.
			 interpreterProxy failed ifFalse: [^port asSmallIntegerObj]]! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'dtl (auto pragmas dtl 2010-09-28) 9/28/2010 20:16'!
primitiveSocketAddressSetPort: portNumber

	| addr addrSize addrBase |
	<var: #addrBase type: 'char *'>
	addr := self primitive: 'primitiveSocketAddressSetPort' parameters: #(SmallInteger) receiver: #Oop.
	addrSize := interpreterProxy byteSizeOf: addr.
	addrBase := self cCoerce: (interpreterProxy firstIndexableField: addr) to: 'char *'.
	interpreterProxy failed ifFalse: [self sqSocketAddress: addrBase Size: addrSize SetPort: portNumber]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:17'!
primitiveSocketCloseConnection: socket

	| s |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketCloseConnection'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		self sqSocketCloseConnection: s]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:17'!
primitiveSocketConnectionStatus: socket

	| s status |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketConnectionStatus'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		status := self sqSocketConnectionStatus: s].
	^ status asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:57'!
primitiveSocketCreateNetwork: netType type: socketType receiveBufferSize: recvBufSize sendBufSize: sendBufSize semaIndex: semaIndex 
	| socketOop s okToCreate |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketCreate' parameters: #(#SmallInteger #SmallInteger #SmallInteger #SmallInteger #SmallInteger ).
	"If the security plugin can be loaded, use it to check for permission.
	If  not, assume it's ok"
	sCCSOTfn ~= 0
		ifTrue: [okToCreate := self cCode: ' ((int (*) (int, int)) sCCSOTfn)(netType, socketType)'.
			okToCreate
				ifFalse: [^ interpreterProxy primitiveFail]].
	socketOop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self socketRecordSize.
	s := self socketValueOf: socketOop.
	self
		sqSocket: s
		CreateNetType: netType
		SocketType: socketType
		RecvBytes: recvBufSize
		SendBytes: sendBufSize
		SemaID: semaIndex.
	^ socketOop! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/30/2005 15:57'!
primitiveSocketCreateNetwork: netType type: socketType receiveBufferSize: recvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema 
	| socketOop s okToCreate |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketCreate3Semaphores' parameters: #(#SmallInteger #SmallInteger #SmallInteger #SmallInteger #SmallInteger #SmallInteger #SmallInteger ).
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCCSOTfn ~= 0
		ifTrue: [okToCreate := self cCode: ' ((int (*) (int, int)) sCCSOTfn)(netType, socketType)'.
			okToCreate
				ifFalse: [^ interpreterProxy primitiveFail]].
	socketOop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self socketRecordSize.
	s := self socketValueOf: socketOop.
	self
		sqSocket: s
		CreateNetType: netType
		SocketType: socketType
		RecvBytes: recvBufSize
		SendBytes: sendBufSize
		SemaID: semaIndex
		ReadSemaID: aReadSema
		WriteSemaID: aWriteSema.
	^ socketOop! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketDestroy: socket

	| s |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketDestroy'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		self sqSocketDestroy: s]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketError: socket

	| s err |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketError'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		err := self sqSocketError: s].
	^err asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 5/24/2000 13:38'!
primitiveSocketListenWithOrWithoutBacklog
	"Backward compatibility"
	<export: true>
	interpreterProxy methodArgumentCount = 2
		ifTrue:[^self primitiveSocketListenOnPort]
		ifFalse:[^self primitiveSocketListenOnPortBacklog]
! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketLocalAddress: socket

	| s addr |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketLocalAddress'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	addr := self sqSocketLocalAddress: s.
	^self intToNetAddress: addr! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/9/2007 10:30'!
primitiveSocketLocalAddressSize: socket

	| s size |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketLocalAddressSize' parameters: #(#Oop).
	s := self socketValueOf: socket.
	interpreterProxy failed ifTrue: [^nil].
	size := self sqSocketLocalAddressSize: s.
	interpreterProxy failed ifTrue: [^nil].
	^size asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketLocalPort: socket

	| s port |
	<var: #s type: 'SocketPtr '>
	self primitive: 'primitiveSocketLocalPort'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	port := self sqSocketLocalPort: s.
	^port asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketReceiveDataAvailable: socket

	| s dataIsAvailable |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketReceiveDataAvailable'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	dataIsAvailable := self sqSocketReceiveDataAvailable: s.
	^dataIsAvailable asBooleanObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketRemoteAddress: socket

	| s addr |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketRemoteAddress'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	addr := self sqSocketRemoteAddress: s.
	^self intToNetAddress: addr! !
!SocketPlugin methodsFor: 'ipv6 primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 6/9/2007 10:30'!
primitiveSocketRemoteAddressSize: socket

	| s size |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketRemoteAddressSize' parameters: #(#Oop).
	s := self socketValueOf: socket.
	interpreterProxy failed ifTrue: [^nil].
	size := self sqSocketRemoteAddressSize: s.
	interpreterProxy failed ifTrue: [^nil].
	^size asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketRemotePort: socket

	| s port |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketRemotePort'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	port := self sqSocketRemotePort: s.
	^port asSmallIntegerObj! !
!SocketPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:18'!
primitiveSocketSendDone: socket

	| s done |
	<var: #s type: 'SocketPtr'>
	self primitive: 'primitiveSocketSendDone'
		parameters: #(Oop).
	s := self socketValueOf: socket.
	done := self sqSocketSendDone: s.
	^done asBooleanObj! !
!SocketPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:55'!
shutdownModule
	<export: true>
	^self cCode: 'socketShutdown()' inSmalltalk:[true]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 17:26'!
socketRecordSize
	"Return the size of a Smalltalk socket record in bytes."

	^ self cCode: 'sizeof(SQSocket)' inSmalltalk: [12]! !
!SocketPlugin methodsFor: 'primitives' stamp: 'ikp (auto pragmas dtl 2010-09-28) 3/31/2005 14:08'!
socketValueOf: socketOop 
	"Return a pointer to the first byte of of the socket record within the  
	given Smalltalk object, or nil if socketOop is not a socket record."
	| socketIndex |
	<returnTypeC: 'SQSocket *'>
	<var: #socketIndex type: 'void *'>
	interpreterProxy success: ((interpreterProxy isBytes: socketOop)
			and: [(interpreterProxy byteSizeOf: socketOop)
					= self socketRecordSize]).
	interpreterProxy failed
		ifTrue: [^ nil]
		ifFalse: [socketIndex := self cCoerce: (interpreterProxy firstIndexableField: socketOop) to: 'void *'.
			^ self cCode: '(SQSocket *) socketIndex']! !

SmartSyntaxInterpreterPlugin subclass: #SoundPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!SoundPlugin commentStamp: 'tpr 5/2/2003 15:50' prior: 0!
This plugin implements the main sound related primiives.  Since it requires platform support it will only be built when supported on your platform


FORMAT OF SOUND DATA

Squeak uses 16-bit signed samples encoded in the host's endian order.  A sound buffer is a sequence of "frames", or "slices", where each frame usually includes one sample per channel.  The exception is that for playback, each frame always includes 2 samples; for monaural playback, every other sample is ignored.
!
!SoundPlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:12'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!SoundPlugin class methodsFor: 'translation' stamp: 'tpr 11/29/2000 22:38'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!SoundPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:54'!
initialiseModule
	<export: true>
	^self cCode: 'soundInit()' inSmalltalk:[true]! !
!SoundPlugin methodsFor: 'primitives' stamp: 'ar 4/4/2006 21:11'!
primitiveSoundAvailableSpace
	"Returns the number of bytes of available sound output buffer space.  This should be (frames*4) if the device is in stereo mode, or (frames*2) otherwise"

	| frames |
	self primitive: 'primitiveSoundAvailableSpace'.
	frames := self cCode: 'snd_AvailableSpace()'.  "-1 if sound output not started"
	interpreterProxy success: frames >= 0.
	^frames asPositiveIntegerObj! !
!SoundPlugin methodsFor: 'primitives' stamp: 'ar (auto pragmas 12/08) 4/4/2006 21:10'!
primitiveSoundGetRecordingSampleRate
	"Return a float representing the actual sampling rate during recording. Fail if not currently recording."

	| rate |
	<var: #rate type: 'double '>
	self primitive: 'primitiveSoundGetRecordingSampleRate'.
	rate := self cCode: 'snd_GetRecordingSampleRate()'.  "fail if not recording"
	^rate asFloatObj! !
!SoundPlugin methodsFor: 'primitives' stamp: 'ar 4/4/2006 21:11'!
primitiveSoundGetVolume
	"Set the sound input recording level."
	| left right results | 
	self primitive: 'primitiveSoundGetVolume'
		parameters: #( ).
	self var: #left type: 'double '.
	self var: #right type: 'double '.
	left := 0.
	right := 0.
	self cCode: 'snd_Volume((double *) &left,(double *) &right)'.
	interpreterProxy pushRemappableOop: (right asOop: Float).
	interpreterProxy pushRemappableOop: (left asOop: Float).
	interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2).
	results := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
	^ results! !
!SoundPlugin methodsFor: 'primitives' stamp: 'dtl 4/26/2009 12:20'!
primitiveSoundInsertSamples: frameCount from: buf leadTime: leadTime 
	"Insert a buffer's worth of sound samples into the currently playing  
	buffer. Used to make a sound start playing as quickly as possible. The  
	new sound is mixed with the previously buffered sampled."
	"Details: Unlike primitiveSoundPlaySamples, this primitive always starts  
	with the first sample the given sample buffer. Its third argument  
	specifies the number of samples past the estimated sound output buffer  
	position the inserted sound should start. If successful, it returns the  
	number of samples inserted."
	| framesPlayed |
	self primitive: 'primitiveSoundInsertSamples'
		parameters: #(SmallInteger WordArray SmallInteger ).
	interpreterProxy success: frameCount <= (interpreterProxy slotSizeOf: buf cPtrAsOop).

	interpreterProxy failed
		ifFalse: [framesPlayed := self cCode: 'snd_InsertSamplesFromLeadTime(frameCount, (void *)buf, leadTime)'.
			interpreterProxy success: framesPlayed >= 0].
	^ framesPlayed asPositiveIntegerObj! !
!SoundPlugin methodsFor: 'primitives' stamp: 'dtl 4/26/2009 11:19'!
primitiveSoundPlaySamples: frameCount from: buf startingAt: startIndex 
	"Output a buffer's worth of sound samples."
	| framesPlayed |
	self primitive: 'primitiveSoundPlaySamples'
		parameters: #(SmallInteger WordArray SmallInteger ).
	interpreterProxy success: (startIndex >= 1 and: [startIndex + frameCount - 1 <= (interpreterProxy slotSizeOf: buf cPtrAsOop)]).

	interpreterProxy failed
		ifFalse: [framesPlayed := self cCode: 'snd_PlaySamplesFromAtLength(frameCount, (void *)buf, startIndex - 1)'.
			interpreterProxy success: framesPlayed >= 0].
	^ framesPlayed asPositiveIntegerObj! !
!SoundPlugin methodsFor: 'primitives' stamp: 'ar 4/4/2006 21:11'!
primitiveSoundPlaySilence
	"Output a buffer's worth of silence. Returns the number of sample frames played."

	| framesPlayed |
	self primitive: 'primitiveSoundPlaySilence'.
	framesPlayed := self cCode: 'snd_PlaySilence()'.  "-1 if sound output not started"
	interpreterProxy success: framesPlayed >= 0.
	^framesPlayed asPositiveIntegerObj! !
!SoundPlugin methodsFor: 'primitives' stamp: 'ar 3/31/2010 09:41'!
primitiveSoundRecordSamplesInto: buf startingAt: startWordIndex 
	"Record a buffer's worth of 16-bit sound samples."
	| bufSizeInBytes samplesRecorded bufPtr byteOffset bufLen |
	self var: #bufPtr type: 'char*'.
	self primitive: 'primitiveSoundRecordSamples'
		parameters: #(WordArray SmallInteger ).

	interpreterProxy failed ifFalse:
		[bufSizeInBytes := (interpreterProxy slotSizeOf: buf cPtrAsOop) * 4.
		 interpreterProxy success: (startWordIndex >= 1 and: [startWordIndex - 1 * 2 < bufSizeInBytes])].

	interpreterProxy failed ifFalse:[
		byteOffset := (startWordIndex - 1) * 2.
		bufPtr := (self cCoerce: buf to: 'char*') + byteOffset.
		bufLen := bufSizeInBytes - byteOffset.
		samplesRecorded := self cCode: 'snd_RecordSamplesIntoAtLength(bufPtr, 0, bufLen)' inSmalltalk:[bufPtr. bufLen. 0].
	].

	^ samplesRecorded asPositiveIntegerObj! !
!SoundPlugin methodsFor: 'primitives' stamp: 'JMM 11/6/2000 11:06'!
primitiveSoundSetLeftVolume: aLeftVolume rightVolume: aRightVolume
	"Set the sound input recording level."

	self primitive: 'primitiveSoundSetLeftVolume'
		parameters: #(Float Float).
	interpreterProxy failed ifFalse: [self cCode: 'snd_SetVolume(aLeftVolume,aRightVolume)'].
! !
!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:39'!
primitiveSoundSetRecordLevel: level 
	"Set the sound input recording level."
	self primitive: 'primitiveSoundSetRecordLevel'
		parameters: #(SmallInteger ).
	interpreterProxy failed ifFalse: [self cCode: 'snd_SetRecordLevel(level)']! !
!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 14:58'!
primitiveSoundStartBufferSize: bufFrames rate: samplesPerSec stereo: stereoFlag
	"Start the double-buffered sound output with the given buffer size, sample rate, and stereo flag."

	self primitive: 'primitiveSoundStart'
		parameters: #(SmallInteger SmallInteger Boolean).
	interpreterProxy success: (self cCode: 'snd_Start(bufFrames, samplesPerSec, stereoFlag, 0)')! !
!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:57'!
primitiveSoundStartBufferSize: bufFrames rate: samplesPerSec stereo: stereoFlag semaIndex: semaIndex
	"Start the double-buffered sound output with the given buffer size, sample rate, stereo flag, and semaphore index."

	self primitive: 'primitiveSoundStartWithSemaphore'
		parameters: #(SmallInteger SmallInteger Boolean SmallInteger).
	interpreterProxy success: (self cCode: 'snd_Start(bufFrames, samplesPerSec, stereoFlag, semaIndex)')! !
!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:55'!
primitiveSoundStartRecordingDesiredSampleRate: desiredSamplesPerSec stereo: stereoFlag semaIndex: semaIndex
	"Start recording sound with the given parameters."

	self primitive: 'primitiveSoundStartRecording'
		parameters: #(SmallInteger Boolean SmallInteger).
	self cCode: 'snd_StartRecording(desiredSamplesPerSec, stereoFlag, semaIndex)'! !
!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:58'!
primitiveSoundStop
	"Stop double-buffered sound output."

	self primitive: 'primitiveSoundStop'.

	self cCode: 'snd_Stop()'.  "leave rcvr on stack"! !
!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:58'!
primitiveSoundStopRecording
	"Stop recording sound."

	self primitive: 'primitiveSoundStopRecording'.
	self cCode: 'snd_StopRecording()'.  "leave rcvr on stack"! !
!SoundPlugin methodsFor: 'initialize-release' stamp: 'ar (auto pragmas 12/08) 5/12/2000 16:55'!
shutdownModule
	<export: true>
	^self cCode: 'soundShutdown()' inSmalltalk:[true]! !

SmartSyntaxInterpreterPlugin subclass: #TestOSAPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!TestOSAPlugin commentStamp: 'tpr 5/2/2003 15:51' prior: 0!
I am the Plugin for the Squeak/Applescript Interface. Since it requires platform support it will only be built when supported on your platform!
!TestOSAPlugin class methodsFor: 'as yet unclassified' stamp: 'acg 9/21/1999 01:29'!
declareCVarsIn: cg

	cg addHeaderFile: '<AppleEvents.h>'.
	cg addHeaderFile: '<AppleScript.h>'.
	cg addHeaderFile: '<OSA.h>'.
	cg addHeaderFile: '<OSAGeneric.h>'.
	cg addHeaderFile: '<Script.h>'.! !
!TestOSAPlugin class methodsFor: 'translation' stamp: 'JMM 5/30/2001 19:43'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/23/1999 22:49'!
primAECoerceDesc: typeCode to: result

	|rcvr |
	rcvr := self 	primitive: 	'primAECoerceDesc'
				parameters:	#(DescType AEDesc)
				receiver:	#AEDesc.
	^(self 
		cCode: 'AECoerceDesc(rcvr,*typeCode,result)'
		inSmalltalk: [[rcvr]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/20/1999 12:37'!
primAECreateDesc: typeCode from: aString

	|rcvr size |
	rcvr := self 	primitive: 	'primAECreateDesc'
				parameters:	#(DescType String)
				receiver:	#AEDesc.
	size := aString size.
	^(self 
		cCode: 'AECreateDesc(*typeCode, aString, size, rcvr)'
		inSmalltalk: [[rcvr. size]. -1]) asOop: Unsigned
! !
!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/20/1999 14:16'!
primAEDescToString: aString

	| rcvr size |
	rcvr := self	primitive: 	'primAEDescToString'
				parameters: #(String)
				receiver: #AEDesc.
	size := aString size.
	self cCode: 'BlockMove(*(rcvr->dataHandle), aString, size)'
		 inSmalltalk: [rcvr. size].
	^aString asOop: String

! !
!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/20/1999 12:38'!
primAEDisposeDesc
	
	|rcvr|
	rcvr :=	self	primitive: 	'primAEDisposeDesc'
				parameters:	#()
				receiver: 	#AEDesc.
	^(self 
		cCode: 'AEDisposeDesc(rcvr)'
		inSmalltalk: [[rcvr]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:22'!
primAEGetKeyPtr: key type: type actual: ignoreDesc to: bytes

	| rcvr size ignoreSize |
	<var: #ignoreSize type: 'Size '>
	rcvr := self	primitive: 	'primAEGetKeyPtr'
				parameters: #(DescType DescType DescType ByteArray)
				receiver: #AEDesc.
	size := ignoreSize := bytes size.
	^(self cCode: 'AEGetKeyPtr(rcvr, *key, *type, ignoreDesc, bytes, size, &ignoreSize)'
		 inSmalltalk: [[rcvr. size. ignoreSize]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'Gen''l Mac OS prims' stamp: 'acg 9/20/1999 12:56'!
primGetHandleSize: anIndex

	|rcvr|
	rcvr := self	primitive: 'primGetHandleSize'
				parameters: #(SmallInteger)
				receiver:	#WordArray.
	^(self
		cCode: 'GetHandleSize((Handle) *(rcvr+anIndex))'
		inSmalltalk: [[rcvr]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 16:08'!
primOSACompile: source mode: mode to: object

	|component|
	component := self primitive: 	'primOSACompile'
					parameters: #(AEDesc SmallInteger OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSACompile(*component,source,mode,object)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 16:08'!
primOSADisplay: source as: type mode: mode to: result

	|component|
	component := self primitive: 	'primOSADisplay'
					parameters: #(OSAID DescType SmallInteger AEDesc)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSADisplay(*component,*source,*type,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 15:39'!
primOSADispose: anOSAID

	|component|
	component := self primitive: 	'primOSADispose'
					parameters: #(OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSADispose(*component,*anOSAID)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'JMM 10/31/2005 11:59'!
primOSADoScript: source in: context mode: mode resultType: type to: result

	|component resultsOfCall giLocker |
	component := self primitive: 	'primOSADoScript'
					parameters: #(AEDesc OSAID SmallInteger DescType AEDesc)
					receiver:	#ComponentInstance.

	self cCode: '
        giLocker = interpreterProxy->ioLoadFunctionFrom("getUIToLock", "");
        if (giLocker !!= 0) {
            long *foo;
            foo = malloc(sizeof(long)*9);
            foo[0] = 6;
            foo[1] = OSADoScript;
            foo[2] = *component;
            foo[3] = source;
            foo[4] = *context;
            foo[5] = *type;
            foo[6] = mode;
            foo[7] = result;
            foo[8] = 0;
            ((int (*) (void *)) giLocker)(foo);
            resultsOfCall = interpreterProxy->positive32BitIntegerFor(foo[8]);
            free(foo);}'
			inSmalltalk: [[component. giLocker].  resultsOfCall := -1].
	^resultsOfCall asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'JMM 10/31/2005 11:59'!
primOSAExecute: script in: context mode: mode to: result

	|component giLocker resultsOfCall |
	component := self primitive: 	'primOSAExecute'
					parameters: #(OSAID OSAID SmallInteger OSAID)
					receiver:	#ComponentInstance.

	self cCode: '
         giLocker = interpreterProxy->ioLoadFunctionFrom("getUIToLock", "");
         if (giLocker !!= 0) {
            long *foo;
            foo = malloc(sizeof(long)*8);
            foo[0] = 5;
            foo[1] = OSAExecute;
            foo[2] = *component;
            foo[3] = *script;
            foo[4] = *context;
            foo[5] = mode;
            foo[6] = result;
            foo[7] = 0;
            ((int (*) (void *)) giLocker)(foo);
            resultsOfCall = interpreterProxy->positive32BitIntegerFor(foo[7]);
            free(foo); }
'
			inSmalltalk: [[component. giLocker]. resultsOfCall := -1].
	^resultsOfCall asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/25/1999 15:01'!
primOSAGetScriptInfo: aScriptID type: aDescType to: resultData

	|component|
	component := self	primitive: 	'primOSAGetScriptInfo'
						parameters: #(OSAID DescType IntegerArray)
						receiver:	#ComponentInstance.
	
	^(self cCode: 'OSAGetScriptInfo(*component,*aScriptID,*aDescType, (long *)resultData)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/25/1999 17:25'!
primOSAGetSource: aScriptID type: aDescType to: resultData

	|component|
	component := self	primitive: 	'primOSAGetSource'
						parameters: #(OSAID DescType AEDesc)
						receiver:	#ComponentInstance.
	
	^(self cCode: 'OSAGetSource(*component,*aScriptID,*aDescType, resultData)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/22/1999 03:08'!
primOSALoad: source mode: mode to: result

	|component|
	component := self primitive: 	'primOSALoad'
					parameters: #(AEDesc SmallInteger OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSALoad(*component,source,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/25/1999 22:55'!
primOSAMakeContext: name parent: parent to: result

	|component|
	component := self primitive: 	#primOSAMakeContext
					parameters: #(AEDesc OSAID OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSAMakeContext(*component,name,*parent,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/23/1999 20:39'!
primOSAScriptError: selector type: type to: result

	|component|
	component := self primitive: 	'primOSAScriptError'
					parameters: #(DescType DescType AEDesc)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSAScriptError(*component,*selector,*type,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 21:53'!
primOSAScriptingComponentNameTo: anAEDesc

	|component|
	component := self	primitive: 	'primOSAScriptingComponentName'
						parameters: #(AEDesc)
						receiver:	#ComponentInstance.
	
	^(self cCode: 'OSAScriptingComponentName(*component,anAEDesc)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/22/1999 07:51'!
primOSAStore: source resultType: type mode: mode to: result

	|component|
	component := self primitive: 	#primOSAStore
					parameters: #(OSAID DescType SmallInteger AEDesc)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSAStore(*component,*source,*type,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !
!TestOSAPlugin methodsFor: 'Component Mgr prims' stamp: 'acg 9/20/1999 23:42'!
primOpenDefaultConfiguration: type subtype: subtype

	| component |
	component := self	primitive: 	'primOpenDefaultConfiguration'
						parameters: #(DescType DescType)
						receiver:	#ComponentInstance.
	self	cCode: '*component = OpenDefaultComponent(*type,*subtype)'
		inSmalltalk: [component at: 0 put: 0].
	^component asOop: ComponentInstance! !

SmartSyntaxInterpreterPlugin subclass: #UUIDPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!UUIDPlugin commentStamp: 'tpr 5/2/2003 15:52' prior: 0!
A class to generate UUID
by John M McIntosh johnmci@smalltalkconsulting.com, since it requires platform support it will only be built when supported on your platform.
See http://www.webdav.org/specs/draft-leach-uuids-guids-01.txt

If a plugin does not exist then we generate a UUID version 4 type GUUID in Smalltalk!
!UUIDPlugin class methodsFor: 'translation' stamp: 'JMM 10/9/2001 12:46'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!UUIDPlugin class methodsFor: 'translation' stamp: 'JMM 10/9/2001 13:37'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!UUIDPlugin methodsFor: 'initialize' stamp: 'JMM (auto pragmas 12/08) 10/9/2001 12:47'!
initialiseModule
	<export: true>
	^self cCode: 'sqUUIDInit()' inSmalltalk:[true]! !
!UUIDPlugin methodsFor: 'system primitives' stamp: 'eem 3/4/2009 17:48'!
primitiveMakeUUID
	| oop location |
	<export: true>
	<var: #location type: 'char*'>
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	oop := interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isBytes: oop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy byteSizeOf: oop) = 16
		ifFalse:[^interpreterProxy primitiveFail].
	location := interpreterProxy firstIndexableField: oop.

	^self cCode: 'MakeUUID(location)' 
		inSmalltalk: [location. interpreterProxy primitiveFail].
! !
!UUIDPlugin methodsFor: 'initialize' stamp: 'ar (auto pragmas 12/08) 2/3/2002 20:03'!
shutdownModule
	<export: true>
	^self cCode: 'sqUUIDShutdown()' inSmalltalk:[true]! !

InterpreterPlugin subclass: #SoundCodecPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!SoundCodecPlugin commentStamp: 'tpr 5/5/2003 12:20' prior: 0!
This plugin provide GSM typecodec capabilities.!
!SoundCodecPlugin class methodsFor: 'accessing' stamp: 'tpr 5/23/2001 17:11'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!SoundCodecPlugin class methodsFor: 'accessing' stamp: 'tpr 4/18/2002 15:56'!
moduleName

	^ 'SoundCodecPrims' "Needs to be the name used for module specification..."
! !
!SoundCodecPlugin class methodsFor: 'accessing' stamp: 'tpr 7/2/2001 16:34'!
requiresCrossPlatformFiles
	"If there cross platform files to be associated with the plugin, here is where you want to flag"
	^true! !
!SoundCodecPlugin methodsFor: 'gsm 6.10 codec' stamp: 'jm (auto pragmas 12/08) 2/4/1999 08:38'!
primitiveGSMDecode

	| dstIndex dst srcIndex src frameCount state srcSize dstSize result srcDelta dstDelta |
	<export: true>
	dstIndex := interpreterProxy stackIntegerValue: 0.
	dst := interpreterProxy stackObjectValue: 1.
	srcIndex := interpreterProxy stackIntegerValue: 2.
	src := interpreterProxy stackObjectValue: 3.
	frameCount := interpreterProxy stackIntegerValue: 4.
	state := interpreterProxy stackObjectValue: 5.
	interpreterProxy success: (interpreterProxy isWords: dst).
	interpreterProxy success: (interpreterProxy isBytes: src).
	interpreterProxy success: (interpreterProxy isBytes: state).
	interpreterProxy failed ifTrue:[^ nil].
	srcSize := interpreterProxy slotSizeOf: src.
	dstSize := (interpreterProxy slotSizeOf: dst) * 2.
	self cCode: 'gsmDecode(state + 4, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
	interpreterProxy failed ifTrue:[^ nil].
	result := interpreterProxy makePointwithxValue: srcDelta yValue: dstDelta.
	interpreterProxy failed ifTrue:[^ nil].
	interpreterProxy pop: 6.
	interpreterProxy push: result.
! !
!SoundCodecPlugin methodsFor: 'gsm 6.10 codec' stamp: 'jm (auto pragmas 12/08) 2/4/1999 08:37'!
primitiveGSMEncode

	| dstIndex dst srcIndex src frameCount state srcSize dstSize result srcDelta dstDelta |
	<export: true>
	dstIndex := interpreterProxy stackIntegerValue: 0.
	dst := interpreterProxy stackObjectValue: 1.
	srcIndex := interpreterProxy stackIntegerValue: 2.
	src := interpreterProxy stackObjectValue: 3.
	frameCount := interpreterProxy stackIntegerValue: 4.
	state := interpreterProxy stackObjectValue: 5.
	interpreterProxy success: (interpreterProxy isBytes: dst).
	interpreterProxy success: (interpreterProxy isWords: src).
	interpreterProxy success: (interpreterProxy isBytes: state).
	interpreterProxy failed ifTrue:[^ nil].
	srcSize := (interpreterProxy slotSizeOf: src) * 2.
	dstSize := interpreterProxy slotSizeOf: dst.
	self cCode: 'gsmEncode(state + 4, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
	interpreterProxy failed ifTrue:[^ nil].
	result := interpreterProxy makePointwithxValue: srcDelta yValue: dstDelta.
	interpreterProxy failed ifTrue:[^ nil].
	interpreterProxy pop: 6.
	interpreterProxy push: result.
! !
!SoundCodecPlugin methodsFor: 'gsm 6.10 codec' stamp: 'bgf 2/25/2009 21:40'!
primitiveGSMNewState

	| stateBytes state |
	<export: true>
	stateBytes := self cCode: 'gsmStateBytes()'.
	state := interpreterProxy
		instantiateClass: interpreterProxy classByteArray
		indexableSize: stateBytes.
	self cCode: 'gsmInitState(state + 4)'.
	interpreterProxy pop: 1.
	interpreterProxy push: state.
! !

InterpreterPlugin subclass: #SoundGenerationPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!SoundGenerationPlugin commentStamp: '<historical>' prior: 0!
This class is a stub for the directly generated primitives in AbstractSound and subclasses.!
!SoundGenerationPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 18:16'!
declareCVarsIn: cg
	cg addHeaderFile: '"SoundGenerationPlugin.h"'.! !
!SoundGenerationPlugin class methodsFor: 'accessing' stamp: 'tpr 5/23/2001 17:11'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!SoundGenerationPlugin class methodsFor: 'accessing' stamp: 'tpr 4/9/2002 16:15'!
translateInDirectory: directory doInlining: inlineFlag
"handle a special case code string rather than generated code. 
NB sqOldSoundsPrims IS NOT FULLY INTEGRATED - it still isn't included in the exports list"
	| cg |
	self initialize.

	cg := self buildCodeGeneratorUpTo: InterpreterPlugin.

	cg addMethodsForPrimitives: AbstractSound translatedPrimitives.
	self storeString: cg generateCodeStringForPrimitives onFileNamed: (directory fullNameFor: self moduleName, '.c').
	"What we need here is some way to derive the prim names from sqOldSoundPrims - or dump it entirely. Perhaps add this class (without then generating the file again) using fake entry points like SurfacePlugin does"

	^cg exportedPrimitiveNames asArray
! !
!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar (auto pragmas 12/08) 2/3/2001 15:58'!
primitiveFMSoundMix
	<export: true>
	^self primFMSoundmixSampleCountintostartingAtpan! !
!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar (auto pragmas 12/08) 2/3/2001 15:59'!
primitiveOldSampledSoundMix
	<export: true>
	^self oldprimSampledSoundmixSampleCountintostartingAtleftVolrightVol! !
!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar (auto pragmas 12/08) 2/3/2001 15:58'!
primitivePluckedSoundMix
	<export: true>
	^self primPluckedSoundmixSampleCountintostartingAtpan! !
!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar (auto pragmas 12/08) 2/3/2001 15:58'!
primitiveSampledSoundMix
	<export: true>
	^self primSampledSoundmixSampleCountintostartingAtpan! !
!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar (auto pragmas 12/08) 2/3/2001 15:57'!
primitiveWaveTableSoundMix
	<export: true>
	^self primWaveTableSoundmixSampleCountintostartingAtpan! !

InterpreterPlugin subclass: #StarSqueakPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!StarSqueakPlugin commentStamp: '<historical>' prior: 0!
This plugin defines primitives accelerators to support StarSqueak. The plugin library, usually named "StarSqueakPlugin", should be put in the same folder as the Squeak interpreter. If this plugin is not available the primitives will still work, but they will be run much more slowly, since they will be running as Squeak code.
!
!StarSqueakPlugin methodsFor: 'all' stamp: 'jm (auto pragmas 12/08) 1/20/2001 11:01'!
checkedUnsignedIntPtrOf: oop
	"Return an unsigned int pointer to the first indexable word of oop, which must be a words object."

	<returnTypeC: 'unsigned int *'>
	interpreterProxy success: (interpreterProxy isWords: oop).
	interpreterProxy failed ifTrue: [^ 0].
	^ self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'unsigned int *'
! !
!StarSqueakPlugin methodsFor: 'all' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:22'!
primitiveDiffuseFromToWidthHeightDelta
	"Diffuse the integer values of the source patch variable Bitmap into the output Bitmap. Each cell of the output is the average of the NxN area around it in the source, where N = (2 * delta) + 1."

	| srcOop dstOop height width delta src dst area startY endY startX endX sum rowStart |
	<export: true>
	<var: 'src' type: 'unsigned int *'>
	<var: 'dst' type: 'unsigned int *'>

	srcOop := interpreterProxy stackValue: 4.
	dstOop := interpreterProxy stackValue: 3.
	width := interpreterProxy stackIntegerValue: 2.
	height := interpreterProxy stackIntegerValue: 1.
	delta := interpreterProxy stackIntegerValue: 0.
	src := self checkedUnsignedIntPtrOf: srcOop.
	dst := self checkedUnsignedIntPtrOf: dstOop.
	interpreterProxy success:
		(interpreterProxy stSizeOf: srcOop) = (interpreterProxy stSizeOf: dstOop).
	interpreterProxy success:
		(interpreterProxy stSizeOf: srcOop) = (width * height).
	interpreterProxy failed ifTrue: [^ nil].

	area := ((2 * delta) + 1) * ((2 * delta) + 1).
	0 to: height - 1 do: [:y |
		startY := y - delta.
		startY < 0 ifTrue: [startY := 0].
		endY := y + delta.
		endY >= height ifTrue: [endY := height - 1].
		0 to: width - 1 do: [:x |
			startX := x - delta.
			startX < 0 ifTrue: [startX := 0].
			endX := x + delta.
			endX >= width ifTrue: [endX := width - 1].

			sum := 0.
			startY to: endY do: [:y2 |
				rowStart := y2 * width.
				startX to: endX do: [:x2 |
					sum := sum + (src at: rowStart + x2)]].

			dst at: ((y * width) + x) put: (sum // area)]].

	interpreterProxy pop: 5.  "pop args, leave rcvr on stack"
! !
!StarSqueakPlugin methodsFor: 'all' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:22'!
primitiveEvaporateRate
	"Evaporate the integer values of the source Bitmap at the given rate. The rate is an integer between 0 and 1024, where 1024 is a scale factor of 1.0 (i.e., no evaporation)."

	| patchVarOop rate patchVar sz |
	<export: true>
	<var: 'patchVar' type: 'unsigned int *'>

	patchVarOop := interpreterProxy stackValue: 1.
	rate := interpreterProxy stackIntegerValue: 0.
	patchVar := self checkedUnsignedIntPtrOf: patchVarOop.
	sz := interpreterProxy stSizeOf: patchVarOop.
	interpreterProxy failed ifTrue: [^ nil].

	0 to: sz - 1 do: [:i |
		patchVar at: i put: (((patchVar at: i) * rate) >> 10)].

	interpreterProxy pop: 2.  "pop args, leave rcvr on stack"
! !
!StarSqueakPlugin methodsFor: 'all' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:22'!
primitiveMapFromToWidthHeightPatchSizeRgbFlagsShift

	| srcOop dstOop w h patchSize rgbFlags shiftAmount src dst rgbMult srcIndex level pixel offset |
	<export: true>
	<var: 'src' type: 'unsigned int *'>
	<var: 'dst' type: 'unsigned int *'>

	srcOop := interpreterProxy stackValue: 6.
	dstOop := interpreterProxy stackValue: 5.
	w := interpreterProxy stackIntegerValue: 4.
	h := interpreterProxy stackIntegerValue: 3.
	patchSize := interpreterProxy stackIntegerValue: 2.
	rgbFlags := interpreterProxy stackIntegerValue: 1.
	shiftAmount := interpreterProxy stackIntegerValue: 0.

	src := self checkedUnsignedIntPtrOf: srcOop.
	dst := self checkedUnsignedIntPtrOf: dstOop.
	interpreterProxy success:
		(interpreterProxy stSizeOf: dstOop) = (w * h).
	interpreterProxy success:
		(interpreterProxy stSizeOf: dstOop) = ((interpreterProxy stSizeOf: srcOop) * patchSize * patchSize).
	interpreterProxy failed ifTrue: [^ nil].

	rgbMult := 0.
	(rgbFlags bitAnd: 2r100) > 0 ifTrue: [rgbMult := rgbMult + 16r10000].
	(rgbFlags bitAnd: 2r10) > 0 ifTrue: [rgbMult := rgbMult + 16r100].
	(rgbFlags bitAnd: 2r1) > 0 ifTrue: [rgbMult := rgbMult + 16r1].
	srcIndex := -1.
	0 to: (h // patchSize) - 1 do: [:y |
		0 to: (w // patchSize) - 1 do: [:x |
			level := (src at: (srcIndex := srcIndex + 1)) bitShift: shiftAmount.
			level > 255 ifTrue: [level := 255].
			level <= 0
				ifTrue: [pixel := 1]  "non-transparent black"
				ifFalse: [pixel := level * rgbMult].

			"fill a patchSize x patchSize square with the pixel value"
			offset := ((y * w) + x) * patchSize.
			offset to: offset + ((patchSize - 1) * w) by: w do: [:rowStart |
				rowStart to: rowStart + patchSize - 1 do: [:dstIndex |
					dst at: dstIndex put: pixel]] ]].

	interpreterProxy pop: 7.  "pop args, leave rcvr on stack"
! !

InterpreterPlugin subclass: #SurfacePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!SurfacePlugin commentStamp: '<historical>' prior: 0!
This plugin is a fake. It doesn't do anything useful. It's sole purpose is to wrap the C code that's associated with the SurfacePlugin into the main VM generation process. Since the C code isn't easily generated from ST code this is (unfortunately) necessary. But look on the bright side - you don't have to define any weird stuff for the C compiler. Isn't that great?!! (just kidding...) !
!SurfacePlugin class methodsFor: 'translation' stamp: 'tpr 5/23/2001 17:12'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!SurfacePlugin class methodsFor: 'translation' stamp: 'tpr 7/4/2001 15:15'!
requiresCrossPlatformFiles
	"If there cross platform files to be associated with the plugin, here is where you want to flag"
	^true! !
!SurfacePlugin class methodsFor: 'translation' stamp: 'tpr 4/9/2002 16:15'!
translateInDirectory: directory doInlining: inlineFlag
"handle a special case external file rather than normal generated code."
	| cg |
	self initialize.

	cg := self buildCodeGeneratorUpTo: self.

	"We rely on the fake entry points implemented on the instance side to allow the export list to be accurate. Please update them if you change the code"
	^cg exportedPrimitiveNames asArray! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:33'!
initialiseModule
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:34'!
ioFindSurface
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:34'!
ioGetSurfaceFormat
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:34'!
ioLockSurface
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:34'!
ioRegisterSurface
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:34'!
ioShowSurface
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:34'!
ioUnlockSurface
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:34'!
ioUnregisterSurface
	"Fake entry point"
	<export: true>! !
!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar (auto pragmas 12/08) 5/26/2000 22:33'!
shutdownModule
	"Fake entry point"
	<export: true>! !

Object subclass: #InterpreterProxy
	instanceVariableNames: 'successFlag remapBuffer stack method argumentCount bb thisSessionID primFailCode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!InterpreterProxy commentStamp: '<historical>' prior: 0!
This class should provide the definition of what interpreter support plugins need and can have access to. Note that the proxy related files platforms - Cross - vm - sqVirtualMachine.[ch] are kept under the SVN tree at www.squeakvm.org .
The main use of the class is to support the vm simulator!
!InterpreterProxy class methodsFor: 'private' stamp: 'tpr 12/22/2005 17:13'!
validateProxyImplementation: anInterpreter 
	"InterpreterProxy validateProxyImplementation: Interpreter"

	| proxyClass catList |
	proxyClass := InterpreterProxy.
	catList := proxyClass organization categories copy asOrderedCollection.
	catList remove: 'initialize' ifAbsent:[].
	catList remove: 'private' ifAbsent:[].
	catList do:[:categ|
		(proxyClass organization listAtCategoryNamed: categ) do:[:selector|
			(anInterpreter canUnderstand: selector) 
				ifFalse:
					[self notifyWithLabel: selector, ' is not implemented in ', anInterpreter name]]]! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:40'!
argumentCountOf: methodPointer
	^methodPointer numArgs! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar (auto pragmas 12/08) 10/11/1998 03:01'!
arrayValueOf: oop
	<returnTypeC: 'void *'>
	self success: (self isWordsOrBytes: oop).
	^CArrayAccessor on: oop.! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
become: array1 with: array2
	array1 elementsExchangeIdentityWith: array2! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 21:27'!
booleanValueOf: obj
	obj == true ifTrue:[^true].
	obj == false ifTrue:[^false].
	self primitiveFail.
	^nil! !
!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:11'!
byteAt: accessor
	^accessor byteAt: 0! !
!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:12'!
byteAt: accessor put: value
	^accessor byteAt: 0 put: value! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:23'!
byteSizeOf: oop
	"Return the size of the receiver in bytes"
	^oop class isBytes
		ifTrue:[(self slotSizeOf: oop)]
		ifFalse:[(self slotSizeOf: oop) * 4]! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
byteSwapped: w
	"Return the given integer with its bytes in the reverse order."

	^ ((w bitShift: -24) bitAnd: 16rFF) +
	  ((w bitShift: -8) bitAnd: 16rFF00) +
	  ((w bitShift: 8) bitAnd: 16rFF0000) +
	  ((w bitShift: 24) bitAnd: 16rFF000000)
! !
!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 21:43'!
characterTable
	^Character characterTable! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/4/1998 15:47'!
checkedIntegerValueOf: intOop
	(self isIntegerObject: intOop)
		ifTrue:[^self integerValueOf: intOop]
		ifFalse:[self primitiveFail. ^0].! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'eem 11/26/2007 17:47'!
classAlien
        ^Smalltalk at: #Alien ifAbsent: [nil]! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:42'!
classArray
	^Array! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classBitmap
	^Bitmap! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classByteArray
	^ByteArray! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classCharacter
	^Character! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:03'!
classExternalAddress
	^Smalltalk at: #ExternalAddress ifAbsent:[nil]! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:03'!
classExternalData
	^Smalltalk at: #ExternalData ifAbsent:[nil]! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:03'!
classExternalFunction
	^Smalltalk at: #ExternalFunction ifAbsent:[nil]! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:04'!
classExternalLibrary
	^Smalltalk at: #ExternalLibrary ifAbsent:[nil]! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:04'!
classExternalStructure
	^Smalltalk at: #ExternalStructure ifAbsent:[nil]! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classFloat
	^Float! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 11/19/1999 14:29'!
classLargeNegativeInteger
	^LargeNegativeInteger! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classLargePositiveInteger
	^LargePositiveInteger! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classPoint
	^Point! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classSemaphore
	^Semaphore! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 21:43'!
classSmallInteger
	^SmallInteger! !
!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classString
	^String! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'eem 4/18/2008 15:17'!
classUnsafeAlien
        ^Smalltalk at: #UnsafeAlien ifAbsent: [nil]! !
!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/18/1998 20:11'!
clone: oop
	^oop clone! !
!InterpreterProxy methodsFor: 'BitBlt support' stamp: 'ar 4/12/1999 23:29'!
copyBits
	bb copyBits.! !
!InterpreterProxy methodsFor: 'BitBlt support' stamp: 'ar 4/12/1999 23:29'!
copyBitsFrom: leftX to: rightX at: yValue
	bb copyBitsFrom: leftX to: rightX at: yValue.! !
!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 21:42'!
displayObject
	^Display! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
failed
	^successFlag not! !
!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 20:40'!
falseObject
	^false! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar (auto pragmas 12/08) 10/10/1998 21:22'!
fetchArray: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
	"Note: May be called by translated primitive code."

	| arrayOop |
	<returnTypeC: 'void *'>
	arrayOop := self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self arrayValueOf: arrayOop
! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:07'!
fetchClassOf: oop
	^oop class! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar (auto pragmas 12/08) 10/10/1998 21:21'!
fetchFloat: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
	"Note: May be called by translated primitive code."

	| floatOop |
	<returnTypeC: 'double'>
	floatOop := self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self floatValueOf: floatOop! !
!InterpreterProxy methodsFor: 'object access' stamp: 'tpr (auto pragmas 12/08) 3/15/2004 20:20'!
fetchInteger: fieldIndex ofObject: objectPointer
	"Note: May be called by translated primitive code."

	| intOop |
	<inline: false>
	intOop := self fetchPointer: fieldIndex ofObject: objectPointer.
	^self checkedIntegerValueOf: intOop! !
!InterpreterProxy methodsFor: 'private' stamp: 'ar 10/27/1999 14:13'!
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
	"Support for BitBlt simulation only"
	| intOrFloat |
	intOrFloat := self fetchPointer: fieldIndex ofObject: objectPointer.
	(self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
	intOrFloat isFloat ifTrue:[^intOrFloat truncated].
	^self primitiveFail.! !
!InterpreterProxy methodsFor: 'object access' stamp: 'tpr 6/6/2005 19:11'!
fetchLong32: fieldIndex ofObject: oop
"fetchWord:ofObject: is rescinded as of VMMaker 3.8 64bit VM. This is the same code as used therein and may need revision for 64 bit cleanliness"
	^oop instVarAt: fieldIndex+1! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 16:04'!
fetchPointer: index ofObject: oop
	^oop instVarAt: index+1! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar (auto pragmas dtl 2010-09-28) 9/18/1998 20:26'!
firstFixedField: oop
	<returnTypeC: 'void *'>
	^CObjectAccessor on: oop! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar (auto pragmas dtl 2010-09-28) 10/10/1998 16:22'!
firstIndexableField: oop
	<returnTypeC: 'void *'>
	^CArrayAccessor on: oop! !
!InterpreterProxy methodsFor: 'converting' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:35'!
floatObjectOf: aFloat
	<var: #aFloat type: 'double '>
	aFloat class == Float ifFalse:[self error:'Not a float object'].
	^aFloat! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar (auto pragmas dtl 2010-09-28) 10/10/1998 16:09'!
floatValueOf: oop
	<returnTypeC: 'double'>
	oop class == Float
		ifTrue:[^oop]
		ifFalse:[self primitiveFail. ^0.0].! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:52'!
fullDisplayUpdate
	Display display! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
fullGC
	Smalltalk garbageCollect.! !
!InterpreterProxy methodsFor: 'other' stamp: 'eem 11/2/2007 13:25'!
getStackPointer
	self error: 'not yet implemented in Smalltalk'! !
!InterpreterProxy methodsFor: 'other' stamp: 'tpr 12/21/2005 18:49'!
getThisSessionID
	"Answer a session identifier which represents the current instance of Squeak.
	The identifier is expected to be unique among all instances of Squeak on a
	network at any point in time."

	[thisSessionID = 0]
		whileTrue:
			[thisSessionID := (Random new next * SmallInteger maxVal) asInteger].
	^ thisSessionID
! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 11/17/1999 22:04'!
includesBehavior: aClass ThatOf: aSuperclass
	^aClass includesBehavior: aSuperclass! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:52'!
incrementalGC
	Smalltalk garbageCollectMost.! !
!InterpreterProxy methodsFor: 'initialize' stamp: 'ar 9/16/1998 01:35'!
initialize
	successFlag := true.
	remapBuffer := OrderedCollection new.
	stack := OrderedCollection new.! !
!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/16/1998 01:11'!
instantiateClass: classPointer indexableSize: size
	^size = 0 
		ifTrue:[classPointer basicNew]
		ifFalse:[classPointer basicNew: size]! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:13'!
integerObjectOf: value
	value class == SmallInteger ifFalse:[self error:'Not a SmallInteger object'].
	^value! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:10'!
integerValueOf: oop
	oop class == SmallInteger ifFalse:[self error:'Not a SmallInteger'].
	^oop! !
!InterpreterProxy methodsFor: 'object access' stamp: 'eem 6/27/2007 14:44'!
internalIsImutable: oop
	^oop isImmutable! !
!InterpreterProxy methodsFor: 'object access' stamp: 'eem 6/27/2007 14:44'!
internalIsMutable: oop
	^oop isImmutable not! !
!InterpreterProxy methodsFor: 'converting' stamp: 'tpr 12/29/2005 17:35'!
ioFilename: aCharBuffer fromString: aFilenameString ofLength: filenameLength resolveAliases: aBoolean
	"the vm has to convert aFilenameString via any canonicalization and char-mapping and put the result in aCharBuffer. This doesn't translate well in Smalltalk since we know how long strings are rather than considering them terminated by a 0 char. Do the best we can.
Note the resolveAliases flag - this is an awful artefact of OSX and Apples demented alias handling. When opening a file, the flag must be  true, when closing or renaming it must be false. Sigh."
	aCharBuffer replaceFrom:1 to: filenameLength with: aFilenameString! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 5/11/2000 20:05'!
ioLoadFunction: functionName From: moduleName
	"Dummy - provided by support code"
	^0! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/28/1999 18:33'!
ioLoadModule: moduleNameIndex OfLength: moduleLength
	"Dummy - provided by support code"
	^0! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/28/1999 18:34'!
ioLoadSymbol: functionNameIndex OfLength: functionLength FromModule: moduleHandle
	"Dummy - provided by support code"
	^0! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 5/13/2000 14:55'!
ioMicroMSecs
	^Time millisecondClockValue! !
!InterpreterProxy methodsFor: 'testing' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 16:35'!
is: oop KindOf: aString
	"InterpreterProxy new is: 42 KindOf: 'Number'"
	| theClass |
	<var: #aString type: 'char *'>
	theClass := Smalltalk at: aString asSymbol ifAbsent:[nil].
	^theClass isNil
		ifTrue:[false]
		ifFalse:[^oop isKindOf: theClass]! !
!InterpreterProxy methodsFor: 'testing' stamp: 'tpr (auto pragmas dtl 2010-09-28) 12/29/2005 16:35'!
is: oop MemberOf: aString
	"InterpreterProxy new is: 42 MemberOf:'SmallInteger'"
	| theClass |
	<var: #aString type: 'char *'>
	theClass := Smalltalk at: aString asSymbol ifAbsent:[nil].
	^theClass isNil
		ifTrue:[false]
		ifFalse:[^oop isMemberOf: theClass]! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 12/5/2003 20:17'!
isArray: oop
	^(self isIntegerObject: oop) not and:[(oop class format bitAnd: 15) = 2]
! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:04'!
isBytes: oop
	^oop class isBytes! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 21:44'!
isFloatObject: oop
	^oop class == Float! !
!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/28/1999 19:04'!
isInMemory: address
	"Return true if the given address is in ST object memory"
	^true! !
!InterpreterProxy methodsFor: 'testing' stamp: 'acg 9/19/1999 13:11'!
isIndexable: oop
	^oop class isVariable! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:12'!
isIntegerObject: objectPointer
	^objectPointer class == SmallInteger! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:13'!
isIntegerValue: intValue
	^intValue class == SmallInteger! !
!InterpreterProxy methodsFor: 'private' stamp: 'ar 10/27/1999 14:21'!
isInterpreterProxy
	"Return true since I am not a real Interpreter simulation"
	^true! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:04'!
isPointers: oop
	^oop class isPointers! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:16'!
isWeak: oop
	^oop class isWeak! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 10/9/1998 22:19'!
isWords: oop
	^oop class isPointers not and:[oop class isBytes not]! !
!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:05'!
isWordsOrBytes: oop
	^(self isBytes: oop) or:[self isWords: oop]! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:38'!
literal: offset ofMethod: methodPointer
	^methodPointer literals at: offset+1! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:40'!
literalCountOf: methodPointer
	^methodPointer numLiterals! !
!InterpreterProxy methodsFor: 'BitBlt support' stamp: 'ar 4/12/1999 23:29'!
loadBitBltFrom: bbOop
	bb := bbOop.! !
!InterpreterProxy methodsFor: 'initialize' stamp: 'ar 10/3/1998 18:50'!
loadStackFrom: aContext
	self push: aContext receiver.
	method := aContext method.
	argumentCount := method numArgs.
	1 to: argumentCount do:[:i| self push: (aContext at: i) ].! !
!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:11'!
longAt: accessor
	^accessor longAt: 0! !
!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:11'!
longAt: accessor put: value
	^accessor longAt: 0 put: value! !
!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 10/10/1998 16:14'!
makePointwithxValue: xValue yValue: yValue
	(xValue class == SmallInteger and:[yValue class == SmallInteger]) 
		ifFalse:[self error:'Not SmallInteger objects'].
	^xValue@yValue! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:43'!
methodArgumentCount
	^argumentCount! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:43'!
methodPrimitiveIndex
	^method primitive! !
!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 20:40'!
nilObject
	^nil! !
!InterpreterProxy methodsFor: 'object access' stamp: 'tpr 6/6/2005 19:28'!
obsoleteDontUseThisFetchWord: fieldIndex ofObject: oop
"fetchWord:ofObject: is rescinded as of VMMaker 3.8 64bit VM. This is a placeholder to sit in the sqVirtualMachine structure to support older plugins for a while"
	self halt: 'deprecated method'! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 01:41'!
pop: nItems
	1 to: nItems do:[:i| stack removeLast].! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 01:41'!
pop: nItems thenPush: oop
	self pop: nItems.
	self push: oop.! !
!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/16/1998 01:14'!
popRemappableOop
	^remapBuffer removeLast! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:11'!
positive32BitIntegerFor: integerValue
	integerValue isInteger ifFalse:[self error:'Not an Integer object'].
	^integerValue > 0
		ifTrue:[integerValue]
		ifFalse:[ (1 bitShift: 32) + integerValue]! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:12'!
positive32BitValueOf: oop
	oop isInteger ifFalse:[self error:'Not an integer object'].
	oop < 0 
		ifTrue:[self primitiveFail. ^0]
		ifFalse:[^oop]! !
!InterpreterProxy methodsFor: 'converting' stamp: 'JMM 11/8/2001 15:26'!
positive64BitIntegerFor: integerValue
	integerValue isInteger ifFalse:[self error:'Not an Integer object'].
	^integerValue > 0
		ifTrue:[integerValue]
		ifFalse:[ (1 bitShift: 64) + integerValue]! !
!InterpreterProxy methodsFor: 'converting' stamp: 'JMM 11/8/2001 15:27'!
positive64BitValueOf: oop
	oop isInteger ifFalse:[self error:'Not an integer object'].
	oop < 0 
		ifTrue:[self primitiveFail. ^0]
		ifFalse:[^oop]! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
primitiveFail
	(self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt].
	successFlag := false.! !
!InterpreterProxy methodsFor: 'other' stamp: 'eem 11/1/2007 16:08'!
primitiveFailFor: reasonCode
	"Set specific primitive failure."
	(self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt].
	primFailCode := reasonCode! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:39'!
primitiveIndexOf: methodPointer
	^methodPointer primitive! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 11/28/1999 17:43'!
primitiveMethod
	"Return the method an external primitive was defined in"
	^method! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 01:42'!
push: object
	stack addLast: object! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 10/10/1998 21:16'!
pushBool: trueOrFalse
	(trueOrFalse == true or:[trueOrFalse == false]) ifFalse:[self error:'Not a Boolean'].
	self push: trueOrFalse! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:35'!
pushFloat: f
	<var: #f type: 'double '>
	f class == Float ifFalse:[^self error:'Not a Float'].
	self push: f.! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 10/10/1998 21:20'!
pushInteger: integerValue
	self push: (self integerObjectOf: integerValue).! !
!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/16/1998 01:14'!
pushRemappableOop: oop
	remapBuffer addLast: oop! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:52'!
showDisplayBits: aForm Left: l Top: t Right: r Bottom: b
	aForm == Display ifTrue:[
		Display forceToScreen: (Rectangle left: l right: r top: t bottom: b)].! !
!InterpreterProxy methodsFor: 'other' stamp: 'JMM 6/6/2000 21:00'!
signalSemaphoreWithIndex: semaIndex
	((Smalltalk externalObjects) at: semaIndex) signal! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 11/29/1999 22:01'!
signed32BitIntegerFor: integerValue
	integerValue isInteger ifFalse:[self error:'Not an Integer object'].
	^integerValue! !
!InterpreterProxy methodsFor: 'converting' stamp: 'ar 11/29/1999 22:00'!
signed32BitValueOf: oop
	oop isInteger ifFalse:[self error:'Not an integer object'].
	^oop! !
!InterpreterProxy methodsFor: 'converting' stamp: 'JMM 11/8/2001 15:27'!
signed64BitIntegerFor: integerValue
	integerValue isInteger ifFalse:[self error:'Not an Integer object'].
	^integerValue! !
!InterpreterProxy methodsFor: 'converting' stamp: 'JMM 11/8/2001 15:27'!
signed64BitValueOf: oop
	oop isInteger ifFalse:[self error:'Not an integer object'].
	^oop! !
!InterpreterProxy methodsFor: 'object access' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:35'!
sizeOfSTArrayFromCPrimitive: cPtr
	"Note: Only called by translated primitive code."
	<var: #cPtr type: 'void *'>
	^self shouldNotImplement! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:24'!
slotSizeOf: oop
	"Returns the number of slots in the receiver.
	If the receiver is a byte object, return the number of bytes.
	Otherwise return the number of words."
	^(oop basicSize) + (oop class instSize)! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:53'!
stObject: array at: index
	^array at: index! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:53'!
stObject: array at: index put: value
	^array at: index put: value! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:26'!
stSizeOf: oop
	"Return the number of indexable fields in the receiver"
	^oop basicSize! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar (auto pragmas 12/08) 9/27/1998 15:22'!
stackFloatValue: offset
	| oop |
	<returnTypeC: 'double'>
	oop := self stackValue: offset.
	(self isFloatObject: oop) ifFalse: [self primitiveFail. ^0.0].
	^oop! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 22:07'!
stackIntegerValue: offset
	| oop |
	oop := self stackValue: offset.
	(self isIntegerObject: oop) ifFalse: [self primitiveFail. ^0].
	^oop! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 22:07'!
stackObjectValue: offset
	| oop |
	oop := self stackValue: offset.
	(self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
	^oop! !
!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 11:47'!
stackValue: offset
	^stack at: stack size - offset.! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/25/1998 16:16'!
storeInteger: index ofObject: oop withValue: integer
	(self isIntegerValue: integer) 
		ifTrue:[^self storePointer: index ofObject: oop withValue: integer]
		ifFalse:[^self primitiveFail]! !
!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 21:25'!
storePointer: index ofObject: oop withValue: valuePointer
	^oop instVarAt: index+1 put: valuePointer! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/19/1998 13:30'!
success: aBoolean
	successFlag not ifTrue:[^self].
	successFlag := successFlag and:[aBoolean].
	successFlag not ifTrue:[
		(self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt]].! !
!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
superclassOf: classPointer
	^classPointer superclass! !
!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 20:41'!
trueObject
	^true! !
!InterpreterProxy methodsFor: 'other' stamp: 'tpr 12/22/2005 17:48'!
vmEndianness
	"return 0 for little endian, 1 for big endian"
	^SmalltalkImage current endianness =#big ifTrue:[1] ifFalse:[0]! !

Object subclass: #InterpreterSimulationObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
!InterpreterSimulationObject methodsFor: 'simulation' stamp: 'di 8/5/2004 18:55'!
cCoerce: value to: cTypeString
	"Here the Simulator has a chance to create properly typed flavors of CArray access."

	value isCObjectAccessor ifTrue:
		[^ self getInterpreter cCoerce: value to: cTypeString].
	(value isMemberOf: CArray) ifTrue:
		[^ self getInterpreter cCoerce: value to: cTypeString].
	^ value! !
!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'di 8/5/2004 20:56'!
long32At: byteAddress
	"Simulation support.  Answer the 32-bit word at byteAddress which must be 0 mod 4."

	^self getInterpreter long32At: byteAddress! !
!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'di 8/5/2004 20:56'!
long32At: byteAddress put: a32BitValue
	"Simulation support.  Store the 32-bit value at byteAddress which must be 0 mod 4."

	^self getInterpreter long32At: byteAddress put: a32BitValue! !
!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'ikp 8/3/2004 15:56'!
oopForPointer: aPointer
	"Simulation support.  Pointers and oops are the same when simulating; answer aPointer."

	^aPointer! !
!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'ikp 8/3/2004 15:56'!
pointerForOop: anOop
	"Simulation support.  Pointers and oops are the same when simulating; answer anOop."

	^anOop! !
!Object class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:05'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asNakedOopFrom: anInteger on: aStream! !
!Object class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/20/1999 13:01'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg emitCExpression: aNode on: aStream! !
!Object class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 10/5/1999 06:10'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg emitCExpression: aNode on: aStream! !
!Object class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/18/1999 16:09'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asKindOf: self from: anInteger! !
!Object class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/20/1999 11:12'!
ccgCanConvertFrom: anObject

	^anObject isKindOf: self! !
!Object class methodsFor: '*VMMaker-plugin generation' stamp: 'ikp 3/31/2005 14:20'!
ccgDeclareCForVar: aSymbolOrString

	^'sqInt ', aSymbolOrString! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 9/19/1999 20:39'!
asIf: aClass var: aString

	|index|
	index := aClass allInstVarNames 
		indexOf: aString
		ifAbsent: [self error: 'must use instVar name'].
	^self instVarAt: index
! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 10/5/1999 06:35'!
asIf: aClass var: aString asValue: someClass

	^(self asIf: aClass var: aString) asValue: someClass
! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 9/19/1999 20:40'!
asIf: aClass var: aString put: aValue

	|index|
	index := aClass allInstVarNames 
		indexOf: aString
		ifAbsent: [self error: 'must use instVar name'].
	^self instVarAt: index put: aValue
! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 9/20/1999 11:30'!
asOop: aClass

	(self class isVariable and: [self class instSize > 0])
		ifTrue: [self error: 'cannot auto-coerce indexable objects with named instance variables'].
	(aClass ccgCanConvertFrom: self)
		ifFalse: [self error: 'incompatible object for this coercion'].
	^self! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 9/19/1999 20:21'!
asSmallIntegerObj

	^self! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 10/5/1999 06:21'!
asValue: aClass

	^self! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'dtl 10/12/2010 20:16'!
buildCodeGeneratorUpTo: aClass
	"Build a CCodeGenerator for this class. By default, generate only the
	the methods for aClass."
	 | cg |
	cg := self codeGeneratorClass new initialize.
	cg declareModuleName: self name.
	cg addClass: aClass.
	^cg
! !
!Object methodsFor: '*VMMaker-translation support'!
cCode: codeString
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'eem 9/16/2009 18:08'!
cCode: codeStringOrBlock inSmalltalk: aBlock
	"Support for Smalltalk-to-C translation. The first argument is output when generating C code.
	 But if this code is being simulated in Smalltalk, answer the result of evaluating the given block.
	 If the first argument is a string it is output literally, and if it is a block it is translated."

	^aBlock value
! !
!Object methodsFor: '*VMMaker-translation support'!
cCoerce: value to: cType
	"Type coercion for translation only; just return the value when running in Smalltalk."

	^ value! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'dtl 10/12/2010 20:16'!
codeGeneratorClass
	^CCodeGenerator! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'sr 12/23/2001 21:38'!
debugCode: aBlock 
	"Sending this message tells the code generator that there is debug code in 
	aBlock. Debug code will be be generated only, if the correponding flag 
	has been set by TestCodeGenerator>>generateDebugCode:.
	In ST simulation just perform the debug code."
	aBlock value! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'ar 9/18/1998 23:27'!
export: aBoolean
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: '' prior: 25009951!
inline: inlineFlag
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'di 7/14/2004 12:15'!
isCObjectAccessor

	^ false! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'dtl 11/9/2006 19:37'!
isDefined: directiveString inSmalltalk: conditionBlock comment: commentStringOrNil ifTrue: trueExpressionOrBlock
	"When translated, produces #ifdef #endif CPP directives.
	Example usage:

	self isDefined: 'HAVE_FOO'
		inSmalltalk: [self isFoo]
		comment: 'some platforms do not support foo properly'
		ifTrue: [self doThingsThatWorkIfFooIsPresent]

	Generated C code:
	
	# ifdef HAVE_FOO  // some platforms do not support foo properly
 		doThingsThatWorkIfFooIsPresent();
	# endif  // HAVE_FOO
	"

	^ self isDefined: directiveString
			inSmalltalk: conditionBlock
			comment: commentStringOrNil
			ifTrue: trueExpressionOrBlock
			ifFalse: []
! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'dtl 11/9/2006 19:59'!
isDefined: directiveString inSmalltalk: conditionBlock comment: commentStringOrNil ifTrue: trueExpressionOrBlock ifFalse: falseExpressionOrBlockOrNil
	"When translated, produces #ifdef #else #endif CPP directives.
	Example usage:

	Smalltalk Slang:
		self isDefined: 'HAVE_FOO'
			inSmalltalk: [self isFoo]
			comment: 'some platforms do not support foo properly'
			ifTrue: [self doThingsThatWorkIfFooIsPresent]
			ifFalse: [self doSomethingElseInstead]

	Generated C code:
		# ifdef HAVE_FOO  // some platforms do not support foo properly
			doThingsThatWorkIfFooIsPresent();
		# else
			doSomethingElseInstead();
		# endif  // HAVE_FOO

	Smalltalk Slang:
		hasFoo := self isDefined: 'HAVE_FOO'
					inSmalltalk: [self isFoo]
					comment: 'some platforms do not support foo properly'
					ifTrue: [true]
					ifFalse: [false].

	Generated C code:
		hasFoo =
	# ifdef HAVE_FOO  // some platforms do not support foo properly
			1
	# else
			0
	# endif  // HAVE_FOO
 		;

	"

	^ conditionBlock value
		ifTrue: [trueExpressionOrBlock value]
		ifFalse: [falseExpressionOrBlockOrNil value]
! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'dtl 5/17/2010 15:14'!
isDefinedTrueExpression: condition inSmalltalk: conditionBlock comment: commentStringOrNil ifTrue: trueExpressionOrBlock ifFalse: falseExpressionOrBlockOrNil
	"When translated, produces #if (condition) #else #endif CPP directives.
	Example usage:

		self isDefinedTrueExpression: 'BytesPerWord == 8'
			inSmalltalk: [BytesPerWord = 8]
			comment: 'conditional on object word size'
			ifTrue: [self doSomethingFor64BitWord]
			ifFalse: [self doSomethingFor32BitWord]"

	^ conditionBlock value
		ifTrue: [trueExpressionOrBlock value]
		ifFalse: [falseExpressionOrBlockOrNil value]
! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'dtl 8/14/2009 09:31'!
preprocessorExpression: directive
	"For translation only; noop when running in Smalltalk.
	When translated, emits directive as a C preprocessor directive.

	Example usage:

	self preprocessorExpression: 'ifdef HAS_FOO'.
	self doFooStuff.
	self preprocessorExpression: 'endif'.
	
	Generated C code:
	
	# ifdef HAS_FOO
		doFooStuff();
	# endif
	"! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'nk 4/5/2005 20:50'!
primitive: primName
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'nk 4/5/2005 20:50'!
primitive: primName parameters: parms
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'tpr 6/9/2003 16:40'!
primitive: primID parameters: parmSpecs receiver: rcvrSpec
"belongs in CCG package"
	| tMethod |
	tMethod := SmartSyntaxPluginTMethod new 
		fromContext: thisContext sender 
		primitive: primID 
		parameters: parmSpecs 
		receiver: rcvrSpec.
	^tMethod simulatePrologInContext: thisContext sender! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 1/1/2000 12:45'!
remapOop: oopOrList in: aBlock
	"For translation only; noop when running in Smalltalk."
	^aBlock value! !
!Object methodsFor: '*VMMaker-translation support'!
returnTypeC: typeString
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support'!
sharedCodeNamed: label inCase: caseNumber
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 1/1/2000 12:46'!
stAt: index

	^self at: index! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 1/1/2000 12:46'!
stAt: index put: value

	^self at: index put: value! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 1/1/2000 22:42'!
stSize

	^self size! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'ar 2/21/2000 00:42'!
static: aBoolean
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'acg 12/18/1999 11:31'!
suppressFailureGuards: failureGuardFlag
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'nk 4/5/2005 20:45'!
touch: something
	"For translation only; eliminated by CCodeGenerator"! !
!Object methodsFor: '*VMMaker-translation support' stamp: '' prior: 25010074!
var: varSymbol declareC: declString
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'sma 3/3/2000 12:06'!
var: varSymbol type: typeString
	"For translation only; noop when running in Smalltalk."! !
!Object methodsFor: '*VMMaker-translation support' stamp: 'sma 3/3/2000 12:06'!
var: varSymbol type: typeString array: array
	"For translation only; noop when running in Smalltalk."! !

Object subclass: #ObjectMemory
	instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcSemaphoreIndex gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statFullGCMSecs statIncrGCs statIncrGCMSecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statGCTime statSpecialMarkCount statIGCDeltaTime statpendingFinalizationSignals forceTenureFlag'
	classVariableNames: 'BlockContextProto Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask CharacterTable ClassAlien ClassArray ClassBitmap ClassBlockClosure ClassBlockContext ClassByteArray ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassPoint ClassProcess ClassPseudoContext ClassSemaphore ClassString ClassTranslatedMethod ClassUnsafeAlien ClassWeakFinalizer CompactClassMask CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero ContextFixedSizePlusHeader CtxtTempFrameStart DoAssertionChecks DoBalanceChecks Done ExternalObjectsArray ExtraRootSize FalseObject GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass InvokeCallbackSelector LargeContextBit MethodContextProto NilContext NilObject ProcessSignalingLowSpace RemapBufferSize RootTableRedZone RootTableSize SchedulerAssociation SelectorAboutToReturn SelectorAttemptToAssign SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SelectorRunWithIn SpecialSelectors StackStart StartField StartObj TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward'
	poolDictionaries: ''
	category: 'VMMaker-Interpreter'!

ObjectMemory class
	instanceVariableNames: 'timeStamp'!
!ObjectMemory commentStamp: '<historical>' prior: 0!
This class describes a 32-bit direct-pointer object memory for Smalltalk.  The model is very simple in principle:  a pointer is either a SmallInteger or a 32-bit direct object pointer.

SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.

All object pointers point to a header, which may be followed by a number of data fields.  This object memory achieves considerable compactness by using a variable header size (the one complexity of the design).  The format of the 0th header word is as follows:

	3 bits	reserved for gc (mark, root, unused)
	12 bits	object hash (for HashSets)
	5 bits	compact class index
	4 bits	object format
	6 bits	object size in 32-bit words
	2 bits	header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)

If a class is in the compact class table, then this is the only header information needed.  If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits.  It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.

The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).

This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers.  It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.

There is now a simple 64-bit version of the object memory.  It is the simplest possible change that could work.  It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits.  The format of the base header word is changed in one minor, not especially elegant, way.  Consider the old 32-bit header:
	ggghhhhhhhhhhhhcccccffffsssssstt
The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit.  At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue.  So, the change is as follows:
	ggghhhhhhhhhhhhcccccffffsssssrtt
where bit r supplies the 4's bit of the byte size residue for byte objects.  Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit.

See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.!

ObjectMemory class
	instanceVariableNames: 'timeStamp'!

ObjectMemory subclass: #Interpreter
	instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector argumentCount newMethod currentBytecode successFlag primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB processSignalingLowSpace savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory newNativeMethod methodClass receiverClass interpreterVersion imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods primFailCode imageFormatInitialVersion'
	classVariableNames: 'ActiveProcessIndex AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BlockMethodIndex BytecodeTable CacheProbeMax CallerIndex CharacterValueIndex ClosureCopiedValuesIndex ClosureFirstCopiedValueIndex ClosureIndex ClosureMethodIndex ClosureNumArgsIndex ClosureOuterContextIndex ClosureStartPCIndex CompilerHooksSize CrossedX DirBadPath DirEntryFound DirNoMoreEntries EndOfRun ExcessSignalsIndex FirstLinkIndex HeaderIndex HomeIndex InitialIPIndex InstanceSpecificationIndex InstructionPointerIndex InterpreterSourceVersion JitterTable LastLinkIndex LiteralStart MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MessageArgumentsIndex MessageDictionaryIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodCacheClass MethodCacheEntries MethodCacheEntrySize MethodCacheMask MethodCacheMethod MethodCacheNative MethodCachePrim MethodCachePrimFunction MethodCacheSelector MethodCacheSize MethodIndex MillisecondClockMask MyListIndex NextLinkIndex PrimErrBadArgument PrimErrBadIndex PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrTableIndex PrimErrUnsupported PrimNoErr PrimitiveExternalCallIndex PrimitiveTable PriorityIndex ProcessListsIndex ReceiverIndex SelectorStart SemaphoresToSignalSize SenderIndex StackPointerIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex SuspendedContextIndex TempFrameStart ValueIndex XIndex YIndex'
	poolDictionaries: ''
	category: 'VMMaker-Interpreter'!
!Interpreter commentStamp: '<historical>' prior: 0!
This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas.

It has been modernized with 32-bit pointers, better management of Contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms.

In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case.

NOTE:  Here follows a list of things to be borne in mind when working on this code, or when making changes for the future.

1.  There are a number of things that should be done the next time we plan to release a copletely incompatible image format.  These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:.  Also, contexts should be given a special format code (see next item).

2.  There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change.  This is necessary because the oops may change during a compaction when the oops are being adjusted.  It's important to be aware of this when writing a new image using the systemTracer.  A better solution would be to reserve one of the format codes for Contexts only.

3.  We have made normal files tolerant to size and positions up to 32 bits.  This has not been done for async files, since they are still experimental.  The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes.

4.  Note that 0 is used in a couple of places as an impossible oop.  This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment).  The places include the method cache and the at cache. !
!Interpreter class methodsFor: 'constants'!
bytecodeTable

	^ BytecodeTable! !
!Interpreter class methodsFor: 'translation' stamp: 'dtl 10/5/2010 23:19'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator addHeaderFile:'<setjmp.h>'.
	aCCodeGenerator 
		var: #interpreterProxy 
		type: #'struct VirtualMachine*'.
	aCCodeGenerator
		var: #primitiveTable
		declareC: 'void *primitiveTable[', (MaxPrimitiveIndex +2) printString, '] = ',	self primitiveTableString.
	aCCodeGenerator
		var: #primitiveFunctionPointer
		declareC: 'void *primitiveFunctionPointer'				.		"xxxx FIX THIS STUPIDITY xxxx - ikp. What he means is use a better type than void *, apparently - tpr"
	aCCodeGenerator
		var: #methodCache
		declareC: 'long methodCache[', (MethodCacheSize + 1) printString, ']'.
	aCCodeGenerator
		var: #atCache
		declareC: 'sqInt atCache[', (AtCacheTotalSize + 1) printString, ']'.
	aCCodeGenerator var: #statGCTime type: #'sqLong'.
	aCCodeGenerator var: #statFullGCMSecs type: #'sqLong'.
	aCCodeGenerator var: #statIGCDeltaTime type: #'sqLong'.
	aCCodeGenerator var: #statIncrGCMSecs type: #'sqLong'.
	aCCodeGenerator var: #localIP type: #'char*'.
	aCCodeGenerator var: #localSP type: #'char*'.
	aCCodeGenerator var: #showSurfaceFn type: #'void*'.
	aCCodeGenerator var: 'semaphoresToSignalA'
		declareC: 'sqInt semaphoresToSignalA[', (SemaphoresToSignalSize + 1) printString, ']'.
	aCCodeGenerator var: 'semaphoresToSignalB'
		declareC: 'sqInt semaphoresToSignalB[', (SemaphoresToSignalSize + 1) printString, ']'.
	aCCodeGenerator
		var: #compilerHooks
		declareC: 'sqInt (*compilerHooks[', (CompilerHooksSize + 1) printString, '])()'.
	aCCodeGenerator
		var: #interpreterVersion
		declareC: 'const char *interpreterVersion = "', SmalltalkImage current datedVersion, ' [', SmalltalkImage current lastUpdateString,']"'.
	aCCodeGenerator
		var: #obsoleteIndexedPrimitiveTable
		declareC: 'char* obsoleteIndexedPrimitiveTable[][3] = ', self obsoleteIndexedPrimitiveTableString.
	aCCodeGenerator
		var: #obsoleteNamedPrimitiveTable
		declareC: 'const char* obsoleteNamedPrimitiveTable[][3] = ', self obsoleteNamedPrimitiveTableString.
	aCCodeGenerator
		var: #externalPrimitiveTable
		declareC: 'void *externalPrimitiveTable[', (MaxExternalPrimitiveTableSize + 1) printString, ']'.

	self declareCAsOop: {
			#instructionPointer .
			#method .
			#newMethod .
			#activeContext .
			#theHomeContext .
			#stackPointer }
		in: aCCodeGenerator.
		
	aCCodeGenerator
		var: #jmpBuf
		declareC: 'jmp_buf jmpBuf[', (MaxJumpBuf + 1) printString, ']'.
	aCCodeGenerator
		var: #suspendedCallbacks
		declareC: 'sqInt suspendedCallbacks[', (MaxJumpBuf + 1) printString, ']'.
	aCCodeGenerator
		var: #suspendedMethods
		declareC: 'sqInt suspendedMethods[', (MaxJumpBuf + 1) printString, ']'.

	"Reinitialized at interpreter entry by #initializeImageFormatVersion"
	aCCodeGenerator
		var: #imageFormatVersionNumber
		declareC: 'sqInt imageFormatVersionNumber = 0'.
	"Declared here to prevent inclusion in foo struct by CCodeGeneratorGlobalStructure"
	aCCodeGenerator
		var: #imageFormatInitialVersion
		declareC: 'sqInt imageFormatInitialVersion = 0'
! !
!Interpreter class methodsFor: 'initialization' stamp: 'dtl 1/19/2011 19:40'!
initialize
	"Interpreter initialize"

	super initialize.  "initialize ObjectMemory constants"
	self initializeAssociationIndex.
	self initializeBytecodeTable.
	self initializeCaches.
	self initializeCharacterIndex.
	self initializeCharacterScannerIndices.
	self initializeClassIndices.
	self initializeCompilerHooks.
	self initializeContextIndices.
	self initializeDirectoryLookupResultCodes.
	self initializeMessageIndices.
	self initializeMethodIndices.
	self initializePointIndices.
	self initializePrimitiveTable.
	self initializeSchedulerIndices.
	self initializeSmallIntegers.
	self initializeStreamIndices.
	self initializeInterpreterSourceVersion.

	SemaphoresToSignalSize := 500.
	PrimitiveExternalCallIndex := 117. "Primitive index for #primitiveExternalCall"
	MillisecondClockMask := 16r1FFFFFFF.
	"Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)"
	MaxExternalPrimitiveTableSize := 4096. "entries"

	MaxJumpBuf := 32. "max. callback depth"! !
!Interpreter class methodsFor: 'initialization'!
initializeAssociationIndex
	ValueIndex := 1! !
!Interpreter class methodsFor: 'initialization' stamp: 'eem 6/16/2008 10:07'!
initializeBytecodeTable
	"Interpreter initializeBytecodeTable"
	"Note: This table will be used to generate a C switch statement."

	BytecodeTable := Array new: 256.
	self table: BytecodeTable from:
	#(
		(  0  15 pushReceiverVariableBytecode)
		( 16  31 pushTemporaryVariableBytecode)
		( 32  63 pushLiteralConstantBytecode)
		( 64  95 pushLiteralVariableBytecode)
		( 96 103 storeAndPopReceiverVariableBytecode)
		(104 111 storeAndPopTemporaryVariableBytecode)
		(112 pushReceiverBytecode)
		(113 pushConstantTrueBytecode)
		(114 pushConstantFalseBytecode)
		(115 pushConstantNilBytecode)
		(116 pushConstantMinusOneBytecode)
		(117 pushConstantZeroBytecode)
		(118 pushConstantOneBytecode)
		(119 pushConstantTwoBytecode)
		(120 returnReceiver)
		(121 returnTrue)
		(122 returnFalse)
		(123 returnNil)
		(124 returnTopFromMethod)
		(125 returnTopFromBlock)

		(126 127 unknownBytecode)

		(128 extendedPushBytecode)
		(129 extendedStoreBytecode)
		(130 extendedStoreAndPopBytecode)
		(131 singleExtendedSendBytecode)
		(132 doubleExtendedDoAnythingBytecode)
		(133 singleExtendedSuperBytecode)
		(134 secondExtendedSendBytecode)
		(135 popStackBytecode)
		(136 duplicateTopBytecode)

		(137 pushActiveContextBytecode)
		(138 pushNewArrayBytecode)
		(139 unknownBytecode)
		(140 pushRemoteTempLongBytecode)
		(141 storeRemoteTempLongBytecode)
		(142 storeAndPopRemoteTempLongBytecode)
		(143 pushClosureCopyCopiedValuesBytecode)

		(144 151 shortUnconditionalJump)
		(152 159 shortConditionalJump)
		(160 167 longUnconditionalJump)
		(168 171 longJumpIfTrue)
		(172 175 longJumpIfFalse)

		"176-191 were sendArithmeticSelectorBytecode"
		(176 bytecodePrimAdd)
		(177 bytecodePrimSubtract)
		(178 bytecodePrimLessThan)
		(179 bytecodePrimGreaterThan)
		(180 bytecodePrimLessOrEqual)
		(181 bytecodePrimGreaterOrEqual)
		(182 bytecodePrimEqual)
		(183 bytecodePrimNotEqual)
		(184 bytecodePrimMultiply)
		(185 bytecodePrimDivide)
		(186 bytecodePrimMod)
		(187 bytecodePrimMakePoint)
		(188 bytecodePrimBitShift)
		(189 bytecodePrimDiv)
		(190 bytecodePrimBitAnd)
		(191 bytecodePrimBitOr)	

		"192-207 were sendCommonSelectorBytecode"
		(192 bytecodePrimAt)
		(193 bytecodePrimAtPut)
		(194 bytecodePrimSize)
		(195 bytecodePrimNext)
		(196 bytecodePrimNextPut)
		(197 bytecodePrimAtEnd)
		(198 bytecodePrimEquivalent)
		(199 bytecodePrimClass)
		(200 bytecodePrimBlockCopy)
		(201 bytecodePrimValue)
		(202 bytecodePrimValueWithArg)
		(203 bytecodePrimDo)
		(204 bytecodePrimNew)
		(205 bytecodePrimNewWithArg)
		(206 bytecodePrimPointX)
		(207 bytecodePrimPointY)

		(208 255 sendLiteralSelectorBytecode)
	).! !
!Interpreter class methodsFor: 'initialization' stamp: 'tpr 3/17/2005 10:40'!
initializeCaches

	| atCacheEntrySize |
	MethodCacheEntries := 512. 
	MethodCacheSelector := 1.
	MethodCacheClass := 2.
	MethodCacheMethod := 3.
	MethodCachePrim := 4.
	MethodCacheNative := 5.
	MethodCachePrimFunction := 6.
	MethodCacheEntrySize := 8.  "Must be power of two for masking scheme."
	MethodCacheMask := (MethodCacheEntries - 1) * MethodCacheEntrySize.
	MethodCacheSize := MethodCacheEntries * MethodCacheEntrySize.
	CacheProbeMax := 3.

	AtCacheEntries := 8.  "Must be a power of two"
	AtCacheOop := 1.
	AtCacheSize := 2.
	AtCacheFmt := 3.
	AtCacheFixedFields := 4.
	atCacheEntrySize := 4.  "Must be power of two for masking scheme."
	AtCacheMask := (AtCacheEntries-1) * atCacheEntrySize.
	AtPutBase := AtCacheEntries * atCacheEntrySize.
	AtCacheTotalSize := AtCacheEntries * atCacheEntrySize * 2.
! !
!Interpreter class methodsFor: 'initialization'!
initializeCharacterIndex
	CharacterValueIndex := 0! !
!Interpreter class methodsFor: 'initialization' stamp: 'tpr 4/29/2003 12:10'!
initializeCharacterScannerIndices
	CrossedX := 258.
	EndOfRun := 257
! !
!Interpreter class methodsFor: 'initialization'!
initializeClassIndices
	"Class Class"
	SuperclassIndex := 0.
	MessageDictionaryIndex := 1.
	InstanceSpecificationIndex := 2.
	"Fields of a message dictionary"
	MethodArrayIndex := 1.
	SelectorStart := 2! !
!Interpreter class methodsFor: 'initialization' stamp: 'ikp 10/27/2000 14:47'!
initializeCompilerHooks
	"Interpreter initializeCompilerHooks"

	"compilerHooks[] indices:
	1	void compilerTranslateMethodHook(void)
	2	void compilerFlushCacheHook(CompiledMethod *oldMethod)
	3	void compilerPreGCHook(int fullGCFlag)
	4	void compilerMapHook(int memStart, int memEnd)
	5	void compilerPostGCHook(void)
	6	void compilerProcessChangeHook(void)
	7	void compilerPreSnapshotHook(void)
	8	void compilerPostSnapshotHook(void)
	9	void compilerMarkHook(void)
	10	void compilerActivateMethodHook(void)
	11	void compilerNewActiveContextHook(int sendFlag)
	12	void compilerGetInstructionPointerHook(void)
	13	void compilerSetInstructionPointerHook(void)
	14	void compilerCreateActualMessageHook(void)"

	CompilerHooksSize := 15.! !
!Interpreter class methodsFor: 'initialization' stamp: 'eem 9/8/2008 16:32'!
initializeContextIndices
	"Class MethodContext"
	SenderIndex := 0.
	InstructionPointerIndex := 1.
	StackPointerIndex := 2.
	MethodIndex := 3.
	ClosureIndex := 4. "N.B. Called receiverMap in the image."
	ReceiverIndex := 5.
	TempFrameStart := 6.  "Note this is in two places!!"

	"Class BlockContext"
	CallerIndex := 0.
	BlockArgumentCountIndex := 3.
	InitialIPIndex := 4.
	HomeIndex := 5.

	"Class BlockClosure"
	ClosureOuterContextIndex := 0.
	ClosureStartPCIndex := 1.
	ClosureNumArgsIndex := 2.
	ClosureFirstCopiedValueIndex := 3! !
!Interpreter class methodsFor: 'initialization'!
initializeDirectoryLookupResultCodes

	DirEntryFound := 0.
	DirNoMoreEntries := 1.
	DirBadPath := 2.! !
!Interpreter class methodsFor: 'initialization' stamp: 'dtl 4/10/2010 12:19'!
initializeInterpreterSourceVersion
	"Identify the VMMaker source version that generated the C code for an
	interpreter. Provides a runtime version identification test."

	Smalltalk at: #VMMaker
		ifPresent: [:vmm | ^ InterpreterSourceVersion := vmm versionString].
	^ InterpreterSourceVersion := ''! !
!Interpreter class methodsFor: 'initialization' stamp: 'di 3/25/1999 22:09'!
initializeMessageIndices
	MessageSelectorIndex := 0.
	MessageArgumentsIndex := 1.
	MessageLookupClassIndex := 2.! !
!Interpreter class methodsFor: 'initialization'!
initializeMethodIndices
	"Class CompiledMethod"
	HeaderIndex := 0.
	LiteralStart := 1! !
!Interpreter class methodsFor: 'initialization'!
initializePointIndices
	XIndex := 0.
	YIndex := 1! !
!Interpreter class methodsFor: 'initialization' stamp: 'dtl 12/11/2010 13:08'!
initializePrimitiveTable 
	"This table generates a C function address table use in primitiveResponse along with dispatchFunctionPointerOn:in:"

	"NOTE: The real limit here is 2047 because of the method header layout but there is no point in going over the needed size"
	MaxPrimitiveIndex := 575.
	PrimitiveTable := Array new: MaxPrimitiveIndex + 1.
	self table: PrimitiveTable from: 
	#(	"Integer Primitives (0-19)"
		(0 primitiveFail)
		(1 primitiveAdd)
		(2 primitiveSubtract)
		(3 primitiveLessThan)
		(4 primitiveGreaterThan)
		(5 primitiveLessOrEqual)
		(6 primitiveGreaterOrEqual)
		(7 primitiveEqual)
		(8 primitiveNotEqual)
		(9 primitiveMultiply)
		(10 primitiveDivide)
		(11 primitiveMod)
		(12 primitiveDiv)
		(13 primitiveQuo)
		(14 primitiveBitAnd)
		(15 primitiveBitOr)
		(16 primitiveBitXor)
		(17 primitiveBitShift)
		(18 primitiveMakePoint)
		(19 primitiveFail)					"Guard primitive for simulation -- *must* fail"

		"LargeInteger Primitives (20-39)"
		(20 primitiveFail)
		(21 primitiveAddLargeIntegers)
		(22 primitiveSubtractLargeIntegers)
		(23 primitiveLessThanLargeIntegers)
		(24 primitiveGreaterThanLargeIntegers)
		(25 primitiveLessOrEqualLargeIntegers)
		(26 primitiveGreaterOrEqualLargeIntegers)
		(27 primitiveEqualLargeIntegers)
		(28 primitiveNotEqualLargeIntegers)
		(29 primitiveMultiplyLargeIntegers)
		(30 primitiveDivideLargeIntegers)
		(31 primitiveModLargeIntegers)
		(32 primitiveDivLargeIntegers)
		(33 primitiveQuoLargeIntegers)
		(34 primitiveBitAndLargeIntegers)
		(35 primitiveBitOrLargeIntegers)
		(36 primitiveBitXorLargeIntegers)
		(37 primitiveBitShiftLargeIntegers)
		(38 primitiveFail)
		(39 primitiveFail)

		"Float Primitives (40-59)"
		(40 primitiveAsFloat)
		(41 primitiveFloatAdd)
		(42 primitiveFloatSubtract)
		(43 primitiveFloatLessThan)
		(44 primitiveFloatGreaterThan)
		(45 primitiveFloatLessOrEqual)
		(46 primitiveFloatGreaterOrEqual)
		(47 primitiveFloatEqual)
		(48 primitiveFloatNotEqual)
		(49 primitiveFloatMultiply)
		(50 primitiveFloatDivide)
		(51 primitiveTruncated)
		(52 primitiveFractionalPart)
		(53 primitiveExponent)
		(54 primitiveTimesTwoPower)
		(55 primitiveSquareRoot)
		(56 primitiveSine)
		(57 primitiveArctan)
		(58 primitiveLogN)
		(59 primitiveExp)

		"Subscript and Stream Primitives (60-67)"
		(60 primitiveAt)
		(61 primitiveAtPut)
		(62 primitiveSize)
		(63 primitiveStringAt)
		(64 primitiveStringAtPut)
		(65 primitiveFail) "was primitiveNext which no longer pays its way (normal Smalltalk code is faster)"
		(66 primitiveFail) "was primitiveNextPut which no longer pays its way (normal Smalltalk code is faster)"
		(67 primitiveFail) "was primitiveAtEnd which no longer pays its way (normal Smalltalk code is faster)"

		"StorageManagement Primitives (68-79)"
		(68 primitiveObjectAt)
		(69 primitiveObjectAtPut)
		(70 primitiveNew)
		(71 primitiveNewWithArg)
		(72 primitiveArrayBecomeOneWay)	"Blue Book: primitiveBecome"
		(73 primitiveInstVarAt)
		(74 primitiveInstVarAtPut)
		(75 primitiveAsOop)
		(76 primitiveStoreStackp)					"Blue Book: primitiveAsObject"
		(77 primitiveSomeInstance)
		(78 primitiveNextInstance)
		(79 primitiveNewMethod)

		"Control Primitives (80-89)"
		(80 primitiveBlockCopy)
		(81 primitiveValue)
		(82 primitiveValueWithArgs)
		(83 primitivePerform)
		(84 primitivePerformWithArgs)
		(85 primitiveSignal)
		(86 primitiveWait)
		(87 primitiveResume)
		(88 primitiveSuspend)
		(89 primitiveFlushCache)

		"Input/Output Primitives (90-109)"
		(90 primitiveMousePoint)
		(91 primitiveTestDisplayDepth)			"Blue Book: primitiveCursorLocPut"
		(92 primitiveSetDisplayMode)				"Blue Book: primitiveCursorLink"
		(93 primitiveInputSemaphore)
		(94 primitiveGetNextEvent)				"Blue Book: primitiveSampleInterval"
		(95 primitiveInputWord)
		(96 primitiveFail)	"primitiveCopyBits"
		(97 primitiveSnapshot)
		(98 primitiveStoreImageSegment)
		(99 primitiveLoadImageSegment)
		(100 primitivePerformInSuperclass)		"Blue Book: primitiveSignalAtTick"
		(101 primitiveBeCursor)
		(102 primitiveBeDisplay)
		(103 primitiveScanCharacters)
		(104 primitiveFail)	"primitiveDrawLoop"
		(105 primitiveStringReplace)
		(106 primitiveScreenSize)
		(107 primitiveMouseButtons)
		(108 primitiveKbdNext)
		(109 primitiveKbdPeek)

		"System Primitives (110-119)"
		(110 primitiveEquivalent)
		(111 primitiveClass)
		(112 primitiveBytesLeft)
		(113 primitiveQuit)
		(114 primitiveExitToDebugger)
		(115 primitiveChangeClass)					"Blue Book: primitiveOopsLeft"
		(116 primitiveFlushCacheByMethod)
		(117 primitiveExternalCall)
		(118 primitiveDoPrimitiveWithArgs)
		(119 primitiveFlushCacheSelective)
			"Squeak 2.2 and earlier use 119.  Squeak 2.3 and later use 116.
			Both are supported for backward compatibility."

		"Miscellaneous Primitives (120-127)"
		(120 primitiveCalloutToFFI)
		(121 primitiveImageName)
		(122 primitiveNoop)					"Blue Book: primitiveImageVolume"
		(123 primitiveValueUninterruptably)	"@@@: Remove this when all VMs have support"
		(124 primitiveLowSpaceSemaphore)
		(125 primitiveSignalAtBytesLeft)

		"Squeak Primitives Start Here"

		"Squeak Miscellaneous Primitives (128-149)"
		(126 primitiveDeferDisplayUpdates)
		(127 primitiveShowDisplayRect)
		(128 primitiveArrayBecome)
		(129 primitiveSpecialObjectsOop)
		(130 primitiveFullGC)
		(131 primitiveIncrementalGC)
		(132 primitiveObjectPointsTo)
		(133 primitiveSetInterruptKey)
		(134 primitiveInterruptSemaphore)
		(135 primitiveMillisecondClock)
		(136 primitiveSignalAtMilliseconds)
		(137 primitiveSecondsClock)
		(138 primitiveSomeObject)
		(139 primitiveNextObject)
		(140 primitiveBeep)
		(141 primitiveClipboardText)
		(142 primitiveVMPath)
		(143 primitiveShortAt)
		(144 primitiveShortAtPut)
		(145 primitiveConstantFill)
		"NOTE: When removing the obsolete indexed primitives,
		the following two should go become #primitiveIntegerAt / atPut"
		(146 primitiveFail)	"primitiveReadJoystick"
		(147 primitiveFail)	"primitiveWarpBits"
		(148 primitiveClone)
		(149 primitiveGetAttribute)

		"File Primitives (150-169) - NO LONGER INDEXED"
		(150 159 primitiveFail)
		(160 primitiveAdoptInstance)
		(161 164 primitiveFail)
		(165 primitiveIntegerAt)		"hacked in here for now"
		(166 primitiveIntegerAtPut)
		(167 primitiveYield)
		(168 primitiveCopyObject)
		(169 primitiveFail)

		"Sound Primitives (170-199) - NO LONGER INDEXED"
		(170 185 primitiveFail)

		"Old closure primitives"
		(186 primitiveFail) "was primitiveClosureValue"
		(187 primitiveFail) "was primitiveClosureValueWithArgs"

		"Perform method directly"
		(188 primitiveExecuteMethodArgsArray)
		(189 primitiveExecuteMethod)

		"Sound Primitives (continued) - NO LONGER INDEXED"
		(190 194 primitiveFail)

		"Unwind primitives"
		(195 primitiveFindNextUnwindContext)
		(196 primitiveTerminateTo)
		(197 primitiveFindHandlerContext)
		(198 primitiveMarkUnwindMethod)
		(199 primitiveMarkHandlerMethod)

		"new closure primitives (were Networking primitives)"
		(200 primitiveClosureCopyWithCopiedValues)
		(201 primitiveClosureValue) "value"
		(202 primitiveClosureValue) "value:"
		(203 primitiveClosureValue) "value:value:"
		(204 primitiveClosureValue) "value:value:value:"
		(205 primitiveClosureValue) "value:value:value:value:"
		(206 primitiveClosureValueWithArgs) "valueWithArguments:"

		(207 209 primitiveFail) "reserved for Cog primitives"

		(210 primitiveAt)		"Compatibility with Cog StackInterpreter Context primitives"
		(211 primitiveAtPut)	"Compatibility with Cog StackInterpreter Context primitives"
		(212 primitiveSize)	"Compatibility with Cog StackInterpreter Context primitives"
		(213 219 primitiveFail) "reserved for Cog primitives"

		(220 primitiveFail)		"reserved for Cog primitives"

		(221 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch"
		(222 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch:"

		(223 229 primitiveFail)	"reserved for Cog primitives"

		(230 primitiveRelinquishProcessor)
		(231 primitiveForceDisplayUpdate)
		(232 primitiveFormPrint)
		(233 primitiveSetFullScreen)
		(234 primitiveFail) "primBitmapdecompressfromByteArrayat"
		(235 primitiveFail) "primStringcomparewithcollated"
		(236 primitiveFail) "primSampledSoundconvert8bitSignedFromto16Bit"
		(237 primitiveFail) "primBitmapcompresstoByteArray"
		(238 241 primitiveFail) "serial port primitives"
		(242 primitiveFail)
		(243 primitiveFail) "primStringtranslatefromtotable"
		(244 primitiveFail) "primStringfindFirstInStringinSetstartingAt"
		(245 primitiveFail) "primStringindexOfAsciiinStringstartingAt"
		(246 primitiveFail) "primStringfindSubstringinstartingAtmatchTable"
		(247 primitiveSnapshotEmbedded)
		(248 primitiveInvokeObjectAsMethod)
		(249 primitiveArrayBecomeOneWayCopyHash)

		"VM Implementor Primitives (250-255)"
		(250 clearProfile)
		(251 dumpProfile)
		(252 startProfiling)
		(253 stopProfiling)
		(254 primitiveVMParameter)
		(255 primitiveInstVarsPutFromStack) "Never used except in Disney tests.  Remove after 2.3 release."

		"Quick Push Const Methods"
		(256 primitivePushSelf)
		(257 primitivePushTrue)
		(258 primitivePushFalse)
		(259 primitivePushNil)
		(260 primitivePushMinusOne)
		(261 primitivePushZero)
		(262 primitivePushOne)
		(263 primitivePushTwo)

		"Quick Push Const Methods"
		(264 519 primitiveLoadInstVar)

		"These ranges used to be used by obsiolete indexed primitives."
		(520 529 primitiveFail)
		(530 539 primitiveFail)
		(540 549 primitiveFail)
		(550 559 primitiveFail)
		(560 569 primitiveFail)

		"External primitive support primitives"
		(570 primitiveFlushExternalPrimitives)
		(571 primitiveUnloadModule)
		(572 primitiveListBuiltinModule)
		(573 primitiveListExternalModule)
		(574 primitiveFail) "reserved for addl. external support prims"

		"Unassigned Primitives"
		(575 primitiveFail)).
! !
!Interpreter class methodsFor: 'initialization'!
initializeSchedulerIndices
	"Class ProcessorScheduler"
	ProcessListsIndex := 0.
	ActiveProcessIndex := 1.
	"Class LinkedList"
	FirstLinkIndex := 0.
	LastLinkIndex := 1.
	"Class Semaphore"
	ExcessSignalsIndex := 2.
	"Class Link"
	NextLinkIndex := 0.
	"Class Process"
	SuspendedContextIndex := 1.
	PriorityIndex := 2.
	MyListIndex := 3! !
!Interpreter class methodsFor: 'initialization'!
initializeSmallIntegers
	"SmallIntegers"
	ConstMinusOne := Interpreter new integerObjectOf: -1.
	ConstZero := Interpreter new integerObjectOf: 0.
	ConstOne := Interpreter new integerObjectOf: 1.
	ConstTwo := Interpreter new integerObjectOf: 2! !
!Interpreter class methodsFor: 'initialization'!
initializeStreamIndices
	StreamArrayIndex := 0.
	StreamIndexIndex := 1.
	StreamReadLimitIndex := 2.
	StreamWriteLimitIndex := 3.! !
!Interpreter class methodsFor: 'translation' stamp: 'eem 6/19/2008 22:16'!
isNonArgumentImplicitReceiverVariableName: aString
	aString = 'interpreterProxy' ifTrue: [self halt].
	^'self' = aString! !
!Interpreter class methodsFor: 'translation' stamp: 'eem 12/15/2008 18:32'!
isTypePointerToStruct: type "<String>"
	^false! !
!Interpreter class methodsFor: 'initialization' stamp: 'JMM 10/25/2004 16:36'!
obsoleteIndexedPrimitiveTable
	"Interpreter obsoleteIndexedPrimitiveTableString"
	"Initialize the links from the (now obsolete) indexed primitives to
	the new named primitives."
	| table |
	table := Array new: MaxPrimitiveIndex+1.
	#(
		(96	(BitBltPlugin primitiveCopyBits))
		(104 (BitBltPlugin primitiveDrawLoop))
		(147 (BitBltPlugin primitiveWarpBits))

		(146 (JoystickTabletPlugin primitiveReadJoystick))

		"File Primitives (150-169)"
		(150 (FilePlugin primitiveFileAtEnd))
		(151 (FilePlugin primitiveFileClose))
		(152 (FilePlugin primitiveFileGetPosition))
		(153 (FilePlugin primitiveFileOpen))
		(154 (FilePlugin primitiveFileRead))
		(155 (FilePlugin primitiveFileSetPosition))
		(156 (FilePlugin primitiveFileDelete))
		(157 (FilePlugin primitiveFileSize))
		(158 (FilePlugin primitiveFileWrite))
		(159 (FilePlugin primitiveFileRename))
		(160 (FilePlugin primitiveDirectoryCreate))
		(161 (FilePlugin primitiveDirectoryDelimitor))
		(162 (FilePlugin primitiveDirectoryLookup))
		(163 (FilePlugin primitiveDirectoryDelete))
		(164 (FilePlugin primitiveDirectoryGetMacTypeAndCreator))
		(169 (FilePlugin primitiveDirectorySetMacTypeAndCreator))

		"Sound Primitives (170-199)"
		(170 (SoundPlugin primitiveSoundStart))
		(171 (SoundPlugin primitiveSoundStartWithSemaphore))
		(172 (SoundPlugin primitiveSoundStop))
		(173 (SoundPlugin primitiveSoundAvailableSpace))
		(174 (SoundPlugin primitiveSoundPlaySamples))
		(175 (SoundPlugin primitiveSoundPlaySilence))

		(176 (SoundGenerationPlugin primitiveWaveTableSoundMix))
		(177 (SoundGenerationPlugin primitiveFMSoundMix))
		(178 (SoundGenerationPlugin primitivePluckedSoundMix))
		(179 (SoundGenerationPlugin primitiveSampledSoundMix))
		(180 (SoundGenerationPlugin primitiveMixFMSound))
		(181 (SoundGenerationPlugin primitiveMixPluckedSound))
		(182 (SoundGenerationPlugin primitiveOldSampledSoundMix))
		(183 (SoundGenerationPlugin primitiveApplyReverb))
		(184 (SoundGenerationPlugin primitiveMixLoopedSampledSound))
		(185 (SoundGenerationPlugin primitiveMixSampledSound))

		(189 (SoundPlugin primitiveSoundInsertSamples))
		(190 (SoundPlugin primitiveSoundStartRecording))
		(191 (SoundPlugin primitiveSoundStopRecording))
		(192 (SoundPlugin primitiveSoundGetRecordingSampleRate))
		(193 (SoundPlugin primitiveSoundRecordSamples))
		(194 (SoundPlugin primitiveSoundSetRecordLevel))

		"Networking Primitives (200-229)"
		(200 (SocketPlugin primitiveInitializeNetwork))
		(201 (SocketPlugin primitiveResolverStartNameLookup))
		(202 (SocketPlugin primitiveResolverNameLookupResult))
		(203 (SocketPlugin primitiveResolverStartAddressLookup))
		(204 (SocketPlugin primitiveResolverAddressLookupResult))
		(205 (SocketPlugin primitiveResolverAbortLookup))
		(206 (SocketPlugin primitiveResolverLocalAddress))
		(207 (SocketPlugin primitiveResolverStatus))
		(208 (SocketPlugin primitiveResolverError))
		(209 (SocketPlugin primitiveSocketCreate))
		(210 (SocketPlugin primitiveSocketDestroy))
		(211 (SocketPlugin primitiveSocketConnectionStatus))
		(212 (SocketPlugin primitiveSocketError))
		(213 (SocketPlugin primitiveSocketLocalAddress))
		(214 (SocketPlugin primitiveSocketLocalPort))
		(215 (SocketPlugin primitiveSocketRemoteAddress))
		(216 (SocketPlugin primitiveSocketRemotePort))
		(217 (SocketPlugin primitiveSocketConnectToPort))
		(218 (SocketPlugin primitiveSocketListenWithOrWithoutBacklog))
		(219 (SocketPlugin primitiveSocketCloseConnection))
		(220 (SocketPlugin primitiveSocketAbortConnection))
		(221 (SocketPlugin primitiveSocketReceiveDataBufCount))
		(222 (SocketPlugin primitiveSocketReceiveDataAvailable))
		(223 (SocketPlugin primitiveSocketSendDataBufCount))
		(224 (SocketPlugin primitiveSocketSendDone))
		(225 (SocketPlugin primitiveSocketAccept))

		"Other Primitives (230-249)"
		(234 (MiscPrimitivePlugin primitiveDecompressFromByteArray))
		(235 (MiscPrimitivePlugin primitiveCompareString))
		(236 (MiscPrimitivePlugin primitiveConvert8BitSigned))
		(237 (MiscPrimitivePlugin primitiveCompressToByteArray))
		(238 (SerialPlugin primitiveSerialPortOpen))
		(239 (SerialPlugin primitiveSerialPortClose))
		(240 (SerialPlugin primitiveSerialPortWrite))
		(241 (SerialPlugin primitiveSerialPortRead))

		(243 (MiscPrimitivePlugin primitiveTranslateStringWithTable))
		(244 (MiscPrimitivePlugin primitiveFindFirstInString))
		(245 (MiscPrimitivePlugin primitiveIndexOfAsciiInString))
		(246 (MiscPrimitivePlugin primitiveFindSubstring))

		"MIDI Primitives (521-539)"
		(521 (MIDIPlugin primitiveMIDIClosePort))
		(522 (MIDIPlugin primitiveMIDIGetClock))
		(523 (MIDIPlugin primitiveMIDIGetPortCount))
		(524 (MIDIPlugin primitiveMIDIGetPortDirectionality))
		(525 (MIDIPlugin primitiveMIDIGetPortName))
		(526 (MIDIPlugin primitiveMIDIOpenPort))
		(527 (MIDIPlugin primitiveMIDIParameterGetOrSet))
		(528 (MIDIPlugin primitiveMIDIRead))
		(529 (MIDIPlugin primitiveMIDIWrite))

		"Experimental Asynchrous File Primitives"
		(540 (AsynchFilePlugin primitiveAsyncFileClose))
		(541 (AsynchFilePlugin primitiveAsyncFileOpen))
		(542 (AsynchFilePlugin primitiveAsyncFileReadResult))
		(543 (AsynchFilePlugin primitiveAsyncFileReadStart))
		(544 (AsynchFilePlugin primitiveAsyncFileWriteResult))
		(545 (AsynchFilePlugin primitiveAsyncFileWriteStart))

		"Pen Tablet Primitives"
		(548 (JoystickTabletPlugin primitiveGetTabletParameters))
		(549 (JoystickTabletPlugin primitiveReadTablet))

		"Sound Codec Primitives"

		(550 (ADPCMCodecPlugin primitiveDecodeMono))
		(551 (ADPCMCodecPlugin primitiveDecodeStereo))	
		(552 (ADPCMCodecPlugin primitiveEncodeMono))	
		(553 (ADPCMCodecPlugin primitiveEncodeStereo))

	) do:[:spec| table at: spec first+1 put: spec second].
	^table! !
!Interpreter class methodsFor: 'initialization' stamp: 'tpr 3/24/2004 21:26'!
obsoleteIndexedPrimitiveTableString
	"Interpreter obsoleteIndexedPrimitiveTableString"
	"Initialize the links from the (now obsolete) indexed primitives 
	to the new named primitives."
	| table |
	table := self obsoleteIndexedPrimitiveTable.
	^ String streamContents: [:s | 
			s nextPutAll: '{';
				 cr.
			table doWithIndex: [:primSpec :idx | 
					primSpec
						ifNil: [s nextPutAll: '{ NULL, NULL, NULL }']
						ifNotNil: [s nextPutAll: '{ "';
								 nextPutAll: primSpec first;
								 nextPutAll: '", "';
								 nextPutAll: primSpec last;
								 nextPutAll: '", NULL }'].
					idx < table size
						ifTrue: [s nextPut: $,;
								 cr]].
			s cr; nextPutAll: '}']! !
!Interpreter class methodsFor: 'initialization' stamp: 'ar 5/3/2001 13:02'!
obsoleteNamedPrimitiveTable
	"Interpreter obsoleteNamedPrimitiveTableString"
	"Initialize the links from the (now obsolete) named primitives to
	the new named primitives."
	^#(
		(gePrimitiveMergeFillFrom B2DPlugin primitiveMergeFillFrom)
		(gePrimitiveSetClipRect B2DPlugin primitiveSetClipRect)
		(gePrimitiveDoProfileStats B2DPlugin primitiveDoProfileStats)
		(gePrimitiveAddCompressedShape B2DPlugin primitiveAddCompressedShape)
		(gePrimitiveFinishedProcessing B2DPlugin primitiveFinishedProcessing)
		(gePrimitiveGetBezierStats B2DPlugin primitiveGetBezierStats)
		(gePrimitiveSetDepth B2DPlugin primitiveSetDepth)
		(gePrimitiveAbortProcessing B2DPlugin primitiveAbortProcessing)
		(gePrimitiveGetTimes B2DPlugin primitiveGetTimes)
		(gePrimitiveNextActiveEdgeEntry B2DPlugin primitiveNextActiveEdgeEntry)
		(gePrimitiveAddBezier B2DPlugin primitiveAddBezier)
		(gePrimitiveRenderScanline B2DPlugin primitiveRenderScanline)
		(gePrimitiveAddBezierShape B2DPlugin primitiveAddBezierShape)
		(gePrimitiveAddLine B2DPlugin primitiveAddLine)
		(gePrimitiveRenderImage B2DPlugin primitiveRenderImage)
		(gePrimitiveGetAALevel B2DPlugin primitiveGetAALevel)
		(gePrimitiveRegisterExternalEdge B2DPlugin primitiveRegisterExternalEdge)
		(gePrimitiveInitializeBuffer B2DPlugin primitiveInitializeBuffer)
		(gePrimitiveAddRect B2DPlugin primitiveAddRect)
		(gePrimitiveInitializeProcessing B2DPlugin primitiveInitializeProcessing)
		(gePrimitiveAddBitmapFill B2DPlugin primitiveAddBitmapFill)
		(gePrimitiveGetClipRect B2DPlugin primitiveGetClipRect)
		(gePrimitiveGetFailureReason B2DPlugin primitiveGetFailureReason)
		(gePrimitiveNextGlobalEdgeEntry B2DPlugin primitiveNextGlobalEdgeEntry)
		(gePrimitiveNextFillEntry B2DPlugin primitiveNextFillEntry)
		(gePrimitiveSetColorTransform B2DPlugin primitiveSetColorTransform)
		(gePrimitiveDisplaySpanBuffer B2DPlugin primitiveDisplaySpanBuffer)
		(gePrimitiveGetOffset B2DPlugin primitiveGetOffset)
		(gePrimitiveAddPolygon B2DPlugin primitiveAddPolygon)
		(gePrimitiveNeedsFlush B2DPlugin primitiveNeedsFlush)
		(gePrimitiveAddOval B2DPlugin primitiveAddOval)
		(gePrimitiveSetAALevel B2DPlugin primitiveSetAALevel)
		(gePrimitiveCopyBuffer B2DPlugin primitiveCopyBuffer)
		(gePrimitiveAddActiveEdgeEntry B2DPlugin primitiveAddActiveEdgeEntry)
		(gePrimitiveGetCounts B2DPlugin primitiveGetCounts)
		(gePrimitiveSetOffset B2DPlugin primitiveSetOffset)
		(gePrimitiveAddGradientFill B2DPlugin primitiveAddGradientFill)
		(gePrimitiveChangedActiveEdgeEntry B2DPlugin primitiveChangedActiveEdgeEntry)
		(gePrimitiveRegisterExternalFill B2DPlugin primitiveRegisterExternalFill)
		(gePrimitiveGetDepth B2DPlugin primitiveGetDepth)
		(gePrimitiveSetEdgeTransform B2DPlugin primitiveSetEdgeTransform)
		(gePrimitiveNeedsFlushPut B2DPlugin primitiveNeedsFlushPut)

		(primitiveFloatArrayAt FloatArrayPlugin primitiveAt)
		(primitiveFloatArrayMulFloatArray FloatArrayPlugin primitiveMulFloatArray)
		(primitiveFloatArrayAddScalar FloatArrayPlugin primitiveAddScalar)
		(primitiveFloatArrayDivFloatArray FloatArrayPlugin primitiveDivFloatArray)
		(primitiveFloatArrayDivScalar FloatArrayPlugin primitiveDivScalar)
		(primitiveFloatArrayHash FloatArrayPlugin primitiveHashArray)
		(primitiveFloatArrayAtPut FloatArrayPlugin primitiveAtPut)
		(primitiveFloatArrayMulScalar FloatArrayPlugin primitiveMulScalar)
		(primitiveFloatArrayAddFloatArray FloatArrayPlugin primitiveAddFloatArray)
		(primitiveFloatArraySubScalar FloatArrayPlugin primitiveSubScalar)
		(primitiveFloatArraySubFloatArray FloatArrayPlugin primitiveSubFloatArray)
		(primitiveFloatArrayEqual FloatArrayPlugin primitiveEqual)
		(primitiveFloatArrayDotProduct FloatArrayPlugin primitiveDotProduct)

		(m23PrimitiveInvertRectInto Matrix2x3Plugin primitiveInvertRectInto)
		(m23PrimitiveTransformPoint Matrix2x3Plugin primitiveTransformPoint)
		(m23PrimitiveIsPureTranslation Matrix2x3Plugin primitiveIsPureTranslation)
		(m23PrimitiveComposeMatrix Matrix2x3Plugin primitiveComposeMatrix)
		(m23PrimitiveTransformRectInto Matrix2x3Plugin primitiveTransformRectInto)
		(m23PrimitiveIsIdentity Matrix2x3Plugin primitiveIsIdentity)
		(m23PrimitiveInvertPoint Matrix2x3Plugin primitiveInvertPoint)

		(primitiveDeflateBlock ZipPlugin primitiveDeflateBlock)
		(primitiveDeflateUpdateHashTable ZipPlugin primitiveDeflateUpdateHashTable)
		(primitiveUpdateGZipCrc32 ZipPlugin primitiveUpdateGZipCrc32)
		(primitiveInflateDecompressBlock ZipPlugin primitiveInflateDecompressBlock)
		(primitiveZipSendBlock ZipPlugin primitiveZipSendBlock)

		(primitiveFFTTransformData FFTPlugin primitiveFFTTransformData)
		(primitiveFFTScaleData FFTPlugin primitiveFFTScaleData)
		(primitiveFFTPermuteData FFTPlugin primitiveFFTPermuteData)
	)! !
!Interpreter class methodsFor: 'initialization' stamp: 'tpr 3/24/2004 21:27'!
obsoleteNamedPrimitiveTableString
	"Interpreter obsoleteNamedPrimitiveTableString"
	"Initialize the links from the (now obsolete) indexed primitives 
	to the new named primitives."
	| table |
	table := self obsoleteNamedPrimitiveTable.
	^ String streamContents: [:s | 
			s nextPutAll: '{';
				 cr.
			table do: [:primSpec | s nextPutAll: '{ "';
						 nextPutAll: primSpec first;
						 nextPutAll: '", "';
						 nextPutAll: primSpec second;
						 nextPutAll: '", "';
						 nextPutAll: primSpec third;
						 nextPutAll: '" },';
						 cr].
			s nextPutAll: '{ NULL, NULL, NULL }'.
			s cr; nextPutAll: '}']! !
!Interpreter class methodsFor: 'translation' stamp: 'sw 5/23/2001 14:33'!
patchInterp: fileName
	"Interpreter patchInterp: 'Squeak VM PPC'"
	"This will patch out the unneccesary range check (a compare
	 and branch) in the inner interpreter dispatch loop."
	"NOTE: You must edit in the Interpeter file name, and the
	 number of instructions (delta) to count back to find the compare
	 and branch that we want to get rid of."

	| delta f code len remnant i |
	delta := 6.
	f := FileStream fileNamed: fileName.
	f binary.
	code := Bitmap new: (len := f size) // 4.
	f nextInto: code.
	remnant := f next: len - (code size * 4).
	i := 0.
	["Look for a BCTR instruction"
	(i := code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue:
		["Look for a CMPLWI FF, 6 instrs back"
	       ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r280000FF ifTrue:
			["Copy dispatch instrs back over the compare"
			self inform: 'Patching at ', i hex.
			0 to: delta - 2 do: [ :j |
				code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]].
	f position: 0; nextPutAll: code; nextPutAll: remnant.
	f close.
! !
!Interpreter class methodsFor: 'translation' stamp: 'sw 5/23/2001 14:34'!
patchInterpGCCPPC: fileName
	"Interpreter patchInterpGCCPPC: 'Squeak copy 1'"
	"This will patch out the unneccesary range check (a compare
	 and branch) in the inner interpreter dispatch loop. for the PPC version of the GCC compiled
	version of Squeak under MPW"
	"NOTE: You must edit in the Interpeter file name"

	| delta f code len remnant i |
	delta := 7.
	f := FileStream fileNamed: fileName.
	f binary.
	code := Bitmap new: (len := f size) // 4.
	f nextInto: code.
	remnant := f next: len - (code size * 4).
	i := 0.
	["Look for a BCTR instruction"
	(i := code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue:
		["Look for a CMPLWI cr1,rxx,FF, 7 instrs back"
	       ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r288000FF ifTrue:
	       	["Copy dispatch instrs back over the compare"
			self inform: 'Patching at ', i hex.
			0 to: delta - 2 do: [ :j |
				code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]].
	f position: 0; nextPutAll: code; nextPutAll: remnant.
	f close! !
!Interpreter class methodsFor: 'constants'!
primitiveTable

	^ PrimitiveTable! !
!Interpreter class methodsFor: 'initialization' stamp: 'tpr 3/17/2005 11:32'!
primitiveTableString
	"Interpreter initializePrimitiveTable primitiveTableString"
	| table |
	table := self primitiveTable.
	^ String
		streamContents: [:s | 
			s nextPut: ${.
			table
				withIndexDo: [:primSpec :index | s cr; tab;
					nextPutAll: '/* ';
					nextPutAll: (index - 1) printString;
					nextPutAll: '*/ ';
					nextPutAll: '(void *)';
					nextPutAll: primSpec;
					nextPut: $,].
			s cr; nextPutAll: ' 0 }']! !
!Interpreter class methodsFor: 'translation' stamp: 'dtl 3/28/2010 12:44'!
requiredMethodNames
	"return the list of method names that should be retained for export or other support reasons"
	| requiredList |
	requiredList := Set new:400.
	"A number of methods required by VM support code, jitter, specific platforms etc"
	requiredList addAll: #(fullDisplayUpdate interpret printCallStack printAllStacks readImageFromFile:HeapSize:StartingAt: success: readableFormat: getCurrentBytecode characterForAscii: findClassOfMethod:forReceiver: findSelectorOfMethod:forReceiver: loadInitialContext nullCompilerHook primitiveFlushExternalPrimitives setCompilerInitialized: getFullScreenFlag getInterruptCheckCounter getInterruptKeycode getInterruptPending getNextWakeupTick getSavedWindowSize setFullScreenFlag: setInterruptCheckCounter: setInterruptKeycode: setInterruptPending: setNextWakeupTick: setSavedWindowSize: forceInterruptCheck getThisSessionID setMicroSeconds:andOffset:).

	"Nice to actually have all the primitives available"
	requiredList addAll: self primitiveTable.

	"InterpreterProxy is the internal analogue of sqVirtualMachine.c, so make sure to keep all those"
	InterpreterProxy organization categories do: [:cat |
		((cat ~= 'initialize') and: [cat ~= 'private']) ifTrue: [
			requiredList addAll: (InterpreterProxy organization listAtCategoryNamed: cat)]].
	
	^requiredList! !
!Interpreter class methodsFor: 'initialization' stamp: 'tpr 3/24/2004 21:29'!
table: anArray from: specArray 
	"SpecArray is an array of either (index selector) or (index1 
	index2 selector)."
	| contiguous |
	contiguous := 0.
	specArray do: [:spec | 
			(spec at: 1) = contiguous
				ifFalse: [self error: 'Non-contiguous table entry'].
			spec size = 2
				ifTrue: [anArray at: (spec at: 1) + 1
						put: (spec at: 2).
					contiguous := contiguous + 1]
				ifFalse: [(spec at: 1) to: (spec at: 2) do: [:i | anArray at: i + 1 put: (spec at: 3)].
					contiguous := contiguous + ((spec at: 2) - (spec at: 1)) + 1]]! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl 5/19/2010 11:04'!
activateNewClosureMethod: blockClosure
	"Similar to activateNewMethod but for Closure and newMethod."
	| theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |

	DoAssertionChecks ifTrue:
		[self okayOop: blockClosure].
	outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
	DoAssertionChecks ifTrue:
		[self okayOop: outerContext].
	closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
	methodHeader := self headerOf: closureMethod.
	self pushRemappableOop: blockClosure.
	newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"

	"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
	theBlockClosure := self popRemappableOop.
	outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
	numCopied := (self fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."
	where :=  newContext + self baseHeaderSize.
	self longAt: where + (SenderIndex << self shiftForWord)
		put: activeContext.
	self longAt: where + (InstructionPointerIndex << self shiftForWord)
		put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
	self longAt: where + (StackPointerIndex << self shiftForWord)
		put: (self integerObjectOf: argumentCount + numCopied).
	self longAt: where + (MethodIndex << self shiftForWord)
		put: (self fetchPointer: MethodIndex ofObject: outerContext).
	self longAt: where + (ClosureIndex << self shiftForWord)
		put: theBlockClosure.
	self longAt: where + (ReceiverIndex << self shiftForWord)
		put: (self fetchPointer: ReceiverIndex ofObject: outerContext).

	"Copy the arguments..."
	1 to: argumentCount do:
		[:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord)
				put: (self stackValue: argumentCount-i)].

	"Copy the copied values..."
	where := newContext + self baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << self shiftForWord).
	0 to: numCopied - 1 do:
		[:i| self longAt: where + (i << self shiftForWord)
				put: (self fetchPointer: i + ClosureFirstCopiedValueIndex
						  ofObject: theBlockClosure)].

	"The initial instructions in the block nil-out remaining temps."

	self pop: argumentCount + 1.
	self newActiveContext: newContext! !
!Interpreter methodsFor: 'message sending' stamp: 'dtl 5/19/2010 11:04'!
activateNewMethod
	| newContext methodHeader initialIP tempCount nilOop where |

	methodHeader := self headerOf: newMethod.
	newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).

	initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1.
	tempCount := (methodHeader >> 19) bitAnd: 16r3F.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."

	where :=  newContext  + self baseHeaderSize.
	self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
	self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
	self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
	self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
	self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.

	"Copy the receiver and arguments..."
	0 to: argumentCount do:
		[:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self stackValue: argumentCount-i)].

	"clear remaining temps to nil in case it has been recycled"
	nilOop := nilObj.
	argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
		[:i | self longAt: where + (i << self shiftForWord) put: nilOop].

	self pop: argumentCount + 1.
	reclaimableContextCount := reclaimableContextCount + 1.
	self newActiveContext: newContext.! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/24/2004 20:52'!
addLastLink: proc toList: aList 
	"Add the given process to the given linked list and set the 
	backpointer of process to its new list."
	| lastLink |
	(self isEmptyList: aList)
		ifTrue: [self storePointer: FirstLinkIndex ofObject: aList withValue: proc]
		ifFalse: [lastLink := self fetchPointer: LastLinkIndex ofObject: aList.
			self storePointer: NextLinkIndex ofObject: lastLink withValue: proc].
	self storePointer: LastLinkIndex ofObject: aList withValue: proc.
	self storePointer: MyListIndex ofObject: proc withValue: aList! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp (auto pragmas dtl 2010-09-26) 3/26/2005 13:35'!
addNewMethodToCache
	"Add the given entry to the method cache.
	The policy is as follows:
		Look for an empty entry anywhere in the reprobe chain.
		If found, install the new entry there.
		If not found, then install the new entry at the first probe position
			and delete the entries in the rest of the reprobe chain.
		This has two useful purposes:
			If there is active contention over the first slot, the second
				or third will likely be free for reentry after ejection.
			Also, flushing is good when reprobe chains are getting full."
	| probe hash |
	<inline: false>
	self compilerTranslateMethodHook.	"newMethod x lkupClass -> newNativeMethod (may cause GC !!)"
	hash := messageSelector bitXor: lkupClass.  "drop low-order zeros from addresses"

	primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: lkupClass.
	
	0 to: CacheProbeMax-1 do:
		[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
		(methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
			["Found an empty entry -- use it"
			methodCache at: probe + MethodCacheSelector put: messageSelector.
			methodCache at: probe + MethodCacheClass put: lkupClass.
			methodCache at: probe + MethodCacheMethod put: newMethod.
			methodCache at: probe + MethodCachePrim put: primitiveIndex.
			methodCache at: probe + MethodCacheNative put: newNativeMethod.
			methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
			^ nil]].

	"OK, we failed to find an entry -- install at the first slot..."
	probe := hash bitAnd: MethodCacheMask.  "first probe"
	methodCache at: probe + MethodCacheSelector put: messageSelector.
	methodCache at: probe + MethodCacheClass put: lkupClass.
	methodCache at: probe + MethodCacheMethod put: newMethod.
	methodCache at: probe + MethodCachePrim put: primitiveIndex.
	methodCache at: probe + MethodCacheNative put: newNativeMethod.
	methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').

	"...and zap the following entries"
	1 to: CacheProbeMax-1 do:
		[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
		methodCache at: probe + MethodCacheSelector put: 0].
! !
!Interpreter methodsFor: 'plugin support' stamp: 'ikp (auto pragmas 12/08) 6/10/2004 12:26'!
addToExternalPrimitiveTable: functionAddress
	"Add the given function address to the external primitive table and return the index where it's stored. This function doesn't need to be fast since it is only called when an external primitive has been looked up (which takes quite a bit of time itself). So there's nothing specifically complicated here.
	Note: Return index will be one-based (ST convention)"

	<var: #functionAddress declareC: 'void *functionAddress'>

	0 to: MaxExternalPrimitiveTableSize-1 do: [ :i |
		(externalPrimitiveTable at: i) = 0 ifTrue: [
			externalPrimitiveTable at: i put: functionAddress.
			^i+1]].
	"if no space left, return zero so it'll looked up again"
	^0! !
!Interpreter methodsFor: 'debug support'!
allAccessibleObjectsOkay
	"Ensure that all accessible objects in the heap are okay."

	| oop |
	oop := self firstAccessibleObject.
	[oop = nil] whileFalse: [
		self okayFields: oop.
		oop := self accessibleObjectAfter: oop.
	].! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl (auto pragmas dtl 2010-09-26) 10/30/2008 07:13'!
allocateMemory: heapSize minimum: minimumMemory imageFile: fileStream headerSize: headerSize

	"Translate to C function call with (case sensitive) camelCase. The purpose of this
	method is to document the translation.
	The default implementation is sqAllocateMemory(minimumMemory, heapSize). This may
	be redefined to make use of the image file and header size parameters for efficient
	implementation with mmap().
	See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."

	<inline: true>
	<returnTypeC: 'char *'>
	<var: #fileStream type: 'sqImageFile'>
	^ self
		allocateMemory: heapSize
		Minimum: minimumMemory
		ImageFile: fileStream
		HeaderSize: headerSize! !
!Interpreter methodsFor: 'utilities' stamp: 'tpr 3/15/2004 19:35'!
areIntegers: oop1 and: oop2
"Test oop1 and oop2 to make sure both are SmallIntegers."
	^ ((oop1 bitAnd: oop2) bitAnd: 1) ~= 0! !
!Interpreter methodsFor: 'message sending'!
argCount
	^ argumentCount! !
!Interpreter methodsFor: 'compiled methods' stamp: 'ar 10/13/1998 13:50'!
argumentCountOf: methodPointer
	^ ((self headerOf: methodPointer) >> 25) bitAnd: 16r0F! !
!Interpreter methodsFor: 'contexts' stamp: 'tpr 3/24/2004 20:59'!
argumentCountOfBlock: blockPointer

	| localArgCount |
	localArgCount := self fetchPointer: BlockArgumentCountIndex ofObject: blockPointer.
	^self checkedIntegerValueOf: localArgCount! !
!Interpreter methodsFor: 'contexts' stamp: 'eem 6/20/2008 21:49'!
argumentCountOfClosure: closurePointer

	^self quickFetchInteger: ClosureNumArgsIndex ofObject: closurePointer! !
!Interpreter methodsFor: 'compiled methods' stamp: 'eem 6/20/2008 10:12'!
argumentCountOfMethodHeader: header
	^ (header >> 25) bitAnd: 16r0F! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:41'!
arrayValueOf: arrayOop
	"Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
	"Note: May be called by translated primitive code."

	<returnTypeC: 'void *'>
	((self isIntegerObject: arrayOop) not and:
	 [self isWordsOrBytes: arrayOop])
		ifTrue: [^ self pointerForOop: (arrayOop + self baseHeaderSize)].
	self primitiveFail.
! !
!Interpreter methodsFor: 'array primitive support' stamp: '(auto pragmas 12/08) '!
asciiOfCharacter: characterObj  "Returns an integer object"

	<inline: false>
	self assertClassOf: characterObj is: (self splObj: ClassCharacter).
	successFlag
		ifTrue: [^ self fetchPointer: CharacterValueIndex ofObject: characterObj]
		ifFalse: [^ ConstZero]  "in case some code needs an int"! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:02'!
assertClassOf: oop is: classOop
	"Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."

	| ccIndex cl |
	<inline: true>
	(self isIntegerObject: oop)
		ifTrue: [ successFlag := false. ^ nil ].

	ccIndex := ((self baseHeader: oop) >> 12) bitAnd: 16r1F.
	ccIndex = 0
		ifTrue: [ cl := ((self classHeader: oop) bitAnd: self allButTypeMask) ]
		ifFalse: [
			"look up compact class"
			cl := (self fetchPointer: (ccIndex - 1)
					ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))].

	self success: cl = classOop.
! !
!Interpreter methodsFor: 'debug support' stamp: 'dtl 5/18/2010 20:53'!
balancedStack: delta afterPrimitive: primIdx withArgs: nArgs
	"Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)"
	(primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true].
	"81-88 are control primitives after which the stack may look unbalanced"
	successFlag ifTrue:[
		"Successful prim, stack must have exactly nArgs arguments popped off"
		^(stackPointer - activeContext + (nArgs * self bytesPerWord)) = delta
	].
	"Failed prim must leave stack intact"
	^(stackPointer - activeContext) = delta
! !
!Interpreter methodsFor: 'utilities' stamp: 'tpr (auto pragmas 12/08) 3/15/2004 19:44'!
booleanCheat: cond
"cheat the interpreter out of the pleasure of handling the next bytecode IFF it is a jump-on-boolean. Which it is, often enough when the current bytecode is something like bytecodePrimEqual"
	| bytecode offset |
	<inline: true>

	bytecode := self fetchByte.  "assume next bytecode is jumpIfFalse (99%)"
	self internalPop: 2.
	(bytecode < 160 and: [bytecode > 151]) ifTrue: [  "short jumpIfFalse"
		cond
			ifTrue: [^ self fetchNextBytecode]
			ifFalse: [^ self jump: bytecode - 151]].

	bytecode = 172 ifTrue: [  "long jumpIfFalse"
		offset := self fetchByte.
		cond
			ifTrue: [^ self fetchNextBytecode]
			ifFalse: [^ self jump: offset]].

	"not followed by a jumpIfFalse; undo instruction fetch and push boolean result"
	localIP := localIP - 1.
	self fetchNextBytecode.
	cond
		ifTrue: [self internalPush: trueObj]
		ifFalse: [self internalPush: falseObj].
! !
!Interpreter methodsFor: 'utilities' stamp: 'tpr 3/15/2004 19:46'!
booleanValueOf: obj
"convert true and false (Smalltalk) to true or false(C)"
	obj = trueObj ifTrue: [ ^ true ].
	obj = falseObj ifTrue: [ ^ false ].
	successFlag := false.
	^ nil! !
!Interpreter methodsFor: 'array primitive support' stamp: 'dtl 5/19/2010 13:02'!
byteLengthOf: oop
	"Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt."
	| header sz fmt |
	header := self baseHeader: oop.
	(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self allButTypeMask ]
		ifFalse: [ sz := header bitAnd: self sizeMask ].
	fmt := (header >> 8) bitAnd: 16rF.
	fmt < 8
		ifTrue: [ ^ (sz - self baseHeaderSize)]  "words"
		ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3)]  "bytes"! !
!Interpreter methodsFor: 'object format' stamp: 'di 6/14/2004 16:37'!
byteSizeOf: oop
	| slots |
self flag: #Dan.
	(self isIntegerObject: oop) ifTrue:[^0].
	slots := self slotSizeOf: oop.
	(self isBytesNonInt: oop)
		ifTrue:[^slots]
		ifFalse:[^slots * 4]! !
!Interpreter methodsFor: 'image save/restore' stamp: 'di 10/18/1999 16:58'!
byteSwapByteObjects
	"Byte-swap the words of all bytes objects in the image. This returns these objects to their original byte ordering after blindly byte-swapping the entire image."

	self byteSwapByteObjectsFrom: self firstObject to: endOfMemory! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 5/18/2010 21:42'!
byteSwapByteObjectsFrom: startOop to: stopAddr 
	"Byte-swap the words of all bytes objects in a range of the 
	image, including Strings, ByteArrays, and CompiledMethods. 
	This returns these objects to their original byte ordering 
	after blindly byte-swapping the entire image. For compiled 
	methods, byte-swap only their bytecodes part."
	| oop fmt wordAddr methodHeader |
	oop := startOop.
	[self oop: oop isLessThan: stopAddr]
		whileTrue: [(self isFreeObject: oop)
				ifFalse: [fmt := self formatOf: oop.
					fmt >= 8
						ifTrue: ["oop contains bytes"
							wordAddr := oop + self baseHeaderSize.
							fmt >= 12
								ifTrue: ["compiled method; start after methodHeader and literals"
									methodHeader := self longAt: oop + self baseHeaderSize.
									wordAddr := wordAddr + self bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * self bytesPerWord)].
							self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)].
					(fmt = 6 and: [self bytesPerWord = 8])
						ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words."
							wordAddr := oop + self baseHeaderSize.
							self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]].
			oop := self objectAfter: oop]! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:33'!
byteSwapped: w
	"Answer the given integer with its bytes in the reverse order."

	<inline: true>
	self isDefinedTrueExpression: 'BYTES_PER_WORD == 4'
		inSmalltalk: [self bytesPerWord = 4]
		comment: 'swap bytes in an object word'
		ifTrue:
			[^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask)
			 + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask)
			 + ((w bitShift: Byte1Shift         ) bitAnd: Byte2Mask)
			 + ((w bitShift: Byte3Shift         ) bitAnd: Byte3Mask)]
		ifFalse:
			[^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask)
			 + ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask)
			 + ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask)
			 + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask)
			 + ((w bitShift: Byte1Shift         ) bitAnd: Byte4Mask)
			 + ((w bitShift: Byte3Shift         ) bitAnd: Byte5Mask)
			 + ((w bitShift: Byte5Shift         ) bitAnd: Byte6Mask)
			 + ((w bitShift: Byte7Shift         ) bitAnd: Byte7Mask)]! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/23/2004 18:23'!
bytecodePrimAdd
	| rcvr arg result |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [result := (self integerValueOf: rcvr) + (self integerValueOf: arg).
				(self isIntegerValue: result) ifTrue:
					[self internalPop: 2 thenPush: (self integerObjectOf: result).
					^ self fetchNextBytecode "success"]]
		ifFalse: [successFlag := true.
				self externalizeIPandSP.
				self primitiveFloatAdd: rcvr toArg: arg.
				self internalizeIPandSP.
				successFlag ifTrue: [^ self fetchNextBytecode "success"]].

	messageSelector := self specialSelector: 0.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/23/2004 18:24'!
bytecodePrimAt
	"BytecodePrimAt will only succeed if the receiver is in the atCache.
	Otherwise it will fail so that the more general primitiveAt will put it in the
	cache after validating that message lookup results in a primitive response."
	| index rcvr result atIx |
	index := self internalStackTop.
	rcvr := self internalStackValue: 1.
	successFlag := (self isIntegerObject: rcvr) not and: [self isIntegerObject: index].
	successFlag ifTrue:
		[atIx := rcvr bitAnd: AtCacheMask.  "Index into atCache = 4N, for N = 0 ... 7"
		(atCache at: atIx+AtCacheOop) = rcvr
		ifTrue: [result := self commonVariableInternal: rcvr at: (self integerValueOf: index) cacheIndex: atIx.
			successFlag ifTrue:
				[self fetchNextBytecode.
				^self internalPop: 2 thenPush: result]]].

	messageSelector := self specialSelector: 16.
	argumentCount := 1.
	self normalSend.
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'!
bytecodePrimAtEnd
	messageSelector := self specialSelector: 21.
	argumentCount := 0.
	self normalSend.! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/23/2004 18:25'!
bytecodePrimAtPut
	"BytecodePrimAtPut will only succeed if the receiver is in the atCache.
	Otherwise it will fail so that the more general primitiveAtPut will put it in the
	cache after validating that message lookup results in a primitive response."
	| index rcvr atIx value |
	value := self internalStackTop.
	index := self internalStackValue: 1.
	rcvr := self internalStackValue: 2.
	successFlag := (self isIntegerObject: rcvr) not and: [self isIntegerObject: index].
	successFlag
		ifTrue: [atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase.  "Index into atPutCache"
			(atCache at: atIx+AtCacheOop) = rcvr
				ifTrue: [self commonVariable: rcvr at: (self integerValueOf: index) put: value cacheIndex: atIx.
					successFlag ifTrue: [self fetchNextBytecode.
						^self internalPop: 3 thenPush: value]]].

	messageSelector := self specialSelector: 17.
	argumentCount := 2.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'!
bytecodePrimBitAnd

	successFlag := true.
	self externalizeIPandSP.
	self primitiveBitAnd.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 14.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'!
bytecodePrimBitOr

	successFlag := true.
	self externalizeIPandSP.
	self primitiveBitOr.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 15.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'!
bytecodePrimBitShift

	successFlag := true.
	self externalizeIPandSP.
	self primitiveBitShift.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 12.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/23/2004 18:26'!
bytecodePrimBlockCopy

	| rcvr hdr |
	rcvr := self internalStackValue: 1.
	successFlag := true.
	hdr := self baseHeader: rcvr.
	self success: (self isContextHeader: hdr).
	successFlag ifTrue: [self externalizeIPandSP.
		self primitiveBlockCopy.
		self internalizeIPandSP].
	successFlag ifFalse: [messageSelector := self specialSelector: 24.
		argumentCount := 1.
		^ self normalSend].
	self fetchNextBytecode.
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'di 1/11/1999 00:09'!
bytecodePrimClass
	| rcvr |
	rcvr := self internalStackTop.
	self internalPop: 1 thenPush: (self fetchClassOf: rcvr).
	self fetchNextBytecode.
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:26'!
bytecodePrimDiv
	| quotient |
	successFlag := true.
	quotient := self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0).
	successFlag ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: quotient).
		^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 13.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:27'!
bytecodePrimDivide
	| rcvr arg result |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [rcvr := self integerValueOf: rcvr.
			arg := self integerValueOf: arg.
			(arg ~= 0 and: [rcvr \\ arg = 0])
				ifTrue: [result := rcvr // arg.
					"generates C / operation"
					(self isIntegerValue: result)
						ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result).
							^ self fetchNextBytecode"success"]]]
		ifFalse: [successFlag := true.
			self externalizeIPandSP.
			self primitiveFloatDivide: rcvr byArg: arg.
			self internalizeIPandSP.
			successFlag ifTrue: [^ self fetchNextBytecode"success"]].

	messageSelector := self specialSelector: 9.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends'!
bytecodePrimDo

	messageSelector := self specialSelector: 27.
	argumentCount := 1.
	self normalSend.
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:28'!
bytecodePrimEqual
	| rcvr arg aBool |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr = arg].

	successFlag := true.
	aBool := self primitiveFloatEqual: rcvr toArg: arg.
	successFlag ifTrue: [^self booleanCheat: aBool].

	messageSelector := self specialSelector: 6.
	argumentCount := 1.
	self normalSend
! !
!Interpreter methodsFor: 'common selector sends'!
bytecodePrimEquivalent

	| rcvr arg |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	self booleanCheat: rcvr = arg.! !
!Interpreter methodsFor: 'common selector sends' stamp: 'eem 9/18/2010 11:41'!
bytecodePrimGreaterOrEqual
	| rcvr arg aBool |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) >= (self integerValueOf: arg)].
		^self booleanCheat: rcvr >= arg].

	successFlag := true.
	aBool := self primitiveFloatGreaterOrEqual: rcvr toArg: arg.
	successFlag ifTrue: [^self booleanCheat: aBool].

	messageSelector := self specialSelector: 5.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:29'!
bytecodePrimGreaterThan
	| rcvr arg aBool |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) > (self integerValueOf: arg)].
		^self booleanCheat: rcvr > arg].

	successFlag := true.
	aBool := self primitiveFloatGreater: rcvr thanArg: arg.
	successFlag ifTrue: [^self booleanCheat: aBool].

	messageSelector := self specialSelector: 3.
	argumentCount := 1.
	self normalSend
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'eem 9/18/2010 11:41'!
bytecodePrimLessOrEqual
	| rcvr arg aBool |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) <= (self integerValueOf: arg)].
		^ self booleanCheat: rcvr <= arg].

	successFlag := true.
	aBool := self primitiveFloatLessOrEqual: rcvr toArg: arg.
	successFlag ifTrue: [^self booleanCheat: aBool].

	messageSelector := self specialSelector: 4.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:30'!
bytecodePrimLessThan
	| rcvr arg aBool |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) < (self integerValueOf: arg)].
		^ self booleanCheat: rcvr < arg].

	successFlag := true.
	aBool := self primitiveFloatLess: rcvr thanArg: arg.
	successFlag ifTrue: [^ self booleanCheat: aBool].

	messageSelector := self specialSelector: 2.
	argumentCount := 1.
	self normalSend
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:31'!
bytecodePrimMakePoint

	successFlag := true.
	self externalizeIPandSP.
	self primitiveMakePoint.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 11.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:31'!
bytecodePrimMod
	| mod |
	successFlag := true.
	mod := self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0).
	successFlag ifTrue:
		[self internalPop: 2 thenPush: (self integerObjectOf: mod).
		^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 10.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:31'!
bytecodePrimMultiply
	| rcvr arg result |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [rcvr := self integerValueOf: rcvr.
				arg := self integerValueOf: arg.
				result := rcvr * arg.
				((arg = 0 or: [(result // arg) = rcvr]) and: [self isIntegerValue: result])
					ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result).
							^ self fetchNextBytecode "success"]]
		ifFalse: [successFlag := true.
				self externalizeIPandSP.
				self primitiveFloatMultiply: rcvr byArg: arg.
				self internalizeIPandSP.
				successFlag ifTrue: [^ self fetchNextBytecode "success"]].

	messageSelector := self specialSelector: 8.
	argumentCount := 1.
	self normalSend.
! !
!Interpreter methodsFor: 'common selector sends'!
bytecodePrimNew

	messageSelector := self specialSelector: 28.
	argumentCount := 0.
	self normalSend.
! !
!Interpreter methodsFor: 'common selector sends'!
bytecodePrimNewWithArg

	messageSelector := self specialSelector: 29.
	argumentCount := 1.
	self normalSend.
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'!
bytecodePrimNext
	messageSelector := self specialSelector: 19.
	argumentCount := 0.
	self normalSend.! !
!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 10:12'!
bytecodePrimNextPut
	messageSelector := self specialSelector: 20.
	argumentCount := 1.
	self normalSend.! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:32'!
bytecodePrimNotEqual
	| rcvr arg aBool |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr ~= arg].

	successFlag := true.
	aBool := self primitiveFloatEqual: rcvr toArg: arg.
	successFlag ifTrue: [^self booleanCheat: aBool not].

	messageSelector := self specialSelector: 7.
	argumentCount := 1.
	self normalSend
! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 2/11/2004 20:33'!
bytecodePrimPointX

	| rcvr |
	successFlag := true.
	rcvr := self internalStackTop.
	self assertClassOf: rcvr is: (self splObj: ClassPoint).
	successFlag
		ifTrue: [self internalPop: 1 thenPush: (self fetchPointer: XIndex ofObject: rcvr).
			^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 30.
	argumentCount := 0.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 2/11/2004 20:34'!
bytecodePrimPointY

	| rcvr |
	successFlag := true.
	rcvr := self internalStackTop.
	self assertClassOf: rcvr is: (self splObj: ClassPoint).
	successFlag
		ifTrue: [self internalPop: 1 thenPush: (self fetchPointer: YIndex ofObject: rcvr).
			^ self fetchNextBytecode "success"].

	messageSelector := self specialSelector: 31.
	argumentCount := 0.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'di 12/11/1998 10:22'!
bytecodePrimSize
	messageSelector := self specialSelector: 18.
	argumentCount := 0.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'tpr 3/24/2004 18:32'!
bytecodePrimSubtract
	| rcvr arg result |
	rcvr := self internalStackValue: 1.
	arg := self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [result := (self integerValueOf: rcvr) - (self integerValueOf: arg).
				(self isIntegerValue: result) ifTrue:
					[self internalPop: 2 thenPush: (self integerObjectOf: result).
					^self fetchNextBytecode "success"]]
		ifFalse: [successFlag := true.
				self externalizeIPandSP.
				self primitiveFloatSubtract: rcvr fromArg: arg.
				self internalizeIPandSP.
				successFlag ifTrue: [^self fetchNextBytecode "success"]].

	messageSelector := self specialSelector: 1.
	argumentCount := 1.
	self normalSend! !
!Interpreter methodsFor: 'common selector sends' stamp: 'eem 8/22/2008 15:20'!
bytecodePrimValue
	"In-line value for BlockClosure and BlockContext"
	| maybeBlock rcvrClass |
	maybeBlock := self internalStackTop.
	argumentCount := 0.
	successFlag := true.
	(self isNonIntegerObject: maybeBlock) ifTrue:
		[rcvrClass := self fetchClassOfNonInt: maybeBlock.
		 rcvrClass = (self splObj: ClassBlockClosure)
			ifTrue:
				[self externalizeIPandSP.
				 self primitiveClosureValue.
				 self internalizeIPandSP]
			ifFalse:
				[rcvrClass = (self splObj: ClassBlockContext)
					ifTrue:
						[self externalizeIPandSP.
						 self primitiveValue.
						 self internalizeIPandSP]
					ifFalse:
						[successFlag := false]]].
	successFlag ifFalse:
		[messageSelector := self specialSelector: 25.
		 ^self normalSend].
	self fetchNextBytecode! !
!Interpreter methodsFor: 'common selector sends' stamp: 'eem 8/22/2008 15:37'!
bytecodePrimValueWithArg
	"In-line value: for BlockClosure and BlockContext"
	| maybeBlock rcvrClass |
	maybeBlock := self internalStackValue: 1.
	argumentCount := 1.
	successFlag := true.
	(self isNonIntegerObject: maybeBlock) ifTrue:
		[rcvrClass := self fetchClassOfNonInt: maybeBlock.
		 rcvrClass = (self splObj: ClassBlockClosure)
			ifTrue:
				[self externalizeIPandSP.
				 self primitiveClosureValue.
				 self internalizeIPandSP]
			ifFalse:
				[rcvrClass = (self splObj: ClassBlockContext)
					ifTrue:
						[self externalizeIPandSP.
						 self primitiveValue.
						 self internalizeIPandSP]
					ifFalse:
						[successFlag := false]]].
	successFlag ifFalse:
		[messageSelector := self specialSelector: 26.
		 ^self normalSend].
	self fetchNextBytecode! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'tpr (auto pragmas 12/08) 5/12/2005 22:48'!
callExternalPrimitive: functionID
	"Call the external plugin function identified. In the VM this is an address, see 	InterpreterSimulator for it's version. "

	<var: #functionID type: 'void *'>
	self dispatchFunctionPointer: functionID! !
!Interpreter methodsFor: 'interpreter shell' stamp: 'dtl (auto pragmas dtl 2010-09-26) 9/29/2009 22:23'!
callInterpreter
	"External call into the interpreter"

	<inline: false>
	<export: true>
	self interpret.! !
!Interpreter methodsFor: 'callback support' stamp: 'ar (auto pragmas 12/08) 1/16/2007 11:47'!
callbackEnter: callbackID
	"Re-enter the interpreter for executing a callback"
	| result activeProc |
	<export: true>
	<var: #callbackID declareC: 'sqInt *callbackID'>

	"For now, do not allow a callback unless we're in a primitiveResponse"
	primitiveIndex = 0 ifTrue:[^false].

	"Check if we've exceeded the callback depth"
	jmpDepth >= jmpMax ifTrue:[^false].
	jmpDepth := jmpDepth + 1.

	"Suspend the currently active process"
	activeProc := self fetchPointer: ActiveProcessIndex
						 ofObject: self schedulerPointer.
	suspendedCallbacks at: jmpDepth put: activeProc.
	"We need to preserve newMethod explicitly since it is not activated yet
	and therefore no context has been created for it. If the caller primitive
	for any reason decides to fail we need to make sure we execute the correct
	method and not the one 'last used' in the call back"
	suspendedMethods at: jmpDepth put: newMethod.
	self transferTo: self wakeHighestPriority.

	"Typically, invoking the callback means that some semaphore has been 
	signaled to indicate the callback. Force an interrupt check right away."
	self forceInterruptCheck.

	result := self setjmp: (jmpBuf at: jmpDepth).
	result == 0 ifTrue:["Fill in callbackID"
		callbackID at: 0 put: jmpDepth.
		"This is ugly but the inliner treats interpret() in very special and strange ways and calling any kind of 'self interpret' either directly or even via cCode:inSmalltalk: will cause this entire method to vanish."
		self cCode: 'interpret()'.
	].

	"Transfer back to the previous process so that caller can push result"
	activeProc := self fetchPointer: ActiveProcessIndex
						 ofObject: self schedulerPointer.
	self putToSleep: activeProc.
	activeProc := suspendedCallbacks at: jmpDepth.
	newMethod := suspendedMethods at: jmpDepth.	"see comment above"
	self transferTo: activeProc.
	jmpDepth := jmpDepth-1.
	^true! !
!Interpreter methodsFor: 'callback support' stamp: 'ar (auto pragmas dtl 2010-09-26) 8/30/2006 11:26'!
callbackLeave: cbID
	"Leave from a previous callback"
	<export: true>

	"For now, do not allow a callback unless we're in a primitiveResponse"
	primitiveIndex = 0 ifTrue:[^false].

	"Check if this is the top-level callback"
	cbID = jmpDepth ifFalse:[^false].
	cbID < 1 ifTrue:[^false].
	"This is ugly but necessary, or otherwise the Mac will not build"
	self long: (jmpBuf at: jmpDepth) jmp: 1.
! !
!Interpreter methodsFor: 'contexts' stamp: 'tpr 3/24/2004 20:59'!
caller
	^self fetchPointer: CallerIndex ofObject: activeContext! !
!Interpreter methodsFor: 'debug support' stamp: 'JMM 11/11/2004 11:06'!
capturePendingFinalizationSignals
	statpendingFinalizationSignals := pendingFinalizationSignals.
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'dtl 5/19/2010 11:40'!
changeClassOf: rcvr to: argClass
	"Change the class of the receiver into the class specified by the argument given that the format of the receiver matches the format of the argument. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
	| classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex |
	"Check what the format of the class says"
	classHdr := self formatOfClass: argClass. "Low 2 bits are 0"

	"Compute the size of instances of the class (used for fixed field classes only)"
	sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
	classHdr := classHdr bitAnd: 16r1FFFF.
	byteSize := (classHdr bitAnd: self sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"

	"Check the receiver's format against that of the class"
	argFormat := (classHdr >> 8) bitAnd: 16rF.
	rcvrFormat := self formatOf: rcvr.
	argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way"

	"For fixed field classes, the sizes must match.
	Note: byteSize-4 because base header is included in class size."
	argFormat < 2 ifTrue:[(byteSize - self baseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].

	(self headerType: rcvr) = HeaderTypeShort
		ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex"
			ccIndex := classHdr bitAnd: CompactClassMask.
			ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact"
			self longAt: rcvr put:
				(((self longAt: rcvr) bitAnd: CompactClassMask bitInvert32)
					bitOr: ccIndex)]
		ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass"
			self longAt: rcvr - self baseHeaderSize put: (argClass bitOr: (self headerType: rcvr)).
			(self oop: rcvr isLessThan: youngStart)
				ifTrue: [self possibleRootStoreInto: rcvr value: argClass]].

	"Flush cache because rcvr's class has changed"
	self flushMethodCache.
! !
!Interpreter methodsFor: 'array primitive support' stamp: 'di (auto pragmas 12/08) 12/10/1998 14:53'!
characterForAscii: ascii  "Arg must lie in range 0-255!!"
	<inline: true>
	^ self fetchPointer: ascii ofObject: (self splObj: CharacterTable)! !
!Interpreter methodsFor: 'arithmetic primitive support' stamp: 'di 11/27/1998 15:38'!
checkBooleanResult: result
	successFlag
		ifTrue: [self pushBool: result]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr (auto pragmas dtl 2010-09-26) 3/22/2004 14:21'!
checkForInterrupts
	"Check for possible interrupts and handle one if necessary."
	| sema now |
	<inline: false>

	"Mask so same wrapping as primitiveMillisecondClock"
	now := self ioMSecs bitAnd: MillisecondClockMask.

	self interruptCheckForced ifFalse: [
		"don't play with the feedback if we forced a check. It only makes life difficult"
		now - lastTick < interruptChecksEveryNms
			ifTrue: ["wrapping is not a concern, it'll get caught quickly  
				enough. This clause is trying to keep a reasonable  
				guess of how many times per 	interruptChecksEveryNms we are calling  
				quickCheckForInterrupts. Not sure how effective it really is."
				interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset + 10]
			ifFalse: [interruptCheckCounterFeedBackReset <= 1000
					ifTrue: [interruptCheckCounterFeedBackReset := 1000]
					ifFalse: [interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset - 12]]].

	"reset the interrupt check counter"
	interruptCheckCounter := interruptCheckCounterFeedBackReset.

	signalLowSpace
		ifTrue: [signalLowSpace := false. "reset flag"
			sema := self splObj: TheLowSpaceSemaphore.
			sema = nilObj ifFalse: [self synchronousSignal: sema]].

	now < lastTick
		ifTrue: ["millisecond clock wrapped so correct the nextPollTick"
			nextPollTick := nextPollTick - MillisecondClockMask - 1].
	now >= nextPollTick
		ifTrue: [self ioProcessEvents.
			"sets interruptPending if interrupt key pressed"
			nextPollTick := now + 200
			"msecs to wait before next call to ioProcessEvents.  
			Note that strictly speaking we might need to update  
			'now' at this point since ioProcessEvents could take a  
			very long time on some platforms"].
	interruptPending
		ifTrue: [interruptPending := false.
			"reset interrupt flag"
			sema := self splObj: TheInterruptSemaphore.
			sema = nilObj
				ifFalse: [self synchronousSignal: sema]].

	nextWakeupTick ~= 0
		ifTrue: [now < lastTick
				ifTrue: ["the clock has wrapped. Subtract the wrap  
					interval from nextWakeupTick - this might just  
					possibly result in 0. Since this is used as a flag  
					value for 'no timer' we do the 0 check above"
					nextWakeupTick := nextWakeupTick - MillisecondClockMask - 1].
			now >= nextWakeupTick
				ifTrue: [nextWakeupTick := 0.
					"set timer interrupt to 0 for 'no timer'"
					sema := self splObj: TheTimerSemaphore.
					sema = nilObj ifFalse: [self synchronousSignal: sema]]].

	"signal any pending finalizations"
	pendingFinalizationSignals > 0
		ifTrue: [sema := self splObj: TheFinalizationSemaphore.
			(self fetchClassOf: sema) = (self splObj: ClassSemaphore)
				ifTrue: [self synchronousSignal: sema].
			pendingFinalizationSignals := 0].

	"signal all semaphores in semaphoresToSignal"
	(semaphoresToSignalCountA > 0 or: [semaphoresToSignalCountB > 0])
		ifTrue: [self signalExternalSemaphores].

	"update the tracking value"
	lastTick := now! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 10/3/2010 10:40'!
checkImageVersionFrom: f startingAt: imageOffset
	"Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number."
	"This code is based on C code by Ian Piumarta."

	| firstVersion |
	<var: #f type: 'sqImageFile '>
	<var: #imageOffset type: 'squeakFileOffsetType '>

	"check the version number"
	self sqImageFile: f Seek: imageOffset.
	imageFormatInitialVersion := firstVersion := self getLongFromFile: f swap: false.
	(self readableFormat: imageFormatInitialVersion) ifTrue: [^ false].

	"try with bytes reversed"
	self sqImageFile: f Seek: imageOffset.
	imageFormatInitialVersion := self getLongFromFile: f swap: true.
	(self readableFormat: imageFormatInitialVersion) ifTrue: [^ true].

	"Note: The following is only meaningful if not reading an embedded image"
	imageOffset = 0 ifTrue:[
		"try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)"
		self sqImageFile: f Seek: 512.
		imageFormatInitialVersion := self getLongFromFile: f swap: false.
		(self readableFormat: imageFormatInitialVersion) ifTrue: [^ false].

		"try skipping the first 512 bytes with bytes reversed"
		self sqImageFile: f Seek: 512.
		imageFormatInitialVersion := self getLongFromFile: f swap: true.
		(self readableFormat: imageFormatInitialVersion) ifTrue: [^ true]].

	"hard failure; abort"
	self print: 'This interpreter (vers. '.
	self printNum: self imageFormatVersion.
	self print: ') cannot read image file (vers. '.
	self printNum: firstVersion.
	self print: ').'.
	self cr.
	self print: 'Press CR to quit...'.
	self getchar.
	self ioExit.
! !
!Interpreter methodsFor: 'arithmetic primitive support' stamp: 'di 11/27/1998 15:26'!
checkIntegerResult: integerResult
	(successFlag and: [self isIntegerValue: integerResult])
		ifTrue: [self pushInteger: integerResult]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'utilities'!
checkedIntegerValueOf: intOop
	"Note: May be called by translated primitive code."

	(self isIntegerObject: intOop)
		ifTrue: [ ^ self integerValueOf: intOop ]
		ifFalse: [ self primitiveFail. ^ 0 ]! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:23'!
classNameOf: aClass Is: className 
	"Check if aClass's name is className"
	| srcName name length |
	<var: #className type: 'char *'>
	<var: #srcName type: 'char *'>
	(self lengthOf: aClass) <= 6 ifTrue: [^ false].

	"Not a class but might be behavior"
	name := self fetchPointer: 6 ofObject: aClass.
	(self isBytes: name) ifFalse: [^ false].
	length := self stSizeOf: name.
	srcName := self cCoerce: (self arrayValueOf: name) to: 'char *'.
	0 to: length - 1 do: [:i | (srcName at: i) = (className at: i) ifFalse: [^ false]].
	"Check if className really ends at this point"
	^ (className at: length) = 0! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:42'!
closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
	| newClosure |
	<inline: true>
	newClosure := self
					instantiateSmallClass: (self splObj: ClassBlockClosure)
					sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
	"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
	self storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (self integerObjectOf: initialIP).
	self storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (self integerObjectOf: numArgs).
	"It is up to the caller to store the outer context and copiedValues."
	^newClosure! !
!Interpreter methodsFor: 'array primitive support' stamp: 'tpr 3/15/2004 20:23'!
commonAt: stringy
	"This code is called if the receiver responds primitively to at:.
	If this is so, it will be installed in the atCache so that subsequent calls of at:
	or next may be handled immediately in bytecode primitive routines."
	| index rcvr atIx result |
	index := self positive32BitValueOf: (self stackTop).  "Sets successFlag"
	rcvr := self stackValue: 1.
	successFlag & (self isIntegerObject: rcvr) not
		ifFalse: [^ self primitiveFail].

	"NOTE:  The at-cache, since it is specific to the non-super response to #at:.
	Therefore we must determine that the message is #at: (not, eg, #basicAt:),
	and that the send is not a super-send, before using the at-cache."
	(messageSelector = (self specialSelector: 16)
		and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
		ifTrue:
		["OK -- look in the at-cache"
		atIx := rcvr bitAnd: AtCacheMask.  "Index into atCache = 4N, for N = 0 ... 7"
		(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
			["Rcvr not in cache.  Install it..."
			self install: rcvr inAtCache: atCache at: atIx string: stringy].
		successFlag ifTrue:
			[result := self commonVariable: rcvr at: index cacheIndex: atIx].
		successFlag ifTrue:
			[^ self pop: argumentCount+1 thenPush: result]].

	"The slow but sure way..."
	successFlag := true.
	result := self stObject: rcvr at: index.
	successFlag ifTrue:
		[stringy ifTrue: [result := self characterForAscii: (self integerValueOf: result)].
		^ self pop: argumentCount+1 thenPush: result]! !
!Interpreter methodsFor: 'array primitive support' stamp: 'tpr 3/15/2004 20:24'!
commonAtPut: stringy
	"This code is called if the receiver responds primitively to at:Put:.
	If this is so, it will be installed in the atPutCache so that subsequent calls of at:
	or  next may be handled immediately in bytecode primitive routines."
	| value index rcvr atIx |
	value := self stackTop.
	index := self positive32BitValueOf: (self stackValue: 1).  "Sets successFlag"
	rcvr := self stackValue: 2.
	successFlag & (self isIntegerObject: rcvr) not
		ifFalse: [^ self primitiveFail].

	"NOTE:  The atPut-cache, since it is specific to the non-super response to #at:Put:.
	Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
	and that the send is not a super-send, before using the at-cache."
	(messageSelector = (self specialSelector: 17)
		and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
		ifTrue:
		["OK -- look in the at-cache"
		atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase.  "Index into atPutCache"
		(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
			["Rcvr not in cache.  Install it..."
			self install: rcvr inAtCache: atCache at: atIx string: stringy].
		successFlag ifTrue:
			[self commonVariable: rcvr at: index put: value cacheIndex: atIx].
		successFlag ifTrue:
			[^ self pop: argumentCount+1 thenPush: value]].

	"The slow but sure way..."
	successFlag := true.
	stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
			ifFalse: [self stObject: rcvr at: index put: value].
	successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: value].
! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/23/2007 09:01'!
commonReturn
	"Note: Assumed to be inlined into the dispatch loop."

	| nilOop thisCntx contextOfCaller localCntx localVal unwindMarked |
	<inline: true>
	self sharedCodeNamed: 'commonReturn' inCase: 120.

	nilOop := nilObj. "keep in a register"
	thisCntx := activeContext.
	localCntx := localReturnContext.
	localVal := localReturnValue.

	"make sure we can return to the given context"
	((localCntx = nilOop) or:
	 [(self fetchPointer: InstructionPointerIndex ofObject: localCntx) = nilOop]) ifTrue: [
		"error: sender's instruction pointer or context is nil; cannot return"
		^self internalCannotReturn: localVal].

	"If this return is not to our immediate predecessor (i.e. from a method to its sender, or from a block to its caller), scan the stack for the first unwind marked context and inform this context and let it deal with it. This provides a chance for ensure unwinding to occur."
	thisCntx := self fetchPointer: SenderIndex ofObject: activeContext.

	"Just possibly a faster test would be to compare the homeContext and activeContext - they are of course different for blocks. Thus we might be able to optimise a touch by having a different returnTo for the blockreteurn (since we know that must return to caller) and then if active ~= home we must be doing a non-local return. I think. Maybe."
	[thisCntx = localCntx] whileFalse: [
		thisCntx = nilOop ifTrue:[
			"error: sender's instruction pointer or context is nil; cannot return"
			^self internalCannotReturn: localVal].
		"Climb up stack towards localCntx. Break out to a send of #aboutToReturn:through: if an unwind marked context is found"
		unwindMarked := self isUnwindMarked: thisCntx.
		unwindMarked ifTrue:[
			"context is marked; break out"
			^self internalAboutToReturn: localVal through: thisCntx].
		thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx.
 ].

	"If we get here there is no unwind to worry about. Simply terminate the stack up to the localCntx - often just the sender of the method"
	thisCntx := activeContext.
	[thisCntx = localCntx]
		whileFalse:
		["climb up stack to localCntx"
		contextOfCaller := self fetchPointer: SenderIndex ofObject: thisCntx.

		"zap exited contexts so any future attempted use will be caught"
		self storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
		self storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.
		reclaimableContextCount > 0 ifTrue:
			["try to recycle this context"
			reclaimableContextCount := reclaimableContextCount - 1.
			self recycleContextIfPossible: thisCntx].
		thisCntx := contextOfCaller].

	activeContext := thisCntx.
	(self oop: thisCntx isLessThan: youngStart) ifTrue: [ self beRootIfOld: thisCntx ].

	self internalFetchContextRegisters: thisCntx.  "updates local IP and SP"
	self fetchNextBytecode.
	self internalPush: localVal.
! !
!Interpreter methodsFor: 'message sending' stamp: 'ar 7/6/2003 21:53'!
commonSend
	"Send a message, starting lookup with the receiver's class."
	"Assume: messageSelector and argumentCount have been set, and that 
	the receiver and arguments have been pushed onto the stack,"
	"Note: This method is inlined into the interpreter dispatch loop."
	self sharedCodeNamed: 'commonSend' inCase: 131.
	self internalFindNewMethod.
	self internalExecuteNewMethod.
	self fetchNextBytecode! !
!Interpreter methodsFor: 'array primitive support' stamp: 'eem 7/18/2009 17:52'!
commonVariable: rcvr at: index cacheIndex: atIx 
	"This code assumes the receiver has been identified at location atIx in the atCache."
	| stSize fmt fixedFields result |

	stSize := atCache at: atIx+AtCacheSize.
	((self oop: index isGreaterThanOrEqualTo: 1)
		and: [self oop: index isLessThanOrEqualTo: stSize])
	ifTrue:
		[fmt := atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields := atCache at: atIx+AtCacheFixedFields.
			^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
		fmt < 8 ifTrue:  "Bitmap"
			[result := self fetchLong32: index - 1 ofObject: rcvr.
			result := self positive32BitIntegerFor: result.
			^ result].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: "String"
			[^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
			ifFalse: "ByteArray"
			[^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].

	self primitiveFail! !
!Interpreter methodsFor: 'array primitive support' stamp: 'eem 7/18/2009 17:51'!
commonVariable: rcvr at: index put: value cacheIndex: atIx
	"This code assumes the receiver has been identified at location atIx in the atCache."
	| stSize fmt fixedFields valToPut |
	<inline: true>

	stSize := atCache at: atIx+AtCacheSize.
	((self oop: index isGreaterThanOrEqualTo: 1)
		and: [self oop: index isLessThanOrEqualTo: stSize])
	ifTrue:
		[fmt := atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields := atCache at: atIx+AtCacheFixedFields.
			^ self storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
		fmt < 8 ifTrue:  "Bitmap"
			[valToPut := self positive32BitValueOf: value.
			successFlag ifTrue: [self storeLong32: index - 1 ofObject: rcvr withValue: valToPut].
			^ nil].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: [valToPut := self asciiOfCharacter: value.
					successFlag ifFalse: [^ nil]]
			ifFalse: [valToPut := value].
		(self isIntegerObject: valToPut) ifTrue:
			[valToPut := self integerValueOf: valToPut.
			((valToPut >= 0) and: [valToPut <= 255]) ifFalse: [^ self primitiveFail].
			^ self storeByte: index - 1 ofObject: rcvr withValue: valToPut]].

	self primitiveFail! !
!Interpreter methodsFor: 'array primitive support' stamp: 'eem 7/18/2009 17:52'!
commonVariableInternal: rcvr at: index cacheIndex: atIx 
	"This code assumes the receiver has been identified at location atIx in the atCache."
	| stSize fmt fixedFields result |
	<inline: true>

	stSize := atCache at: atIx+AtCacheSize.
	((self oop: index isGreaterThanOrEqualTo: 1)
		and: [self oop: index isLessThanOrEqualTo: stSize])
	ifTrue:
		[fmt := atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields := atCache at: atIx+AtCacheFixedFields.
			^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
		fmt < 8 ifTrue:  "Bitmap"
			[result := self fetchLong32: index - 1 ofObject: rcvr.
			self externalizeIPandSP.
			result := self positive32BitIntegerFor: result.
			self internalizeIPandSP.
			^ result].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: "String"
			[^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
			ifFalse: "ByteArray"
			[^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].

	self primitiveFail! !
!Interpreter methodsFor: 'arithmetic primitive support'!
compare31or32Bits: obj1 equal: obj2
	"May set success to false"

	"First compare two ST integers..."
	((self isIntegerObject: obj1)
		and: [self isIntegerObject: obj2])
		ifTrue: [^ obj1 = obj2].

	"Now compare, assuming positive integers, but setting fail if not"
	^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 11/20/1999 05:05'!
compilerCreateActualMessage: aMessage storingArgs: argArray
	^self cCode: 'compilerHooks[14](aMessage, argArray)'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 1/3/1999 18:00'!
compilerFlushCache: aCompiledMethod
	^self cCode: 'compilerHooks[2](aCompiledMethod)'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 1/3/1999 17:59'!
compilerFlushCacheHook: aCompiledMethod
	<inline: true>
	compilerInitialized ifTrue: [self compilerFlushCache: aCompiledMethod]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:00'!
compilerMapFrom: memStart to: memEnd
	^self cCode: 'compilerHooks[4](memStart, memEnd)'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 12/12/1998 17:03'!
compilerMapHookFrom: memStart to: memEnd
	<inline: true>
	compilerInitialized ifTrue: [self compilerMapFrom: memStart to: memEnd]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/19/1998 17:08'!
compilerMark
	^self cCode: 'compilerHooks[9]()'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 12/19/1998 17:08'!
compilerMarkHook
	<inline: true>
	compilerInitialized ifTrue: [self compilerMark]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:00'!
compilerPostGC
	^self cCode: 'compilerHooks[5]()'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 12/12/1998 17:04'!
compilerPostGCHook
	<inline: true>
	compilerInitialized ifTrue: [self compilerPostGC]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/15/1998 12:43'!
compilerPostSnapshot
	^self cCode: 'compilerHooks[8]()'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 12/15/1998 12:43'!
compilerPostSnapshotHook
	<inline: true>
	compilerInitialized ifTrue: [self compilerPostSnapshot]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:01'!
compilerPreGC: fullGCFlag
	^self cCode: 'compilerHooks[3](fullGCFlag)'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 12/12/1998 17:03'!
compilerPreGCHook: fullGCFlag
	<inline: true>
	compilerInitialized ifTrue: [self compilerPreGC: fullGCFlag]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/15/1998 13:10'!
compilerPreSnapshot
	^self cCode: 'compilerHooks[7]()'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 12/15/1998 13:10'!
compilerPreSnapshotHook
	<inline: true>
	compilerInitialized ifTrue: [self compilerPreSnapshot]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:01'!
compilerProcessChange
	^self cCode: 'compilerHooks[6]()'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 11/24/1999 07:09'!
compilerProcessChange: oldProc to: newProc
	^self cCode: 'compilerHooks[6](oldProc, newProc)'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 12/12/1998 17:04'!
compilerProcessChangeHook
	<inline: true>
	compilerInitialized ifTrue: [self compilerProcessChange]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 10/22/1999 17:01'!
compilerTranslateMethod
	^self cCode: 'compilerHooks[1]()'! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp (auto pragmas 12/08) 10/22/1999 17:01'!
compilerTranslateMethodHook
	<inline: true>
	^compilerInitialized and: [self compilerTranslateMethod]! !
!Interpreter methodsFor: 'contexts' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 21:00'!
context: thisCntx hasSender: aContext 
	"Does thisCntx have aContext in its sender chain?"
	| s nilOop |
	<inline: true>
	thisCntx == aContext ifTrue: [^false].
	nilOop := nilObj.
	s := self fetchPointer: SenderIndex ofObject: thisCntx.
	[s == nilOop]
		whileFalse: [s == aContext ifTrue: [^true].
			s := self fetchPointer: SenderIndex ofObject: s].
	^false! !
!Interpreter methodsFor: 'bitblt support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:23'!
copyBits
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBits
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"

	| fn |
	<var: #fn type: 'void *'>
	fn := self ioLoadFunction: 'copyBits' From: 'BitBltPlugin'.
	fn = 0 ifTrue: [^self primitiveFail].
	^self cCode: '((sqInt (*)(void))fn)()'! !
!Interpreter methodsFor: 'bitblt support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:24'!
copyBitsFrom: x0 to: x1 at: y
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBitsFrom:to:at:
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"

	| fn |
	<var: #fn type: 'void *'>
	fn := self ioLoadFunction: 'copyBitsFromtoat' From: 'BitBltPlugin'.
	fn = 0 ifTrue: [^self primitiveFail].
	^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))fn)(x0, x1, y)'! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'dtl 5/19/2010 12:52'!
copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr
	"Copy this object into the segment beginning at lastSeg.
	Install a forwarding pointer, and save oop and header.
	Fail if out of space.  Return the next segmentAddr if successful."

	"Copy the object..."
	| extraSize bodySize hdrAddr |
	self flag: #Dan.  "None of the imageSegment stuff has been updated for 64 bits"
	successFlag ifFalse: [^ lastSeg].
	extraSize := self extraHeaderBytes: oop.
	bodySize := self sizeBitsOf: oop.
	(self oop: (lastSeg + extraSize + bodySize) isGreaterThanOrEqualTo: stopAddr)
		ifTrue: [^ self primitiveFail].
	self transfer: extraSize + bodySize // self bytesPerWord  "wordCount"
		from: oop - extraSize
		to: lastSeg + self bytesPerWord.

	"Clear root and mark bits of all headers copied into the segment"
	hdrAddr := lastSeg + self bytesPerWord + extraSize.
	self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: self allButRootBit - self markBit).

	self forward: oop to: (lastSeg + self bytesPerWord + extraSize - segmentWordArray)
		savingOopAt: oopPtr andHeaderAt: hdrPtr.

	"Return new end of segment"
	^ lastSeg + extraSize + bodySize! !
!Interpreter methodsFor: 'debug printing'!
cr
	"For testing in Smalltalk, this method should be overridden in a subclass."

	self printf: '\n'.! !
!Interpreter methodsFor: 'message sending' stamp: 'dtl 5/18/2010 21:42'!
createActualMessageTo: aClass 
	"Bundle up the selector, arguments and lookupClass into a Message object. 
	In the process it pops the arguments off the stack, and pushes the message object. 
	This can then be presented as the argument of e.g. #doesNotUnderstand:. 
	ikp 11/20/1999 03:59 -- added hook for external runtime compilers."
	"remap lookupClass in case GC happens during allocation"
	| argumentArray message lookupClass |
	self pushRemappableOop: aClass.
	argumentArray := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
	"remap argumentArray in case GC happens during allocation"
	self pushRemappableOop: argumentArray.
	message := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
	argumentArray := self popRemappableOop.
	lookupClass := self popRemappableOop.
	self beRootIfOld: argumentArray.

	compilerInitialized
		ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray]
		ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * self bytesPerWord) to: argumentArray + self baseHeaderSize.
			self pop: argumentCount thenPush: message].

	argumentCount := 1.
	self storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
	self storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
	(self lastPointerOf: message) >= (MessageLookupClassIndex * self bytesPerWord + self baseHeaderSize)
		ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)"
			self storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 21:44'!
disableCompiler
	compilerInitialized := false! !
!Interpreter methodsFor: 'message sending' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 18:08'!
dispatchFunctionPointer: aFunctionPointer

	<var: #aFunctionPointer type: 'void *'>
	self cCode: '((void (*)(void))aFunctionPointer)()'
			inSmalltalk: [self error: 'my simulator should simulate me']! !
!Interpreter methodsFor: 'message sending' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 18:18'!
dispatchFunctionPointerOn: primIdx in: primTable
	"Call the primitive at index primIdx in the primitiveTable."

	<var: #primTable declareC: 'void *primTable[]'>
	^self dispatchFunctionPointer: (primTable at: primIdx)! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'dtl 5/18/2010 21:42'!
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
	"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."

	| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
	displayObj := self splObj: TheDisplay.
	aForm = displayObj ifFalse: [^ nil].
	self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
	successFlag ifTrue: [
		dispBits := self fetchPointer: 0 ofObject: displayObj.
		w := self fetchInteger: 1 ofObject: displayObj.
		h := self fetchInteger: 2 ofObject: displayObj.
		d := self fetchInteger: 3 ofObject: displayObj.
	].
	l < 0 ifTrue:[left := 0] ifFalse: [left := l].
	r > w ifTrue: [right := w] ifFalse: [right := r].
	t < 0 ifTrue: [top := 0] ifFalse: [top := t].
	b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
	((left <= right) and: [top <= bottom]) ifFalse: [^nil].
	successFlag ifTrue: [
		(self isIntegerObject: dispBits) ifTrue: [
			surfaceHandle := self integerValueOf: dispBits.
			showSurfaceFn = 0 ifTrue: [
				showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
				showSurfaceFn = 0 ifTrue: [^self success: false]].
			self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
		] ifFalse: [
			dispBitsIndex := dispBits + self baseHeaderSize.  "index in memory byte array"
			self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
				inSmalltalk: [self showDisplayBits: dispBitsIndex 
								w: w h: h d: d
								left: left right: right top: top bottom: bottom]
		].
	].! !
!Interpreter methodsFor: 'arithmetic primitive support' stamp: 'di 11/29/1998 11:22'!
doPrimitiveDiv: rcvr by: arg
	"Rounds negative results towards negative infinity, rather than zero."
	| result posArg posRcvr integerRcvr integerArg |
	(self areIntegers: rcvr and: arg)
		ifTrue: [integerRcvr := self integerValueOf: rcvr.
				integerArg := self integerValueOf: arg.
				self success: integerArg ~= 0]
		ifFalse: [self primitiveFail].
	successFlag ifFalse: [^ 1 "fail"].

	integerRcvr > 0
		ifTrue: [integerArg > 0
					ifTrue: [result := integerRcvr // integerArg]
					ifFalse: ["round negative result toward negative infinity"
							posArg := 0 - integerArg.
							result := 0 - ((integerRcvr + (posArg - 1)) // posArg)]]
		ifFalse: [posRcvr := 0 - integerRcvr.
				integerArg > 0
					ifTrue: ["round negative result toward negative infinity"
							result := 0 - ((posRcvr + (integerArg - 1)) // integerArg)]
					ifFalse: [posArg := 0 - integerArg.
							result := posRcvr // posArg]].
	self success: (self isIntegerValue: result).
	^ result! !
!Interpreter methodsFor: 'arithmetic primitive support' stamp: 'di 11/29/1998 10:02'!
doPrimitiveMod: rcvr by: arg
	| integerResult integerRcvr integerArg |
	(self areIntegers: rcvr and: arg)
		ifTrue: [integerRcvr := self integerValueOf: rcvr.
				integerArg := self integerValueOf: arg.
				self success: integerArg ~= 0]
		ifFalse: [self primitiveFail].
	successFlag ifFalse: [^ 1 "fail"].

	integerResult := integerRcvr \\ integerArg.

	"ensure that the result has the same sign as the integerArg"
	integerArg < 0
		ifTrue: [integerResult > 0
			ifTrue: [integerResult := integerResult + integerArg]]
		ifFalse: [integerResult < 0
			ifTrue: [integerResult := integerResult + integerArg]].
	self success: (self isIntegerValue: integerResult).
	^ integerResult
! !
!Interpreter methodsFor: 'send bytecodes' stamp: 'tpr 3/24/2004 18:35'!
doubleExtendedDoAnythingBytecode
	"Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count. 
	Here we use 3 bits for the operation sub-type (opType),  and the remaining 5 bits for argument count where needed. 
	The last byte give access to 256 instVars or literals. 
	See also secondExtendedSendBytecode"
	| byte2 byte3 opType top |
	byte2 := self fetchByte.
	byte3 := self fetchByte.
	opType := byte2 >> 5.
	opType = 0 ifTrue: [messageSelector := self literal: byte3.
			argumentCount := byte2 bitAnd: 31.
			^ self normalSend].
	opType = 1 ifTrue: [messageSelector := self literal: byte3.
			argumentCount := byte2 bitAnd: 31.
			^ self superclassSend].
	self fetchNextBytecode.
	opType = 2 ifTrue: [^ self pushReceiverVariable: byte3].
	opType = 3 ifTrue: [^ self pushLiteralConstant: byte3].
	opType = 4 ifTrue: [^ self pushLiteralVariable: byte3].
	opType = 5 ifTrue: [top := self internalStackTop.
			^ self storePointer: byte3 ofObject: receiver withValue: top].
	opType = 6
		ifTrue: [top := self internalStackTop.
			self internalPop: 1.
			^ self storePointer: byte3 ofObject: receiver withValue: top].
	opType = 7
		ifTrue: [top := self internalStackTop.
			^ self storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top]! !
!Interpreter methodsFor: 'initialization' stamp: 'JMM (auto pragmas 12/08) 12/28/2002 22:07'!
dummyReferToProxy
	<inline: false>
	interpreterProxy := interpreterProxy! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl (auto pragmas dtl 2010-09-26) 3/26/2010 02:00'!
dumpImage: fileName
	"Dump the entire image out to the given file. Intended for debugging only."
	| f dataSize result |
	<export: true>
	<var: #fileName type: 'char *'>
	<var: #f type: 'sqImageFile'>

	f := self cCode: 'sqImageFileOpen(fileName, "wb")'.
	f = nil ifTrue: [^-1].
	dataSize := endOfMemory - self startOfMemory.
	result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
	self cCode: 'sqImageFileClose(f)'.
	^result
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:42'!
duplicateTopBytecode

	self fetchNextBytecode.
	self internalPush: self internalStackTop.
! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 21:45'!
enableCompiler
	"Calling this before loading the compiler will provoke a nullCompilerHook error"

	compilerInitialized := true! !
!Interpreter methodsFor: 'message sending' stamp: 'tpr 5/31/2004 17:55'!
executeNewMethod
	"execute a method not found in the mCache - which means that 
	primitiveIndex must be manually set. Used by primitiveClosureValue & primitiveExecuteMethod, where no lookup is previously done"
	primitiveIndex > 0
		ifTrue: [self primitiveResponse.
			successFlag ifTrue: [^ nil]].
	"if not primitive, or primitive failed, activate the method"
	self activateNewMethod.
	"check for possible interrupts at each real send"
	self quickCheckForInterrupts! !
!Interpreter methodsFor: 'message sending' stamp: 'tpr 5/31/2004 17:54'!
executeNewMethodFromCache
	"execute a method found in the mCache - which means that 
	primitiveIndex & primitiveFunctionPointer are already set. Any sender 
	needs to have previously sent findMethodInClass: or equivalent"
	| nArgs delta |
	primitiveIndex > 0
		ifTrue: [DoBalanceChecks ifTrue: ["check stack balance"
					nArgs := argumentCount.
					delta := stackPointer - activeContext].
			successFlag := true.
			self dispatchFunctionPointer: primitiveFunctionPointer.
			"branch direct to prim function from address stored in mcache"
			DoBalanceChecks
				ifTrue: [(self balancedStack: delta afterPrimitive: primitiveIndex withArgs: nArgs)
						ifFalse: [self printUnbalancedStack: primitiveIndex]].
			successFlag ifTrue: [^ nil]].
	"if not primitive, or primitive failed, activate the method"
	self activateNewMethod.
	"check for possible interrupts at each real send"
	self quickCheckForInterrupts! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:46'!
extendedPushBytecode

	| descriptor variableType variableIndex |
	descriptor := self fetchByte.
	self fetchNextBytecode.
	variableType := (descriptor >> 6) bitAnd: 16r3.
	variableIndex := descriptor bitAnd: 16r3F.
	variableType=0 ifTrue: [^self pushReceiverVariable: variableIndex].
	variableType=1 ifTrue: [^self pushTemporaryVariable: variableIndex].
	variableType=2 ifTrue: [^self pushLiteralConstant: variableIndex].
	variableType=3 ifTrue: [^self pushLiteralVariable: variableIndex].
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'!
extendedStoreAndPopBytecode

	self extendedStoreBytecode.
	self internalPop: 1.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 19:06'!
extendedStoreBytecode
	| descriptor variableType variableIndex association |
	<inline: true>
	descriptor := self fetchByte.
	self fetchNextBytecode.
	variableType := descriptor >> 6 bitAnd: 3.
	variableIndex := descriptor bitAnd: 63.
	variableType = 0
		ifTrue: [^ self storePointer: variableIndex ofObject: receiver withValue: self internalStackTop].
	variableType = 1
		ifTrue: [^ self storePointerUnchecked: variableIndex + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop].
	variableType = 2
		ifTrue: [self error: 'illegal store'].
	variableType = 3
		ifTrue: [association := self literal: variableIndex.
			^ self storePointer: ValueIndex ofObject: association withValue: self internalStackTop]! !
!Interpreter methodsFor: 'utilities' stamp: 'ikp 6/10/2004 11:08'!
externalizeIPandSP
	"Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop."

	instructionPointer := self oopForPointer: localIP.
	stackPointer := self oopForPointer: localSP.
	theHomeContext := localHomeContext.
! !
!Interpreter methodsFor: 'primitive support'!
failed

	^successFlag not! !
!Interpreter methodsFor: 'utilities' stamp: 'jm (auto pragmas 12/08) 2/15/98 17:11'!
fetchArray: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
	"Note: May be called by translated primitive code."

	| arrayOop |
	<returnTypeC: 'void *'>
	arrayOop := self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self arrayValueOf: arrayOop
! !
!Interpreter methodsFor: 'interpreter shell' stamp: 'ikp 6/10/2004 11:01'!
fetchByte
	"This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator."

	^ self byteAtPointer: localIP preIncrement! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:42'!
fetchContextRegisters: activeCntx 
	"Note: internalFetchContextRegisters: should track changes  to this method."
	| tmp |
	<inline: true>
	tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
	(self isIntegerObject: tmp)
		ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
			tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
			(self oop: tmp isLessThan: youngStart) ifTrue: [self beRootIfOld: tmp]]
		ifFalse: ["otherwise, it is a method context and is its own home context "
			tmp := activeCntx].
	theHomeContext := tmp.
	receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
	method := self fetchPointer: MethodIndex ofObject: tmp.

	"the instruction pointer is a pointer variable equal to 
	method oop + ip + self baseHeaderSize 
	-1 for 0-based addressing of fetchByte 
	-1 because it gets incremented BEFORE fetching currentByte "
	tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
	instructionPointer := method + tmp + self baseHeaderSize - 2.

	"the stack pointer is a pointer variable also..."
	tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
	stackPointer := activeCntx + self baseHeaderSize + (TempFrameStart + tmp - 1 * self bytesPerWord)! !
!Interpreter methodsFor: 'utilities' stamp: '(auto pragmas 12/08) '!
fetchFloat: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
	"Note: May be called by translated primitive code."

	| floatOop |
	<returnTypeC: 'double'>
	floatOop := self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self floatValueOf: floatOop! !
!Interpreter methodsFor: 'utilities' stamp: 'tpr (auto pragmas 12/08) 3/15/2004 19:52'!
fetchInteger: fieldIndex ofObject: objectPointer
	"Note: May be called by translated primitive code."

	| intOop |
	<inline: false>
	intOop := self fetchPointer: fieldIndex ofObject: objectPointer.
	^self checkedIntegerValueOf: intOop! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:42'!
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
	"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
	"Note: May be called by translated primitive code."

	| intOrFloat floatVal frac trunc |
	<inline: false>
	<var: #floatVal type: 'double '>
	<var: #frac type: 'double '>
	<var: #trunc type: 'double '>

	intOrFloat := self fetchPointer: fieldIndex ofObject: objectPointer.
	(self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
	self assertClassOf: intOrFloat is: (self splObj: ClassFloat).
	successFlag ifTrue: [
		self cCode: '' inSmalltalk: [floatVal := Float new: 2].
		self fetchFloatAt: intOrFloat + self baseHeaderSize into: floatVal.
		self cCode: 'frac = modf(floatVal, &trunc)'.
		"the following range check is for C ints, with range -2^31..2^31-1"
		self flag: #Dan.		"The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
		self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
	successFlag
		ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
		ifFalse: [^ 0].
! !
!Interpreter methodsFor: 'interpreter shell' stamp: 'jm 12/10/1998 16:44'!
fetchNextBytecode
	"This method fetches the next instruction (bytecode). Each bytecode method is responsible for fetching the next bytecode, preferably as early as possible to allow the memory system time to process the request before the next dispatch."

	currentBytecode := self fetchByte.
! !
!Interpreter methodsFor: 'contexts' stamp: 'tpr (auto pragmas dtl 2010-09-26) 3/24/2004 21:01'!
fetchStackPointerOf: aContext
	"Return the stackPointer of a Context or BlockContext."
	| sp |
	<inline: true>
	sp := self fetchPointer: StackPointerIndex ofObject: aContext.
	(self isIntegerObject: sp) ifFalse: [^0].
	^self integerValueOf: sp! !
!Interpreter methodsFor: 'debug support'!
findClassOfMethod: meth forReceiver: rcvr

	| currClass classDict classDictSize methodArray i done |
	currClass := self fetchClassOf: rcvr.
	done := false.
	[done] whileFalse: [
		classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass.
		classDictSize := self fetchWordLengthOf: classDict.
		methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
		i := 0.
		[i < (classDictSize - SelectorStart)] whileTrue: [
			meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
			i := i + 1.
		].
		currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
		done := currClass = nilObj.
	].
	^self fetchClassOf: rcvr    "method not found in superclass chain"! !
!Interpreter methodsFor: 'message sending' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 21:13'!
findNewMethodInClass: class 
	"Find the compiled method to be run when the current 
	messageSelector is sent to the given class, setting the values 
	of 'newMethod' and 'primitiveIndex'."
	| ok |
	<inline: false>
	ok := self lookupInMethodCacheSel: messageSelector class: class.
	ok
		ifFalse: ["entry was not found in the cache; look it up the hard way "
			self lookupMethodInClass: class.
			lkupClass := class.
			self addNewMethodToCache]! !
!Interpreter methodsFor: 'debug support' stamp: 'ajh 3/16/2003 13:04'!
findSelectorOfMethod: meth forReceiver: rcvr

	| currClass done classDict classDictSize methodArray i |
	currClass := self fetchClassOf: rcvr.
	done := false.
	[done] whileFalse: [
		classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass.
		classDictSize := self fetchWordLengthOf: classDict.
		methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
		i := 0.
		[i <= (classDictSize - SelectorStart)] whileTrue: [
			meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [
				^(self fetchPointer: i + SelectorStart ofObject: classDict)
			].
			i := i + 1.
		].
		currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
		done := currClass = nilObj.
	].
	^ nilObj    "method not found in superclass chain"! !
!Interpreter methodsFor: 'plugin support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:42'!
firstFixedField: oop

	<returnTypeC: 'char *'>
	^ self pointerForOop: oop + self baseHeaderSize! !
!Interpreter methodsFor: 'plugin support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:05'!
firstIndexableField: oop
	"NOTE: copied in InterpreterSimulator, so please duplicate any changes"

	| hdr fmt totalLength fixedFields |
	<returnTypeC: 'char *'>
	hdr := self baseHeader: oop.
	fmt := (hdr >> 8) bitAnd: 16rF.
	totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
	fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
	fmt < 8 ifTrue:
		[fmt = 6 ifTrue:
			["32 bit field objects"
			^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)].
		"full word objects (pointer or bits)"
		^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)]
	ifFalse:
		["Byte objects"
		^ self pointerForOop: oop + self baseHeaderSize + fixedFields]! !
!Interpreter methodsFor: 'object format' stamp: 'ar (auto pragmas dtl 2010-09-26) 3/21/98 02:37'!
fixedFieldsOf: oop format: fmt length: wordLength
"
	NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
	When we revise the image format, it should become...
	^ (classFormat >> 2 bitAnd: 16rFF) - 1
"
	| class classFormat |
	<inline: true>
	((fmt > 4) or: [fmt = 2]) ifTrue: [^ 0].  "indexable fields only"
	fmt < 2 ifTrue: [^ wordLength].  "fixed fields only (zero or more)"
	
	"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
	class := self fetchClassOf: oop.
	classFormat := self formatOfClass: class.
	^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1
! !
!Interpreter methodsFor: 'object format' stamp: 'dtl 9/26/2010 11:32'!
floatObjectOf: aFloat
	| newFloatObj |
	<var: #aFloat type: 'double '>
self flag: #Dan.
	newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8 + self baseHeaderSize.
	self storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat.
	^ newFloatObj.
! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl 9/26/2010 11:32'!
floatValueOf: oop
	"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
	"Note: May be called by translated primitive code."

	| result |
	<returnTypeC: 'double'>
	<var: #result type: 'double '>
	self flag: #Dan.  "None of the float stuff has been converted for 64 bits"
	self assertClassOf: oop is: (self splObj: ClassFloat).
	successFlag
		ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2].
				self fetchFloatAt: oop + self baseHeaderSize into: result]
		ifFalse: [result := 0.0].
	^ result! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'dtl 12/13/2010 23:54'!
flushAtCache
	"Flush the at cache. The method cache is flushed on every programming change and garbage collect."

	1 to: AtCacheTotalSize do: [ :i | atCache at: i put: 0 ]
! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'tpr 5/12/2005 22:43'!
flushExternalPrimitiveOf: methodPtr
	"methodPtr is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
	| lit |
	(self literalCountOf: methodPtr) > 0 ifFalse:[^nil]. "Something's broken"
	lit := self literal: 0 ofMethod: methodPtr.
	((self isArray: lit) and:[(self lengthOf: lit) = 4])
		ifFalse:[^nil]. "Something's broken"
	"ConstZero is a known SmallInt so no root check needed"
	self storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
	self storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'tpr 3/15/2004 20:46'!
flushExternalPrimitiveTable
	"Flush the external primitive table"
	0 to: MaxExternalPrimitiveTableSize-1 do:[:i|
		externalPrimitiveTable at: i put: 0].
! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'eem 6/23/2008 16:16'!
flushExternalPrimitives
	"Flush the references to external functions from plugin 
	primitives. This will force a reload of those primitives when 
	accessed next. 
	Note: We must flush the method cache here so that any 
	failed primitives are looked up again."
	| oop primIdx |
	oop := self firstObject.
	[self oop: oop isLessThan: endOfMemory]
		whileTrue: [(self isFreeObject: oop)
				ifFalse: [(self isCompiledMethod: oop)
						ifTrue: ["This is a compiled method"
							primIdx := self primitiveIndexOf: oop.
							primIdx = PrimitiveExternalCallIndex
								ifTrue: ["It's primitiveExternalCall"
									self flushExternalPrimitiveOf: oop]]].
			oop := self objectAfter: oop].
	self flushMethodCache.
	self flushExternalPrimitiveTable! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'dtl 12/13/2010 23:54'!
flushMethodCache
	"Flush the method cache. The method cache is flushed on every programming change and garbage collect."

	1 to: MethodCacheSize do: [ :i | methodCache at: i put: 0 ].
	self flushAtCache! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'dtl 4/22/2007 22:28'!
flushMethodCacheFrom: memStart to: memEnd 
	"Flush entries in the method cache only if the oop address is within the given memory range. 
	This reduces overagressive cache clearing. Note the AtCache is fully flushed, 70% of the time 
	cache entries live in newspace, new objects die young"
	| probe |
	probe := 0.
	1 to: MethodCacheEntries do: [:i | 
			(methodCache at: probe + MethodCacheSelector) = 0
				ifFalse: [(((((self oop: (methodCache at: probe + MethodCacheSelector) isGreaterThanOrEqualTo: memStart)
										and: [self oop: (methodCache at: probe + MethodCacheSelector) isLessThan: memEnd])
									or: [(self oop: (methodCache at: probe + MethodCacheClass) isGreaterThanOrEqualTo: memStart)
											and: [self oop: (methodCache at: probe + MethodCacheClass) isLessThan: memEnd]])
								or: [(self oop: (methodCache at: probe + MethodCacheMethod) isGreaterThanOrEqualTo: memStart)
										and: [self oop: (methodCache at: probe + MethodCacheMethod) isLessThan: memEnd]])
							or: [(self oop: (methodCache at: probe + MethodCacheNative) isGreaterThanOrEqualTo: memStart)
									and: [self oop: (methodCache at: probe + MethodCacheNative) isLessThan: memEnd]])
						ifTrue: [methodCache at: probe + MethodCacheSelector put: 0]].
			probe := probe + MethodCacheEntrySize].
	1 to: AtCacheTotalSize do: [:i | atCache at: i put: 0]! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 4/18/2006 13:33'!
forceInterruptCheck
	"force an interrupt check ASAP - setting interruptCheckCounter to a large -ve number is used as a flag to skip messing with the feedback mechanism and nextPollTick resetting makes sure that ioProcess gets called as near immediately as we can manage"
	interruptCheckCounter := -1000.
	nextPollTick := 0! !
!Interpreter methodsFor: 'object format'!
formatOfClass: classPointer
	"**should be in-lined**"
	"Note that, in Smalltalk, the instSpec will be equal to the inst spec
	part of the base header of an instance (without hdr type) shifted left 1.
	In this way, apart from the smallInt bit, the bits
	are just where you want them for the first header word."
	"Callers expect low 2 bits (header type) to be zero!!"

	^ (self fetchPointer: InstanceSpecificationIndex ofObject: classPointer) - 1! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'di 3/24/1999 16:10'!
forward: oop to: newOop savingOopAt: oopPtr andHeaderAt: hdrPtr

	"Make a new entry in the table of saved oops."
	self longAt: oopPtr put: oop.					"Save the oop"
	self longAt: hdrPtr put: (self longAt: oop).	"Save the old header word"

	"Put a forwarding pointer in the old object, flagged with forbidden header type"
	self longAt: oop put: newOop + HeaderTypeFree.
! !
!Interpreter methodsFor: 'I/O primitive support' stamp: 'tpr 3/15/2004 10:25'!
fullDisplayUpdate
	"Repaint the entire smalltalk screen, ignoring the affected rectangle. Used in some platform's code when the Smalltalk window is brought to the front or uncovered."

	| displayObj w h |
	displayObj := self splObj: TheDisplay.
	((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [
		w := self fetchInteger: 1 ofObject: displayObj.
		h := self fetchInteger: 2 ofObject: displayObj.
		self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: h.
		self ioForceDisplayUpdate].
! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp (auto pragmas 12/08) 8/2/2004 17:54'!
functionPointerFor: primIdx inClass: theClass
	"Find an actual function pointer for this primitiveIndex.  This is an
	opportunity to specialise the prim for the relevant class (format for
	example).  Default for now is simply the entry in the base primitiveTable."

	<returnTypeC: 'void *'>
	^primitiveTable at: primIdx! !
!Interpreter methodsFor: 'interpreter shell'!
getCurrentBytecode
	"currentBytecode will be private to the main dispatch loop in the generated code. This method allows the currentBytecode to be retrieved from global variables."

	^ self byteAt: instructionPointer! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/17/2002 12:02'!
getFullScreenFlag
	^fullScreenFlag! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/17/2002 12:02'!
getInterruptCheckCounter
	^interruptCheckCounter! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/17/2002 12:02'!
getInterruptKeycode
	^interruptKeycode! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/17/2002 12:02'!
getInterruptPending
	^interruptPending! !
!Interpreter methodsFor: 'image save/restore' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:25'!
getLongFromFile: aFile swap: swapFlag
	"Answer the next word read from aFile, byte-swapped according to the swapFlag."

	| w |
	<var: #aFile type: 'sqImageFile '>
	w := 0.
	self cCode: 'sqImageFileRead(&w, sizeof(w), 1, aFile)'.
	swapFlag
		ifTrue: [^ self byteSwapped: w]
		ifFalse: [^ w].
! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/17/2002 12:03'!
getNextWakeupTick
	^nextWakeupTick! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/17/2002 12:03'!
getSavedWindowSize
	^savedWindowSize! !
!Interpreter methodsFor: 'contexts' stamp: 'eem (auto pragmas dtl 2010-09-26) 11/2/2007 15:39'!
getStackPointer
	"For Newsqueak FFI"
	<export: true>
	^stackPointer! !
!Interpreter methodsFor: 'plugin support' stamp: 'tpr (auto pragmas 12/08) 6/17/2005 17:52'!
getThisSessionID
	"return the global session ID value"
	<inline: false>
	^globalSessionID! !
!Interpreter methodsFor: 'compiled methods' stamp: 'tpr 3/24/2004 21:06'!
headerOf: methodPointer
	^self fetchPointer: HeaderIndex ofObject: methodPointer! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 5/18/2010 20:55'!
imageFormatBackwardCompatibilityVersion
	"This VM is backwards-compatible with the immediately preceeding pre-closure version, and will allow loading images (or image segments) of that version."

	self bytesPerWord == 4
		ifTrue: [^6502]
		ifFalse: [^68000]! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 10/3/2010 10:38'!
imageFormatInitialVersion
	"This is the image format version that was saved to in the previous image snapshot.
	The interpreter checks this value at image load time to determine if it is able to load
	and run the image file. When the image is next saved, it will be saved using the current
	imageFormatVersion, which may be different from imageFormatInitialVersion. "
	^imageFormatInitialVersion! !
!Interpreter methodsFor: 'image save/restore' stamp: 'eem 2/18/2009 09:51'!
imageFormatVersion
	"Return a magic constant that changes when the image format changes. Since the image reading code uses
	 this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."

	"See Interpreter class>>declareCVarsIn: and Interpreter>>pushClosureCopyCopiedValuesBytecode
	 for the initialization of imageFormatVersionNumber"
	^imageFormatVersionNumber! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'dtl 5/18/2010 21:43'!
imageSegmentVersion
	| wholeWord |
	"a more complex version that tells both the word reversal and the endianness of the machine it came from.  Low half of word is 6502.  Top byte is top byte of #doesNotUnderstand: on this machine. ($d on the Mac or $s on the PC)"

	wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + self baseHeaderSize.
		"first data word, 'does' "
	^ self imageFormatVersion bitOr: (wholeWord bitAnd: 16rFF000000)! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'ar (auto pragmas 12/08) 11/21/1999 00:11'!
includesBehavior: aClass ThatOf: aSuperclass
	"Return the equivalent of 
		aClass includesBehavior: aSuperclass.
	Note: written for efficiency and better inlining (only 1 temp)"
	| theClass |
	<inline: true>
	(((theClass := aClass) = aSuperclass) "aClass == aSuperclass"
		or:[aSuperclass = nilObj]) "every class inherits from nil"
			ifTrue:[^true].
	[(theClass := self superclassOf: theClass) = aSuperclass ifTrue:[^true].
	theClass ~= nilObj] whileTrue.
	^false! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 11/20/1999 04:53'!
initCompilerHooks
	"Initialize hooks for the 'null compiler'"

	self cCode: 'compilerHooks[1]= nullCompilerHook'.
	self cCode: 'compilerHooks[2]= nullCompilerHook'.
	self cCode: 'compilerHooks[3]= nullCompilerHook'.
	self cCode: 'compilerHooks[4]= nullCompilerHook'.
	self cCode: 'compilerHooks[5]= nullCompilerHook'.
	self cCode: 'compilerHooks[6]= nullCompilerHook'.
	self cCode: 'compilerHooks[7]= nullCompilerHook'.
	self cCode: 'compilerHooks[8]= nullCompilerHook'.
	self cCode: 'compilerHooks[9]= nullCompilerHook'.
	self cCode: 'compilerHooks[10]= nullCompilerHook'.
	self cCode: 'compilerHooks[11]= nullCompilerHook'.
	self cCode: 'compilerHooks[12]= nullCompilerHook'.
	self cCode: 'compilerHooks[13]= nullCompilerHook'.
	self cCode: 'compilerHooks[14]= nullCompilerHook'.

	compilerInitialized := false! !
!Interpreter methodsFor: 'initialization' stamp: 'dtl 5/19/2010 12:52'!
initialCleanup
	"Images written by VMs earlier than 3.6/3.7 will wrongly have the root bit set on the active context. Besides clearing the root bit, we treat this as a marker that these images also lack a cleanup of external primitives (which has been introduced at the same time when the root bit problem was fixed). In this case, we merely flush them from here."

	((self longAt: activeContext) bitAnd: self rootBit) = 0 ifTrue:[^nil]. "root bit is clean"
	"Clean root bit of activeContext"
	self longAt: activeContext put: ((self longAt: activeContext) bitAnd: self allButRootBit).
	"Clean external primitives"
	self flushExternalPrimitives.! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 22:01'!
initializeImageFormatVersionIfNeeded
	"Set the imageFormatVersionNumber to a default value for this word
	size. Normally this will have been set at image load time, but set it to
	a reasonable default if this has not been done."

	<inline: false>
	imageFormatVersionNumber = 0
		ifTrue: [self bytesPerWord == 8
				ifFalse: [imageFormatVersionNumber := 6502]
				ifTrue: [imageFormatVersionNumber := 68000]]
! !
!Interpreter methodsFor: 'initialization' stamp: 'ar 6/8/2006 11:40'!
initializeInterpreter: bytesToShift 
	"Initialize Interpreter state before starting execution of a new image."
	interpreterProxy := self sqGetInterpreterProxy.
	self dummyReferToProxy.
	self initializeObjectMemory: bytesToShift.
	self initCompilerHooks.
	activeContext := nilObj.
	theHomeContext := nilObj.
	method := nilObj.
	receiver := nilObj.
	messageSelector := nilObj.
	newMethod := nilObj.
	methodClass := nilObj.
	lkupClass := nilObj.
	receiverClass := nilObj.
	newNativeMethod := nilObj.
	self flushMethodCache.
	self loadInitialContext.
	self initialCleanup.
	interruptCheckCounter := 0.
	interruptCheckCounterFeedBackReset := 1000.
	interruptChecksEveryNms := 1.
	nextPollTick := 0.
	nextWakeupTick := 0.
	lastTick := 0.
	interruptKeycode := 2094. "cmd-. as used for Mac but no other OS"
	interruptPending := false.
	semaphoresUseBufferA := true.
	semaphoresToSignalCountA := 0.
	semaphoresToSignalCountB := 0.
	deferDisplayUpdates := false.
	pendingFinalizationSignals := 0.
	globalSessionID := 0.
	[globalSessionID = 0]
		whileTrue: [globalSessionID := self
						cCode: 'time(NULL) + ioMSecs()'
						inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]].
	jmpDepth := 0.
	jmpMax := MaxJumpBuf. "xxxx: Must match the definition of jmpBuf and suspendedCallbacks"
! !
!Interpreter methodsFor: 'array primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:26'!
install: rcvr inAtCache: cache at: atIx string: stringy
	"Install the oop of this object in the given cache (at or atPut), along with
	its size, format and fixedSize"
	| hdr fmt totalLength fixedFields |
	<var: #cache type: 'sqInt *'>

	hdr := self baseHeader: rcvr.
	fmt := (hdr >> 8) bitAnd: 16rF.
	(fmt = 3 and: [self isContextHeader: hdr]) ifTrue:
		["Contexts must not be put in the atCache, since their size is not constant"
		^ self primitiveFail].
	totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
	fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength.

	cache at: atIx+AtCacheOop put: rcvr.
	stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16]  "special flag for strings"
			ifFalse: [cache at: atIx+AtCacheFmt put: fmt].
	cache at: atIx+AtCacheFixedFields put: fixedFields.
	cache at: atIx+AtCacheSize put: totalLength - fixedFields.
! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar (auto pragmas 12/08) 3/6/2001 15:21'!
internalAboutToReturn: resultObj through: aContext
	<inline: true>
	self internalPush: activeContext.
	self internalPush: resultObj.
	self internalPush: aContext.
	messageSelector := self splObj: SelectorAboutToReturn.
	argumentCount := 2.
	^self normalSend! !
!Interpreter methodsFor: 'message sending' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:05'!
internalActivateNewMethod
	| methodHeader newContext tempCount argCount2 needsLarge where |
	<inline: true>

	methodHeader := self headerOf: newMethod.
	needsLarge := methodHeader bitAnd: LargeContextBit.
	(needsLarge = 0 and: [freeContexts ~= NilContext])
		ifTrue: [newContext := freeContexts.
				freeContexts := self fetchPointer: 0 ofObject: newContext]
		ifFalse: ["Slower call for large contexts or empty free list"
				self externalizeIPandSP.
				newContext := self allocateOrRecycleContext: needsLarge.
				self internalizeIPandSP].
	tempCount := (methodHeader >> 19) bitAnd: 16r3F.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."
	where :=   newContext + self baseHeaderSize.
	self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
	self longAt: where + (InstructionPointerIndex << self shiftForWord)
		put: (self integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1)).
	self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
	self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
	self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.

	"Copy the receiver and arguments..."
	argCount2 := argumentCount.
	0 to: argCount2 do:
		[:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self internalStackValue: argCount2-i)].

	"clear remaining temps to nil in case it has been recycled"
	methodHeader := nilObj.  "methodHeader here used just as faster (register?) temp"
	argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
		[:i | self longAt: where + (i << self shiftForWord) put: methodHeader].

	self internalPop: argCount2 + 1.
	reclaimableContextCount := reclaimableContextCount + 1.
	self internalNewActiveContext: newContext.
 ! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar (auto pragmas 12/08) 3/6/2001 15:21'!
internalCannotReturn: resultObj
	<inline: true>
	self internalPush: activeContext.
	self internalPush: resultObj.
	messageSelector := self splObj: SelectorCannotReturn.
	argumentCount := 1.
	^ self normalSend! !
!Interpreter methodsFor: 'message sending' stamp: 'tpr (auto pragmas dtl 2010-09-26) 4/22/2004 12:22'!
internalExecuteNewMethod
	| localPrimIndex delta nArgs |
	<inline: true>
	localPrimIndex := primitiveIndex.
	localPrimIndex > 0
		ifTrue: [(localPrimIndex > 255
					and: [localPrimIndex < 520])
				ifTrue: ["Internal return instvars"
					localPrimIndex >= 264
						ifTrue: [^ self internalPop: 1 thenPush: (self fetchPointer: localPrimIndex - 264 ofObject: self internalStackTop)]
						ifFalse: ["Internal return constants"
							localPrimIndex = 256 ifTrue: [^ nil].
							localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: trueObj].
							localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: falseObj].
							localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: nilObj].
							^ self internalPop: 1 thenPush: (self integerObjectOf: localPrimIndex - 261)]]
				ifFalse: [self externalizeIPandSP.
					"self primitiveResponse. <-replaced with  manually inlined code"
					DoBalanceChecks
						ifTrue: ["check stack balance"
							nArgs := argumentCount.
							delta := stackPointer - activeContext].
					successFlag := true.
					self dispatchFunctionPointer: primitiveFunctionPointer. "branch direct to prim function from address stored in mcache"
					DoBalanceChecks
						ifTrue: [(self balancedStack: delta afterPrimitive: localPrimIndex withArgs: nArgs)
								ifFalse: [self printUnbalancedStack: localPrimIndex]].
					self internalizeIPandSP.
					successFlag
						ifTrue: [self browserPluginReturnIfNeeded.
							^ nil]]].
	"if not primitive, or primitive failed, activate the method"
	self internalActivateNewMethod.
	"check for possible interrupts at each real send"
	self internalQuickCheckForInterrupts! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:43'!
internalFetchContextRegisters: activeCntx
	"Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."

	| tmp |
	<inline: true>
	tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
	(self isIntegerObject: tmp) ifTrue: [
		"if the MethodIndex field is an integer, activeCntx is a block context"
		tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
		(self oop: tmp isLessThan: youngStart) ifTrue: [ self beRootIfOld: tmp ].
	] ifFalse: [
		"otherwise, it is a method context and is its own home context"
		tmp := activeCntx.
	].
	localHomeContext := tmp.
	receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
	method := self fetchPointer: MethodIndex ofObject: tmp.

	"the instruction pointer is a pointer variable equal to
		method oop + ip + self baseHeaderSize
		  -1 for 0-based addressing of fetchByte
		  -1 because it gets incremented BEFORE fetching currentByte"
	tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
	localIP := self pointerForOop: method + tmp + self baseHeaderSize - 2.

	"the stack pointer is a pointer variable also..."
	tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
	localSP := self pointerForOop: activeCntx + self baseHeaderSize + ((TempFrameStart + tmp - 1) * self bytesPerWord)! !
!Interpreter methodsFor: 'message sending' stamp: 'ar (auto pragmas 12/08) 7/6/2003 23:55'!
internalFindNewMethod
	"Find the compiled method to be run when the current messageSelector is sent to the class 'lkupClass', setting the values of 'newMethod' and 'primitiveIndex'."
	| ok | 
	<inline: true>
	ok := self lookupInMethodCacheSel: messageSelector class: lkupClass.
	ok ifFalse: [
		"entry was not found in the cache; look it up the hard way"
		self externalizeIPandSP.
		self lookupMethodInClass: lkupClass.
		self internalizeIPandSP.
		self addNewMethodToCache].
! !
!Interpreter methodsFor: 'object format' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-26) 11/23/2008 00:09'!
internalIsImmutable: oop
	<inline: true>
	<export: true>
	^false.
	"^((self baseHeader: oop) bitAnd: ImmutabilityBit) ~= 0"! !
!Interpreter methodsFor: 'object format' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-26) 11/23/2008 00:09'!
internalIsMutable: oop
	<inline: true>
	<export: true>
	^true
	"^((self baseHeader: oop) bitAnd: ImmutabilityBit) = 0"! !
!Interpreter methodsFor: 'message sending' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:05'!
internalJustActivateNewMethod
	"Activate the new method but *do not* copy receiver or argumernts from activeContext."
	| methodHeader initialIP newContext tempCount needsLarge where |
	<inline: true>

	methodHeader := self headerOf: newMethod.
	needsLarge := methodHeader bitAnd: LargeContextBit.
	(needsLarge = 0 and: [freeContexts ~= NilContext])
		ifTrue: [newContext := freeContexts.
				freeContexts := self fetchPointer: 0 ofObject: newContext]
		ifFalse: ["Slower call for large contexts or empty free list"
				newContext := self allocateOrRecycleContext: needsLarge].
	initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1.
	tempCount := (methodHeader >> 19) bitAnd: 16r3F.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."
	where := newContext + self baseHeaderSize.
	self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
	self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
	self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
	self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.

	"Set the receiver..."
	self longAt: where + (ReceiverIndex << self shiftForWord) put: receiver.

	"clear all args and temps to nil in case it has been recycled"
	needsLarge := nilObj.  "needsLarge here used just as faster (register?) temp"
	ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
		[:i | self longAt: where + (i << self shiftForWord) put: needsLarge].
	reclaimableContextCount := reclaimableContextCount + 1.

	activeContext := newContext.! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 23:27'!
internalNewActiveContext: aContext
	"The only difference between this method and newActiveContext: is that this method uses internal context registers."
	<inline: true>

	self internalStoreContextRegisters: activeContext.
	(self oop: aContext isLessThan: youngStart) ifTrue: [ self beRootIfOld: aContext ].
	activeContext := aContext.
	self internalFetchContextRegisters: aContext.! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 20:56'!
internalPop: nItems

	localSP := localSP - (nItems * self bytesPerWord).! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 20:57'!
internalPop: nItems thenPush: oop

	self longAtPointer: (localSP := localSP - ((nItems - 1) * self bytesPerWord)) put: oop.
! !
!Interpreter methodsFor: 'control primitives' stamp: 'tpr (auto pragmas dtl 2010-09-26) 5/13/2005 10:50'!
internalPrimitiveValue
	| newContext blockArgumentCount initialIP |
	<inline: true>
	self sharedCodeNamed: 'commonPrimitiveValue' inCase: 201.
	successFlag := true.
	newContext := self internalStackValue: argumentCount.
	self assertClassOf: newContext is: (self splObj: ClassBlockContext).
	blockArgumentCount := self argumentCountOfBlock: newContext.

	self success: (argumentCount = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: newContext) = nilObj]).

	successFlag
		ifTrue: ["This code assumes argCount can only = 0 or 1"
			argumentCount = 1
				ifTrue: [self storePointer: TempFrameStart ofObject: newContext withValue: self internalStackTop].
			self internalPop: argumentCount + 1.
			"copy the initialIP value to the ip slot"
			initialIP := self fetchPointer: InitialIPIndex ofObject: newContext.
			self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
			self storeStackPointerValue: argumentCount inContext: newContext.
			self storePointerUnchecked: CallerIndex ofObject: newContext withValue: activeContext.
			self internalNewActiveContext: newContext]
		ifFalse: [messageSelector := self specialSelector: 25 + argumentCount.
			self normalSend]! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 20:57'!
internalPush: object

	self longAtPointer: (localSP := localSP + self bytesPerWord) put: object.! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr (auto pragmas dtl 2010-09-26) 2/26/2003 14:05'!
internalQuickCheckForInterrupts
	"Internal version of quickCheckForInterrupts for use within jumps."

	<inline: true>
	((interruptCheckCounter := interruptCheckCounter - 1) <= 0) ifTrue: [
		self externalizeIPandSP.
		self checkForInterrupts.

		self browserPluginReturnIfNeeded.

		self internalizeIPandSP].
! !
!Interpreter methodsFor: 'contexts' stamp: 'ikp 6/10/2004 11:16'!
internalStackTop

	^ self longAtPointer: localSP! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 20:57'!
internalStackValue: offset

	^ self longAtPointer: localSP - (offset * self bytesPerWord)! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:05'!
internalStoreContextRegisters: activeCntx
	"The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."

	"InstructionPointer is a pointer variable equal to
	method oop + ip + self baseHeaderSize
		-1 for 0-based addressing of fetchByte
		-1 because it gets incremented BEFORE fetching currentByte"

	<inline: true>
	self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: 
			((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))).
	self storePointerUnchecked: StackPointerIndex		  ofObject: activeCntx
		withValue: (self integerObjectOf:
			((((self oopForPointer: localSP) - (activeCntx + self baseHeaderSize)) >> self shiftForWord) - TempFrameStart + 1)).
! !
!Interpreter methodsFor: 'utilities' stamp: 'ikp 6/10/2004 11:08'!
internalizeIPandSP
	"Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop."

	localIP := self pointerForOop: instructionPointer.
	localSP := self pointerForOop: stackPointer.
	localHomeContext := theHomeContext.
! !
!Interpreter methodsFor: 'interpreter shell' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 22:00'!
interpret
	"This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently."

	<inline: false> "should not be inlined into any senders"
	"record entry time when running as a browser plug-in"
	self browserPluginInitialiseIfNeeded.
	self initializeImageFormatVersionIfNeeded.
	self internalizeIPandSP.
	self fetchNextBytecode.
	[true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable].
	localIP := localIP - 1.  "undo the pre-increment of IP before returning"
	self externalizeIPandSP.
! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/22/2004 14:20'!
interruptCheckForced
	"was this interrupt check forced by outside code?"
	^interruptCheckCounter < -100! !
!Interpreter methodsFor: 'plugin support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 17:43'!
ioFilename: aCharBuffer fromString: aFilenameString ofLength: filenameLength resolveAliases: aBoolean
"the vm has to convert aFilenameString via any canonicalization and char-mapping and put the result in aCharBuffer.
Note the resolveAliases flag - this is an awful artefact of OSX and Apples demented alias handling. When opening a file, the flag must be  true, when closing or renaming it must be false. Sigh."
	<var: #aCharBuffer type: 'char *'>
	<var: #aFilenameString type: 'char *'>
	self cCode:'sqGetFilenameFromString(aCharBuffer, aFilenameString, filenameLength, aBoolean)'
		inSmalltalk:["this doesn't translate well in Smalltalk since we know how long strings are rather than considering them terminated by a 0 char. Do the best we can"
			aCharBuffer replaceFrom:1 to: filenameLength with: aFilenameString]! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'tpr (auto pragmas dtl 2010-09-26) 12/29/2005 16:26'!
is: oop KindOf: className
	"Support for external primitives."
	| oopClass |
	<var: #className type: 'char *'>
	oopClass := self fetchClassOf: oop.
	[oopClass == nilObj] whileFalse:[
		(self classNameOf: oopClass Is: className) ifTrue:[^true].
		oopClass := self superclassOf: oopClass].
	^false! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'tpr (auto pragmas dtl 2010-09-26) 12/29/2005 16:26'!
is: oop MemberOf: className
	"Support for external primitives"
	| oopClass |
	<var: #className type: 'char *'>
	oopClass := self fetchClassOf: oop.
	^(self classNameOf: oopClass Is: className)! !
!Interpreter methodsFor: 'plugin support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 22:20'!
isBigEnder
	"Answer true (non-zero) if running on a big endian machine."
	| endianness anInt cString len i |
	<var: 'cString' type: 'char *'>
	<var: 'endianness' declareC: 'static sqInt endianness = -1'>
	(endianness == -1) ifFalse: [^ endianness]. "answer cached value"
	len := self cCode: 'sizeof(anInt)'
			inSmalltalk: [^ (Smalltalk endianness == #little) not].
	cString := self cCode: '(char *) &anInt' inSmalltalk: [].
	i := 0.
	[i < len] whileTrue:
		[cString at: i put: i.
		i := i + 1].
	endianness :=  anInt bitAnd: 255.
	^ endianness
! !
!Interpreter methodsFor: 'contexts' stamp: 'eem (auto pragmas 12/08) 5/29/2008 11:53'!
isContext: oop
	<inline: true>
	^(self isNonIntegerObject: oop) and: [self isContextHeader: (self baseHeader: oop)]! !
!Interpreter methodsFor: 'contexts' stamp: 'JMM (auto pragmas dtl 2010-09-26) 12/4/2002 13:27'!
isContextHeader: aHeader
	<inline: true>
	^ ((aHeader >> 12) bitAnd: 16r1F) = 13			"MethodContext"
		or: [((aHeader >> 12) bitAnd: 16r1F) = 14		"BlockContext"
		or: [((aHeader >> 12) bitAnd: 16r1F) = 4]]	"PseudoContext"! !
!Interpreter methodsFor: 'process primitive support'!
isEmptyList: aLinkedList

	^ (self fetchPointer: FirstLinkIndex ofObject: aLinkedList) = nilObj! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'ar 10/7/1998 18:13'!
isFloatObject: oop
	^(self fetchClassOf: oop) == self classFloat! !
!Interpreter methodsFor: 'compiled methods' stamp: 'ar (auto pragmas 12/08) 3/6/2001 15:04'!
isHandlerMarked: aContext
	"Is this a MethodContext whose meth has a primitive number of 199?"
	| header meth pIndex |
	"NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed.
	NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
	<inline: true>
	header := self baseHeader: aContext.
	(self isMethodContextHeader: header) ifFalse: [^false].
	meth := self fetchPointer: MethodIndex ofObject: aContext.
	pIndex := self primitiveIndexOf: meth.
	^pIndex == 199
! !
!Interpreter methodsFor: 'object format' stamp: 'ar 10/7/1998 18:13'!
isIndexable: oop
	^(self formatOf: oop) >= 2! !
!Interpreter methodsFor: 'contexts' stamp: 'di (auto pragmas 12/08) 12/27/1998 23:32'!
isMethodContextHeader: aHeader
	<inline: true>
	^ ((aHeader >> 12) bitAnd: 16r1F) = 14! !
!Interpreter methodsFor: 'compiled methods' stamp: 'ar (auto pragmas 12/08) 3/6/2001 15:04'!
isUnwindMarked: aContext
	"Is this a MethodContext whose meth has a primitive number of 198?"
	| header meth pIndex |
	"NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed
	NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
	<inline: true>
	header := self baseHeader: aContext.
	(self isMethodContextHeader: header) ifFalse: [^false].
	meth := self fetchPointer: MethodIndex ofObject: aContext.
	pIndex := self primitiveIndexOf: meth.
	^pIndex == 198
! !
!Interpreter methodsFor: 'jump bytecodes' stamp: 'ikp 6/10/2004 11:01'!
jump: offset

	localIP := localIP + offset + 1.
	currentBytecode := self byteAtPointer: localIP.
! !
!Interpreter methodsFor: 'jump bytecodes' stamp: 'tpr 3/24/2004 18:36'!
jumplfFalseBy: offset 
	| boolean |
	boolean := self internalStackTop.
	boolean = falseObj
		ifTrue: [self jump: offset]
		ifFalse: [boolean = trueObj
				ifFalse: [messageSelector := self splObj: SelectorMustBeBoolean.
					argumentCount := 0.
					^ self normalSend].
			self fetchNextBytecode].
	self internalPop: 1! !
!Interpreter methodsFor: 'jump bytecodes' stamp: 'tpr 3/24/2004 18:36'!
jumplfTrueBy: offset 
	| boolean |
	boolean := self internalStackTop.
	boolean = trueObj
		ifTrue: [self jump: offset]
		ifFalse: [boolean = falseObj
				ifFalse: [messageSelector := self splObj: SelectorMustBeBoolean.
					argumentCount := 0.
					^ self normalSend].
			self fetchNextBytecode].
	self internalPop: 1! !
!Interpreter methodsFor: 'array primitive support' stamp: 'di (auto pragmas dtl 2010-09-26) 11/29/1998 21:24'!
lengthOf: oop
	"Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."

	| header |
	<inline: true>
	header := self baseHeader: oop.
	^ self lengthOf: oop baseHeader: header format: ((header >> 8) bitAnd: 16rF)! !
!Interpreter methodsFor: 'array primitive support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 12:14'!
lengthOf: oop baseHeader: hdr format: fmt
	"Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."

	| sz |
	<inline: true>
	(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ]
		ifFalse: [ sz := (hdr bitAnd: self sizeMask)].
	sz := sz - (hdr bitAnd: self size4Bit).
	fmt <= 4
		ifTrue: [ ^ (sz - self baseHeaderSize) >> self shiftForWord "words"].
	fmt < 8
		ifTrue: [ ^ (sz - self baseHeaderSize) >> 2 "32-bit longs"]
		ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3) "bytes"]! !
!Interpreter methodsFor: 'compiled methods' stamp: 'tpr 3/24/2004 21:07'!
literal: offset
	^self literal: offset ofMethod: method! !
!Interpreter methodsFor: 'compiled methods'!
literal: offset ofMethod: methodPointer

	^ self fetchPointer: offset + LiteralStart ofObject: methodPointer
! !
!Interpreter methodsFor: 'compiled methods'!
literalCountOf: methodPointer
	^self literalCountOfHeader: (self headerOf: methodPointer)! !
!Interpreter methodsFor: 'compiled methods'!
literalCountOfHeader: headerPointer
	^ (headerPointer >> 10) bitAnd: 16rFF! !
!Interpreter methodsFor: 'bitblt support' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:26'!
loadBitBltFrom: bb
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin:=loadBitBltFrom
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"
	| fn |
	<var: #fn type: 'void *'>
	fn := self ioLoadFunction: 'loadBitBltFrom' From: 'BitBltPlugin'.
	fn = 0 ifTrue: [^self primitiveFail].
	^self cCode: '((sqInt (*)(sqInt))fn)(bb)'! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl (auto pragmas dtl 2010-09-26) 9/11/2008 22:44'!
loadFloatOrIntFrom: floatOrInt
	"If floatOrInt is an integer, then convert it to a C double float and return it.
	If it is a Float, then load its value and return it.
	Otherwise fail -- ie return with successFlag set to false."

	<inline: true>
	<returnTypeC: 'double'>

	(self isIntegerObject: floatOrInt) ifTrue:
		[^ (self integerValueOf: floatOrInt) asFloat].
	(self fetchClassOfNonInt: floatOrInt) = (self splObj: ClassFloat)
		ifTrue: [^ self floatValueOf: floatOrInt].
	successFlag := false! !
!Interpreter methodsFor: 'initialization' stamp: 'dtl 4/22/2007 23:29'!
loadInitialContext

	| sched proc |
	sched := self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation).
	proc := self fetchPointer: ActiveProcessIndex ofObject: sched.
	activeContext := self fetchPointer: SuspendedContextIndex ofObject: proc.
	(self oop: activeContext isLessThan: youngStart) ifTrue: [ self beRootIfOld: activeContext ].
	self fetchContextRegisters: activeContext.
	reclaimableContextCount := 0.! !
!Interpreter methodsFor: 'jump bytecodes' stamp: 'tpr 3/24/2004 18:37'!
longJumpIfFalse

	self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! !
!Interpreter methodsFor: 'jump bytecodes' stamp: 'tpr 3/24/2004 18:37'!
longJumpIfTrue

	self jumplfTrueBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! !
!Interpreter methodsFor: 'jump bytecodes' stamp: 'tpr 3/24/2004 18:37'!
longUnconditionalJump

	| offset |
	offset := (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte.
	localIP := localIP + offset.
	offset < 0 ifTrue: [
		"backward jump means we're in a loop; check for possible interrupts"
		self internalQuickCheckForInterrupts.
	].
	self fetchNextBytecode
! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp (auto pragmas dtl 2010-09-26) 3/26/2005 13:36'!
lookupInMethodCacheSel: selector class: class
	"This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveIndex' and return true. Otherwise, return false."
	"About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."
	"WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache."

	| hash probe |
	<inline: true>
	hash := selector bitXor: class.  "shift drops two low-order zeros from addresses"

	probe := hash bitAnd: MethodCacheMask.  "first probe"
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod := methodCache at: probe + MethodCacheMethod.
			primitiveIndex := methodCache at: probe + MethodCachePrim.
			newNativeMethod := methodCache at: probe + MethodCacheNative.
			primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void *'.
			^ true	"found entry in cache; done"].

	probe := (hash >> 1) bitAnd: MethodCacheMask.  "second probe"
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod := methodCache at: probe + MethodCacheMethod.
			primitiveIndex := methodCache at: probe + MethodCachePrim.
			newNativeMethod := methodCache at: probe + MethodCacheNative.
			primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void *'.
			^ true	"found entry in cache; done"].

	probe := (hash >> 2) bitAnd: MethodCacheMask.
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod := methodCache at: probe + MethodCacheMethod.
			primitiveIndex := methodCache at: probe + MethodCachePrim.
			newNativeMethod := methodCache at: probe + MethodCacheNative.
			primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void *'.
			^ true	"found entry in cache; done"].

	^ false
! !
!Interpreter methodsFor: 'message sending' stamp: 'ikp (auto pragmas dtl 2010-09-26) 10/24/1999 03:58'!
lookupMethodInClass: class
	| currentClass dictionary found rclass |
	<inline: false>

	currentClass := class.
	[currentClass ~= nilObj]
		whileTrue:
		[dictionary := self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
		dictionary = nilObj ifTrue:
			["MethodDict pointer is nil (hopefully due a swapped out stub)
				-- raise exception #cannotInterpret:."
			self pushRemappableOop: currentClass.  "may cause GC!!"
			self createActualMessageTo: class.
			currentClass := self popRemappableOop.
			messageSelector := self splObj: SelectorCannotInterpret.
			^ self lookupMethodInClass: (self superclassOf: currentClass)].
		found := self lookupMethodInDictionary: dictionary.
		found ifTrue: [^ methodClass := currentClass].
		currentClass := self superclassOf: currentClass].

	"Could not find #doesNotUnderstand: -- unrecoverable error."
	messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue:
		[self error: 'Recursive not understood error encountered'].

	"Cound not find a normal message -- raise exception #doesNotUnderstand:"
	self pushRemappableOop: class.  "may cause GC!!"
	self createActualMessageTo: class.
	rclass := self popRemappableOop.
	messageSelector := self splObj: SelectorDoesNotUnderstand.
	^ self lookupMethodInClass: rclass! !
!Interpreter methodsFor: 'message sending' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 21:17'!
lookupMethodInDictionary: dictionary 
	"This method lookup tolerates integers as Dictionary keys to 
	support execution of images in which Symbols have been 
	compacted out"
	| length index mask wrapAround nextSelector methodArray |
	<inline: true>
	length := self fetchWordLengthOf: dictionary.
	mask := length - SelectorStart - 1.
	(self isIntegerObject: messageSelector)
		ifTrue: [index := (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart]
		ifFalse: [index := (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].

	"It is assumed that there are some nils in this dictionary, and search will 
	stop when one is encountered. However, if there are no nils, then wrapAround 
	will be detected the second time the loop gets to the end of the table."
	wrapAround := false.
	[true]
		whileTrue: [nextSelector := self fetchPointer: index ofObject: dictionary.
			nextSelector = nilObj ifTrue: [^ false].
			nextSelector = messageSelector
				ifTrue: [methodArray := self fetchPointer: MethodArrayIndex ofObject: dictionary.
					newMethod := self fetchPointer: index - SelectorStart ofObject: methodArray.
					"Check if newMethod is a CompiledMethod."
					(self isCompiledMethod: newMethod)
						ifTrue: [primitiveIndex := self primitiveIndexOf: newMethod.
							primitiveIndex > MaxPrimitiveIndex
								ifTrue: ["If primitiveIndex is out of range, set to zero before putting in 
									cache. This is equiv to primFail, and avoids the need to check on 
									every send."
									primitiveIndex := 0]]
						ifFalse: ["indicate that this is no compiled method - use primitiveInvokeObjectAsMethod"
							primitiveIndex := 248].
					^ true].
			index := index + 1.
			index = length
				ifTrue: [wrapAround
						ifTrue: [^ false].
					wrapAround := true.
					index := SelectorStart]]! !
!Interpreter methodsFor: 'alien support' stamp: 'eem (auto pragmas dtl 2010-09-26) 11/16/2007 15:55'!
lookupMethodNoMNUEtcInClass: class
	"Lookup.  Answer false on failure father than performing MNU processing etc."
	| currentClass dictionary |
	<inline: true>

	currentClass := class.
	[currentClass ~= nilObj] whileTrue:
		[dictionary := self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
		(dictionary ~= nilObj
		 and: [self lookupMethodInDictionary: dictionary]) ifTrue:
			[methodClass := currentClass.
			 ^true].
		currentClass := self superclassOf: currentClass].

	^false! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl 5/18/2010 20:58'!
makePointwithxValue: xValue yValue: yValue
"make a Point xValue@yValue.
We know both will be integers so no value nor root checking is needed"
	| pointResult |
	pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3 * self bytesPerWord.
	self storePointerUnchecked: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).
	self storePointerUnchecked: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).
	^ pointResult! !
!Interpreter methodsFor: 'object memory support' stamp: 'ar 1/16/2007 10:48'!
mapInterpreterOops
	"Map all oops in the interpreter's state to their new values 
	during garbage collection or a become: operation."
	"Assume: All traced variables contain valid oops."
	| oop |
	nilObj := self remap: nilObj.
	falseObj := self remap: falseObj.
	trueObj := self remap: trueObj.
	specialObjectsOop := self remap: specialObjectsOop.
	compilerInitialized
		ifFalse: [stackPointer := stackPointer - activeContext. "*rel to active"
			activeContext := self remap: activeContext.
			stackPointer := stackPointer + activeContext. "*rel to active"
			theHomeContext := self remap: theHomeContext].
	instructionPointer := instructionPointer - method. "*rel to method"
	method := self remap: method.
	instructionPointer := instructionPointer + method. "*rel to method"
	receiver := self remap: receiver.
	messageSelector := self remap: messageSelector.
	newMethod := self remap: newMethod.
	methodClass := self remap: methodClass.
	lkupClass := self remap: lkupClass.
	receiverClass := self remap: receiverClass.
	1 to: remapBufferCount do: [:i | 
			oop := remapBuffer at: i.
			(self isIntegerObject: oop)
				ifFalse: [remapBuffer at: i put: (self remap: oop)]].

	"Callback support - trace suspended callback list"
	1 to: jmpDepth do:[:i|
		oop := suspendedCallbacks at: i.
		(self isIntegerObject: oop) 
			ifFalse:[suspendedCallbacks at: i put: (self remap: oop)].
		oop := suspendedMethods at: i.
		(self isIntegerObject: oop) 
			ifFalse:[suspendedMethods at: i put: (self remap: oop)].
	].
! !
!Interpreter methodsFor: 'object memory support' stamp: 'ar 1/16/2007 10:47'!
markAndTraceInterpreterOops
	"Mark and trace all oops in the interpreter's state."
	"Assume: All traced variables contain valid oops."
	| oop |
	self compilerMarkHook.
	self markAndTrace: specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
	compilerInitialized
		ifTrue: [self markAndTrace: receiver.
			self markAndTrace: method]
		ifFalse: [self markAndTrace: activeContext].
	self markAndTrace: messageSelector.
	self markAndTrace: newMethod.
	self markAndTrace: methodClass.
	self markAndTrace: lkupClass.
	self markAndTrace: receiverClass.
	1 to: remapBufferCount do: [:i | 
			oop := remapBuffer at: i.
			(self isIntegerObject: oop) ifFalse: [self markAndTrace: oop]].

	"Callback support - trace suspended callback list"
	1 to: jmpDepth do:[:i|
		oop := suspendedCallbacks at: i.
		(self isIntegerObject: oop) ifFalse:[self markAndTrace: oop].
		oop := suspendedMethods at: i.
		(self isIntegerObject: oop) ifFalse:[self markAndTrace: oop].
	].
! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'ar 10/7/1998 18:38'!
methodArgumentCount
	^argumentCount! !
!Interpreter methodsFor: 'compiled methods' stamp: 'tpr 3/24/2004 21:08'!
methodClassOf: methodPointer

	^ self fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'ar 10/7/1998 18:39'!
methodPrimitiveIndex
	^primitiveIndex! !
!Interpreter methodsFor: 'initialization' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 21:22'!
moduleUnloaded: aModuleName 
	"The module with the given name was just unloaded. 
	Make sure we have no dangling references."
	<export: true>
	<var: #aModuleName type: 'char *'>
	(aModuleName strcmp: 'SurfacePlugin') = 0
		ifTrue: ["Surface plugin went away. Should never happen. But  then, who knows"
			showSurfaceFn := 0]! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 4/22/2007 23:29'!
newActiveContext: aContext
	"Note: internalNewActiveContext: should track changes to this method."

	self storeContextRegisters: activeContext.
	(self oop: aContext isLessThan: youngStart) ifTrue: [ self beRootIfOld: aContext ].
	activeContext := aContext.
	self fetchContextRegisters: aContext.! !
!Interpreter methodsFor: 'object format' stamp: 'ar (auto pragmas dtl 2010-09-26) 11/16/2003 01:15'!
nonWeakFieldsOf: oop
	"Return the number of non-weak fields in oop (i.e. the number of fixed fields).
	Note: The following is copied from fixedFieldsOf:format:length: since we do know
	the format of the oop (e.g. format = 4) and thus don't need the length."
	| class classFormat |
	<inline: false> "No need to inline - we won't call this often"

	(self isWeakNonInt: oop) ifFalse:[self error:'Called fixedFieldsOfWeak: with a non-weak oop'].

	"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
	class := self fetchClassOf: oop.
	classFormat := self formatOfClass: class.
	^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1
! !
!Interpreter methodsFor: 'message sending' stamp: 'ar (auto pragmas dtl 2010-09-26) 7/6/2003 22:19'!
normalSend
	"Send a message, starting lookup with the receiver's class."
	"Assume: messageSelector and argumentCount have been set, and that 
	the receiver and arguments have been pushed onto the stack,"
	"Note: This method is inlined into the interpreter dispatch loop."
	| rcvr |
	<inline: true>
	self sharedCodeNamed: 'normalSend' inCase: 131.
	rcvr := self internalStackValue: argumentCount.
	lkupClass := self fetchClassOf: rcvr.
	receiverClass := lkupClass.
	self commonSend.! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 10/6/2010 20:24'!
normalizeFloatOrderingInImage
	"Float objects were saved in platform word ordering. Reorder them into the
	traditional object format."

	<inline: false>
	<var: #floatData type: 'unsigned int *'>
	<var: #val type: 'unsigned int'>
	self isBigEnder
		ifFalse: [ | oop | "Swap words within Float objects, taking them out of native platform ordering"
				oop := self firstAccessibleObject.
				[oop = nil] whileFalse: [ | val |
					(self isFreeObject: oop) ifFalse: [
						(self fetchClassOf: oop) = self classFloat
							ifTrue: [ | floatData |
								floatData := self cCoerce: (self firstIndexableField: oop) to: 'unsigned int *'.
								val := floatData at: 0.
								floatData at: 0 put: (floatData at: 1).
								floatData at: 1 put: val].
						oop := self accessibleObjectAfter: oop]]]
! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:08'!
nullCompilerHook
	"This should never be called: either the compiler is uninitialised (in which case the hooks should never be reached) or the compiler initialisation should have replaced all the hook with their external implementations."

	self error: 'uninitialised compiler hook called'.
	^false! !
!Interpreter methodsFor: 'debug support'!
okayActiveProcessStack

	| cntxt |
	cntxt := activeContext.	
	[cntxt = nilObj] whileFalse: [
		self okayFields: cntxt.
		cntxt := (self fetchPointer: SenderIndex ofObject: cntxt).
	].! !
!Interpreter methodsFor: 'debug support' stamp: 'di 2/15/2001 22:33'!
okayFields: oop
	"If this is a pointers object, check that its fields are all okay oops."

	| i fieldOop c |
	(oop = nil or: [oop = 0]) ifTrue: [ ^true ].
	(self isIntegerObject: oop) ifTrue: [ ^true ].
	self okayOop: oop.
	self oopHasOkayClass: oop.
	(self isPointers: oop) ifFalse: [ ^true ].
	c := self fetchClassOf: oop.
	(c = (self splObj: ClassMethodContext)
		or: [c = (self splObj: ClassBlockContext)])
		ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
		ifFalse: [i := (self lengthOf: oop) - 1].
	[i >= 0] whileTrue: [
		fieldOop := self fetchPointer: i ofObject: oop.
		(self isIntegerObject: fieldOop) ifFalse: [
			self okayOop: fieldOop.
			self oopHasOkayClass: fieldOop.
		].
		i := i - 1.
	].! !
!Interpreter methodsFor: 'debug support'!
okayInterpreterObjects

	| oopOrZero oop |
	self okayFields: nilObj.
	self okayFields: falseObj.
	self okayFields: trueObj.
	self okayFields: specialObjectsOop.
	self okayFields: activeContext.
	self okayFields: method.
	self okayFields: receiver.
	self okayFields: theHomeContext.
	self okayFields: messageSelector.
	self okayFields: newMethod.
	self okayFields: lkupClass.
	0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i |
		oopOrZero := methodCache at: i + MethodCacheSelector.
		oopOrZero = 0 ifFalse: [
			self okayFields: (methodCache at: i + MethodCacheSelector).
			self okayFields: (methodCache at: i + MethodCacheClass).
			self okayFields: (methodCache at: i + MethodCacheMethod).
		].
	].
	1 to: remapBufferCount do: [ :i |
		oop := remapBuffer at: i.
		(self isIntegerObject: oop) ifFalse: [
			self okayFields: oop.
		].
	].
	self okayActiveProcessStack.! !
!Interpreter methodsFor: 'debug support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 12:38'!
okayOop: signedOop
	"Verify that the given oop is legitimate. Check address, header, and size but not class."

	| sz type fmt unusedBit oop |
	<var: #oop type: 'usqInt'>
	oop := self cCoerce: signedOop to: 'usqInt'.

	"address and size checks"
	(self isIntegerObject: oop) ifTrue: [ ^true ].
	(oop < endOfMemory)
		ifFalse: [ self error: 'oop is not a valid address' ].
	((oop \\ self bytesPerWord) = 0)
		ifFalse: [ self error: 'oop is not a word-aligned address' ].
	sz := self sizeBitsOf: oop.
	(oop + sz) < endOfMemory
		ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ].

	"header type checks"
	type := self headerType: oop.
	type = HeaderTypeFree
		ifTrue:  [ self error: 'oop is a free chunk, not an object' ].
	type = HeaderTypeShort ifTrue: [
		(((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0
			ifTrue:  [ self error: 'cannot have zero compact class field in a short header' ].
	].
	type = HeaderTypeClass ifTrue: [
		((oop >= self bytesPerWord) and: [(self headerType: oop - self bytesPerWord) = type])
			ifFalse: [ self error: 'class header word has wrong type' ].
	].
	type = HeaderTypeSizeAndClass ifTrue: [
		((oop >= (self bytesPerWord * 2)) and:
		 [(self headerType: oop - (self bytesPerWord * 2)) = type and:
		 [(self headerType: oop - self bytesPerWord) = type]])
			ifFalse: [ self error: 'class header word has wrong type' ].
	].

	"format check"
	fmt := self formatOf: oop.
	((fmt = 5) | (fmt = 7))
		ifTrue:  [ self error: 'oop has an unknown format type' ].

	"mark and root bit checks"
	unusedBit := 16r20000000.
	self bytesPerWord = 8
		ifTrue:
			[unusedBit := unusedBit << 16.
			 unusedBit := unusedBit << 16].
	((self longAt: oop) bitAnd: unusedBit) = 0
		ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ].
"xxx
	((self longAt: oop) bitAnd: MarkBit) = 0
		ifFalse: [ self error: 'mark bit should not be set except during GC' ].
xxx"
	(((self longAt: oop) bitAnd: self rootBit) = 1 and:
	 [oop >= youngStart])
		ifTrue: [ self error: 'root bit is set in a young object' ].
	^true
! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 10/5/2010 22:21'!
oldFormatFullScreenFlag: flagsWord
	"The full screen flags word in the image header file was originally defined as
	a boolean (low order bit of the word set for true). In more recent usage with
	StackInterpreter, the remaining bits are allocated for other purposes. This
	interpreter does not use the new bit definitions, and should clear the bits
	before saving the image."

	^ flagsWord bitAnd: 1! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'dtl 9/26/2010 11:32'!
oopHasAcceptableClass: signedOop
	"Similar to oopHasOkayClass:, except that it only returns true or false."

	| oopClass formatMask behaviorFormatBits oopFormatBits oop |
	<var: #oop type: 'usqInt'>
	<var: #oopClass type: 'usqInt'>

	(self isIntegerObject: signedOop) ifTrue: [^ true].

	oop := self cCoerce: signedOop to: 'usqInt'.

	oop < endOfMemory ifFalse: [^ false].
	((oop \\ self bytesPerWord) = 0) ifFalse: [^ false].
	(oop + (self sizeBitsOf: oop)) < endOfMemory ifFalse: [^ false].
	oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'.

	(self isIntegerObject: oopClass) ifTrue: [^ false].
	(oopClass < endOfMemory) ifFalse: [^ false].
	((oopClass \\ self bytesPerWord) = 0) ifFalse: [^ false].
	(oopClass + (self sizeBitsOf: oopClass)) < endOfMemory ifFalse: [^ false].
	((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false].
	(self isBytes: oop)
		ifTrue: [ formatMask := 16rC00 ]  "ignore extra bytes size bits"
		ifFalse: [ formatMask := 16rF00 ].

	behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask.
	oopFormatBits := (self baseHeader: oop) bitAnd: formatMask.
	behaviorFormatBits = oopFormatBits ifFalse: [^ false].
	^ true! !
!Interpreter methodsFor: 'debug support' stamp: 'ikp (auto pragmas dtl 2010-09-26) 3/26/2005 21:06'!
oopHasOkayClass: signedOop
	"Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."

	| oop oopClass formatMask behaviorFormatBits oopFormatBits |
	<var: #oop type: 'usqInt'>
	<var: #oopClass type: 'usqInt'>

	oop := self cCoerce: signedOop to: 'usqInt'.
	self okayOop: oop.
	oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'.

	(self isIntegerObject: oopClass)
		ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].
	self okayOop: oopClass.
	((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3])
		ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].
	(self isBytes: oop)
		ifTrue: [ formatMask := 16rC00 ]  "ignore extra bytes size bits"
		ifFalse: [ formatMask := 16rF00 ].

	behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask.
	oopFormatBits := (self baseHeader: oop) bitAnd: formatMask.
	behaviorFormatBits = oopFormatBits
		ifFalse: [ self error: 'object and its class (behavior) formats differ' ].
	^true! !
!Interpreter methodsFor: 'contexts' stamp: 'di 11/30/1998 12:31'!
pop2AndPushIntegerIfOK: integerResult

	successFlag ifTrue:
		[(self isIntegerValue: integerResult)
			ifTrue: [self pop: 2 thenPush: (self integerObjectOf: integerResult)]
			ifFalse: [successFlag := false]]! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 20:59'!
pop: nItems
	"Note: May be called by translated primitive code."

	stackPointer := stackPointer - (nItems * self bytesPerWord).! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 20:59'!
pop: nItems thenPush: oop

	| sp |
	self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put: oop.
	stackPointer := sp.
! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 21:00'!
pop: nItems thenPushInteger: integerVal
"lots of places pop a few items off the stack and then push an integer. MAke it convenient"
	| sp |
	self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put:(self integerObjectOf: integerVal).
	stackPointer := sp.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:44'!
popFloat
	"Note: May be called by translated primitive code."

	| top result |
	<returnTypeC: 'double'>
	<var: #result type: 'double '>
	top := self popStack.
	self assertClassOf: top is: (self splObj: ClassFloat).
	successFlag ifTrue:
		[self cCode: '' inSmalltalk: [result := Float new: 2].
		self fetchFloatAt: top + self baseHeaderSize into: result].
	^ result! !
!Interpreter methodsFor: 'contexts' stamp: 'tpr 3/15/2004 20:00'!
popInteger
"returns 0 if the stackTop was not an integer value, plus sets successFlag false"
	| integerPointer |
	integerPointer := self popStack.
	^self checkedIntegerValueOf: integerPointer! !
!Interpreter methodsFor: 'contexts'!
popPos32BitInteger
	"May set successFlag, and return false if not valid"

	| top |
	top := self popStack.
	^ self positive32BitValueOf: top! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 21:00'!
popStack

	| top |
	top := self longAt: stackPointer.
	stackPointer := stackPointer - self bytesPerWord.
	^ top! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'!
popStackBytecode

	self fetchNextBytecode.
	self internalPop: 1.
! !
!Interpreter methodsFor: 'primitive support' stamp: 'dtl 5/18/2010 21:44'!
positive32BitIntegerFor: integerValue

	| newLargeInteger |
	"Note - integerValue is interpreted as POSITIVE, eg, as the result of
		Bitmap>at:, or integer>bitAnd:."
	integerValue >= 0
		ifTrue: [(self isIntegerValue: integerValue)
					ifTrue: [^ self integerObjectOf: integerValue]].

	self bytesPerWord = 4
	ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
			newLargeInteger := self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)
					sizeInBytes: self baseHeaderSize + 4]
	ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
			newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger)
					indexableSize: 4].
	self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
	self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
	self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
	self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
	^ newLargeInteger! !
!Interpreter methodsFor: 'primitive support'!
positive32BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a four-byte LargePositiveInteger."

	| sz value |
	(self isIntegerObject: oop) ifTrue: [
		value := self integerValueOf: oop.
		value < 0 ifTrue: [^ self primitiveFail].
		^ value].

	self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger).
	successFlag ifTrue: [
		sz := self lengthOf: oop.
		sz = 4 ifFalse: [^ self primitiveFail]].
	successFlag ifTrue: [
		^ (self fetchByte: 0 ofObject: oop) +
		  ((self fetchByte: 1 ofObject: oop) <<  8) +
		  ((self fetchByte: 2 ofObject: oop) << 16) +
		  ((self fetchByte: 3 ofObject: oop) << 24) ].! !
!Interpreter methodsFor: 'primitive support' stamp: 'ar (auto pragmas 12/08) 3/21/2008 20:40'!
positive64BitIntegerFor: integerValue

	| newLargeInteger value highWord sz |
	"Note - integerValue is interpreted as POSITIVE, eg, as the result of
		Bitmap>at:, or integer>bitAnd:."
	<var: 'integerValue' type: 'sqLong'>
 
	(self sizeof: integerValue) = 4 ifTrue: [^self positive32BitIntegerFor: integerValue].


	highWord := self cCode: 'integerValue >> 32'. "shift is coerced to usqInt otherwise"
	highWord = 0 ifTrue:[^self positive32BitIntegerFor: integerValue].
	sz := 5.
	(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
	(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
	(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
	newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger) indexableSize:  sz.
	0 to: sz-1 do: [:i |
		value := self cCode: '(integerValue >> (i * 8)) & 255'.
		self storeByte: i ofObject: newLargeInteger withValue: value].
	^ newLargeInteger
! !
!Interpreter methodsFor: 'primitive support' stamp: 'tpr (auto pragmas 12/08) 3/17/2005 17:47'!
positive64BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a eight-byte LargePositiveInteger."

	| sz szsqLong value  |
	<returnTypeC: 'sqLong'>
	<var: 'value' type: 'sqLong'>
	(self isIntegerObject: oop) ifTrue: [
		value := self integerValueOf: oop.
		value < 0 ifTrue: [^ self primitiveFail].
		^ value].

	self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger).
	successFlag ifFalse: [^ self primitiveFail].
	szsqLong := self cCode: 'sizeof(sqLong)'.
	sz := self lengthOf: oop.
	sz > szsqLong
		ifTrue: [^ self primitiveFail].
	value := 0.
	0 to: sz - 1 do: [:i |
		value := value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: 'sqLong') <<  (i*8))].
	^value.! !
!Interpreter methodsFor: 'object memory support' stamp: 'JMM 6/9/2007 15:36'!
postGCAction
	"Mark the active and home contexts as roots if old. This 
	allows the interpreter to use storePointerUnchecked to 
	store into them."

	compilerInitialized
		ifTrue: [self compilerPostGC]
		ifFalse: [(self oop: activeContext isLessThan: youngStart)
				ifTrue: [self beRootIfOld: activeContext].
			(self oop: theHomeContext isLessThan: youngStart)
				ifTrue: [self beRootIfOld: theHomeContext]].
	(self oop: (self sizeOfFree: freeBlock) isGreaterThan:  shrinkThreshold)
		ifTrue: ["Attempt to shrink memory after successfully 
			reclaiming lots of memory"
			self shrinkObjectMemory: (self sizeOfFree: freeBlock) - growHeadroom].
	
	self signalSemaphoreWithIndex: gcSemaphoreIndex.
! !
!Interpreter methodsFor: 'object memory support' stamp: 'tpr 3/24/2004 21:21'!
preGCAction: fullGCFlag

	compilerInitialized
		ifTrue: [self compilerPreGC: fullGCFlag]
		ifFalse: [self storeContextRegisters: activeContext].! !
!Interpreter methodsFor: 'primitive support'!
primIndex
	^ primitiveIndex! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/30/1998 10:13'!
primitiveAdd

	self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) + (self stackIntegerValue: 0)! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:37'!
primitiveAddLargeIntegers
	"Primitive arithmetic operations for large integers in 64 bit range"
	| integerRcvr integerArg result oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'result' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).
	successFlag ifFalse:[^nil].

	"Compute the preliminary result (which may overflow)"
	result := integerRcvr + integerArg.

	"Now check overflow conditions. First is whether rcvr and arg are of the same sign.
	If they are we need to check for overflow more carefully."
	(integerRcvr bitXor: integerArg) < 0 ifFalse:[
		"Second is whether rcvr and result are of the same sign. If not, we have an overflow."
		(integerRcvr bitXor: result) < 0 ifTrue:[self primitiveFail]].
			
	successFlag ifFalse:[^nil].

	oopResult := self signed64BitIntegerFor: result.
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'eem 7/16/2010 19:57'!
primitiveAdoptInstance
	"Primitive. Change the class of the argument to make it an instance of the receiver
	 given that the format of the receiver matches the format of the argument's class.
	 Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a
	 compact class and the argument isn't, or when the argument's class is compact and
	 the receiver isn't, or when the format of the receiver is different from the format of
	 the argument's class, or when the arguments class is fixed and the receiver's size
	 differs from the size that an instance of the argument's class should have."
	| rcvr arg err |

	arg := self stackObjectValue: 0.
	rcvr := self stackObjectValue: 1.

	err := self changeClassOf: arg to: rcvr.
	err = 0
		ifTrue: ["Flush at cache because rcvr's class has changed."
				self flushAtCache.
				self pop: self methodArgumentCount]
		ifFalse: [self primitiveFail].
	^nil! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:26'!
primitiveArctan

	| rcvr |
	<var: #rcvr type: 'double '>
	rcvr := self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'atan(rcvr)' inSmalltalk: [rcvr arcTan])]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'brp 9/19/2003 16:08'!
primitiveArrayBecome
	"We must flush the method cache here, to eliminate stale references
	to mutated classes and/or selectors."

	| arg rcvr |
	arg := self stackTop.
	rcvr := self stackValue: 1.
	self success: (self become: rcvr with: arg twoWay: true copyHash: true).
	successFlag ifTrue: [ self pop: 1 ].! !
!Interpreter methodsFor: 'object access primitives' stamp: 'brp 9/26/2003 08:00'!
primitiveArrayBecomeOneWay
	"We must flush the method cache here, to eliminate stale references
	to mutated classes and/or selectors."

	| arg rcvr |
	arg := self stackTop.
	rcvr := self stackValue: 1.
	self success: (self become: rcvr with: arg twoWay: false copyHash: true).
	successFlag ifTrue: [ self pop: 1 ].! !
!Interpreter methodsFor: 'object access primitives' stamp: 'brp 9/26/2003 08:08'!
primitiveArrayBecomeOneWayCopyHash
	"Similar to primitiveArrayBecomeOneWay but accepts a third argument whether to copy
	the receiver's identity hash over the argument's identity hash."

	| copyHashFlag arg rcvr |
	copyHashFlag := self booleanValueOf: (self stackTop).
	arg := self stackValue: 1.
	rcvr := self stackValue: 2.
	self success: (self become: rcvr with: arg twoWay: false copyHash: copyHashFlag).
	successFlag ifTrue: [ self pop: 2 ].! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr 3/23/2004 17:21'!
primitiveAsFloat
	| arg |
	arg := self popInteger.
	successFlag
		ifTrue: [ self pushFloat: (self cCode: '((double) arg)' inSmalltalk: [arg asFloat]) ]
		ifFalse: [ self unPop: 1 ].! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 5/13/2005 10:17'!
primitiveAsOop
	| thisReceiver |
	thisReceiver := self stackTop.
	self success: (self isIntegerObject: thisReceiver) not.
	successFlag
		ifTrue: [self pop:1 thenPushInteger: (self hashBitsOf: thisReceiver)]! !
!Interpreter methodsFor: 'array primitives'!
primitiveAt

	self commonAt: false.! !
!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/11/1998 10:15'!
primitiveAtEnd
	| stream index limit |
	stream := self popStack.
	successFlag := ((self isPointers: stream)
			and: [(self lengthOf: stream) >= (StreamReadLimitIndex+1)]).
 	successFlag ifTrue: [
		index := self fetchInteger: StreamIndexIndex ofObject: stream.
		limit := self fetchInteger: StreamReadLimitIndex ofObject: stream].
 	successFlag
		ifTrue: [self pushBool: (index >= limit)]
		ifFalse: [self unPop: 1].! !
!Interpreter methodsFor: 'array primitives'!
primitiveAtPut

	self commonAtPut: false.! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'dtl 5/18/2010 21:44'!
primitiveBeCursor
	"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."

	| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |

self flag: #Dan.  "This is disabled until we convert bitmaps appropriately"
self bytesPerWord = 8 ifTrue: [^ self pop: argumentCount].

	argumentCount = 0 ifTrue: [
		cursorObj := self stackTop.
		maskBitsIndex := nil].
	argumentCount = 1 ifTrue: [
		cursorObj := self stackValue: 1.
		maskObj := self stackTop].
	self success: (argumentCount < 2).

	self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
	successFlag ifTrue: [
		bitsObj := self fetchPointer: 0 ofObject: cursorObj.
		extentX := self fetchInteger: 1 ofObject: cursorObj.
		extentY := self fetchInteger: 2 ofObject: cursorObj.
		depth := self fetchInteger: 3 ofObject: cursorObj.
		offsetObj := self fetchPointer: 4 ofObject: cursorObj].
		self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).

	successFlag ifTrue: [
		offsetX := self fetchInteger: 0 ofObject: offsetObj.
		offsetY := self fetchInteger: 1 ofObject: offsetObj.

		(argumentCount = 0 and: [depth = 32])
			ifTrue: [
				"Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51"
				self success: ((extentX > 0) and: [extentY > 0]).
				self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]).
				self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]).
				cursorBitsIndex := bitsObj + self baseHeaderSize.
				self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]).
				self cCode: '' inSmalltalk:
					[ourCursor := Cursor
						extent: extentX @ extentY
						depth: 32
						fromArray: ((1 to: extentX * extentY) collect: [:i |
							self fetchLong32: i-1 ofObject: bitsObj])
						offset: offsetX  @ offsetY]]
			ifFalse: [
				self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
				self success: ((offsetX >= -16) and: [offsetX <= 0]).
				self success: ((offsetY >= -16) and: [offsetY <= 0]).
				self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
				cursorBitsIndex := bitsObj + self baseHeaderSize.
				self cCode: '' inSmalltalk:
					[ourCursor := Cursor
						extent: extentX @ extentY
						fromArray: ((1 to: 16) collect: [:i |
							((self fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])
						offset: offsetX  @ offsetY]]].

	argumentCount = 1 ifTrue: [
		self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
		successFlag ifTrue: [
			bitsObj := self fetchPointer: 0 ofObject: maskObj.
			extentX := self fetchInteger: 1 ofObject: maskObj.
			extentY := self fetchInteger: 2 ofObject: maskObj.
			depth := self fetchInteger: 3 ofObject: maskObj].

		successFlag ifTrue: [
			self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
			self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
			maskBitsIndex := bitsObj + self baseHeaderSize]].


	successFlag ifTrue: [
		argumentCount = 0
			ifTrue: [
				depth = 32
					ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)'
						inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor])	
							ifFalse: [^self success: false]]
					ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
						inSmalltalk: [ourCursor show]]]
			ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
						inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler"
									ourCursor show]].
		self pop: argumentCount]! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:13'!
primitiveBeDisplay
	"Record the system Display object in the specialObjectsTable."
	| rcvr |
	rcvr := self stackTop.
	self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
	successFlag ifTrue: [self storePointer: TheDisplay ofObject: specialObjectsOop withValue: rcvr]! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:13'!
primitiveBeep
"make the basic beep noise"
	self ioBeep.! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/29/1998 12:02'!
primitiveBitAnd
	| integerReceiver integerArgument |
	integerArgument := self popPos32BitInteger.
	integerReceiver := self popPos32BitInteger.
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor:
					(integerReceiver bitAnd: integerArgument))]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:37'!
primitiveBitAndLargeIntegers
	"Primitive logical operations for large integers in 64 bit range"
	| integerRcvr integerArg oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self positive64BitValueOf: (self stackValue: 0).
	integerRcvr := self positive64BitValueOf: (self stackValue: 1).
	successFlag ifFalse:[^nil].

	oopResult := self positive64BitIntegerFor: (integerRcvr bitAnd: integerArg).
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/29/1998 12:02'!
primitiveBitOr
	| integerReceiver integerArgument |
	integerArgument := self popPos32BitInteger.
	integerReceiver := self popPos32BitInteger.
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor:
					(integerReceiver bitOr: integerArgument))]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:37'!
primitiveBitOrLargeIntegers
	"Primitive logical operations for large integers in 64 bit range"
	| integerRcvr integerArg oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self positive64BitValueOf: (self stackValue: 0).
	integerRcvr := self positive64BitValueOf: (self stackValue: 1).
	successFlag ifFalse:[^nil].

	oopResult := self positive64BitIntegerFor: (integerRcvr bitOr: integerArg).
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/29/1998 12:04'!
primitiveBitShift 
	| integerReceiver integerArgument shifted |
	integerArgument := self popInteger.
	integerReceiver := self popPos32BitInteger.
	successFlag ifTrue: [
		integerArgument >= 0 ifTrue: [
			"Left shift -- must fail if we lose bits beyond 32"
			self success: integerArgument <= 31.
			shifted := integerReceiver << integerArgument.
			self success: (shifted >> integerArgument) = integerReceiver.
		] ifFalse: [
			"Right shift -- OK to lose bits"
			self success: integerArgument >= -31.
			shifted := integerReceiver bitShift: integerArgument.
		].
	].
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor: shifted)]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/21/2008 20:41'!
primitiveBitShiftLargeIntegers
	"Primitive logical operations for large integers in 64 bit range"
	| shifted integerArg integerRcvr oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'shifted' type: 'sqLong'>

	integerArg := self stackIntegerValue: 0.
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).

	successFlag ifTrue: [
		integerArg >= 0 ifTrue: [
			"Left shift -- must fail if we lose bits beyond 64"
			self success: integerArg < 64.
			shifted := integerRcvr << integerArg.
			self success: (self cCode: 'shifted >> integerArg') = integerRcvr.
		] ifFalse: [
			"Right shift -- OK to lose bits"
			self success: integerArg > -64.
			shifted := self cCode: 'integerRcvr >> (0 - integerArg)'. "right shift coerces to usqInt"
		].
	].
	successFlag ifFalse:[^nil].
	oopResult := self signed64BitIntegerFor: shifted.
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/30/1998 13:18'!
primitiveBitXor
	| integerReceiver integerArgument |
	integerArgument := self popPos32BitInteger.
	integerReceiver := self popPos32BitInteger.
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor:
					(integerReceiver bitXor: integerArgument))]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveBitXorLargeIntegers
	"Primitive logical operations for large integers in 64 bit range"
	| integerRcvr integerArg oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self positive64BitValueOf: (self stackValue: 0).
	integerRcvr := self positive64BitValueOf: (self stackValue: 1).
	successFlag ifFalse:[^nil].

	oopResult := self positive64BitIntegerFor: (integerRcvr bitXor: integerArg).
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl 5/18/2010 21:44'!
primitiveBlockCopy

	| context methodContext contextSize newContext initialIP |
	context := self stackValue: 1.
	(self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context))
		ifTrue: ["context is a block; get the context of its enclosing method"
				methodContext := self fetchPointer: HomeIndex ofObject: context]
		ifFalse: [methodContext := context].
	contextSize := self sizeBitsOf: methodContext.  "in bytes, including header"
	context := nil.  "context is no longer needed and is not preserved across allocation"

	"remap methodContext in case GC happens during allocation"
	self pushRemappableOop: methodContext.
	newContext := self instantiateContext: (self splObj: ClassBlockContext) sizeInBytes: contextSize.
	methodContext := self popRemappableOop.

	initialIP := self integerObjectOf: (instructionPointer+1+3) - (method + self baseHeaderSize).
	"Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"

	"Assume: have just allocated a new context; it must be young.
	 Thus, can use uncheck stores. See the comment in fetchContextRegisters."

	self storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
	self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
	self storeStackPointerValue: 0 inContext: newContext.
	self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
	self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
	self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj.

	self pop: 2 thenPush: newContext.! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'dtl 11/2/2010 09:35'!
primitiveBytesLeft
	"Reports bytes available at this moment. For more meaningful 
	results, calls to this primitive should be preceeded by a full 
	or incremental garbage collection."
	| aBool |
	self methodArgumentCount = 0
		ifTrue: ["old behavior - just return the size of the free block"
			^self pop: 1 thenPush: (self positive64BitIntegerFor: (self sizeOfFree: freeBlock))].
	self methodArgumentCount = 1
		ifTrue: ["new behaviour -including or excluding swap space depending on aBool"
			aBool := self booleanValueOf: self stackTop.
			successFlag ifFalse: [^ nil].
			^self pop: 2 thenPush: (self positive64BitIntegerFor: (self bytesLeft: aBool))].
	^ self primitiveFail! !
!Interpreter methodsFor: 'message sending' stamp: 'ikp (auto pragmas 12/08) 6/10/2004 14:10'!
primitiveCalloutToFFI
	"Perform a function call to a foreign function.
	Only invoked from method containing explicit external call spec.
	Due to this we use the pluggable prim mechanism explicitly here
	(the first literal of any FFI spec'ed method is an ExternalFunction
	and not an array as used in the pluggable primitive mechanism)."

	| function moduleName functionName |
	<var: #function declareC: 'static void *function = 0'>
	<var: #moduleName declareC: 'static char *moduleName = "SqueakFFIPrims"'>
	<var: #functionName declareC: 'static char *functionName = "primitiveCallout"'>
	function = 0 ifTrue: [
		function := self
			ioLoadExternalFunction: (self oopForPointer: functionName)
			OfLength: 16
			FromModule: (self oopForPointer: moduleName)
			OfLength: 14.
		function == 0 ifTrue: [^self primitiveFail]].
	^self cCode: '((sqInt (*)(void))function)()'.
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'yo 4/3/2006 16:47'!
primitiveChangeClass
	"Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
	| arg rcvr argClass |

	self methodArgumentCount = 1 ifFalse: [self primitiveFail. ^ nil].

	arg := self stackObjectValue: 0.
	rcvr := self stackObjectValue: 1.
	argClass := self fetchClassOf: arg.
	self changeClassOf: rcvr to: argClass.
	successFlag ifTrue: [ self pop: 1 ].
	^ nil.
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'yo (auto pragmas dtl 2010-09-26) 4/3/2006 16:47'!
primitiveChangeClassWithClass
	"Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
	| rcvr argClass |
	<export: true>
	self methodArgumentCount = 1 ifFalse: [self primitiveFail. ^ nil].

	argClass := self stackObjectValue: 0.
	rcvr := self stackObjectValue: 1.

	self changeClassOf: rcvr to: argClass.
	successFlag ifTrue: [ self pop: 1 ].
	^ nil.
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'ls 8/17/2000 15:52'!
primitiveClass
	| instance |
	instance := self stackTop.
	self pop: argumentCount+1 thenPush: (self fetchClassOf: instance)! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'dtl 5/18/2010 21:44'!
primitiveClipboardText
	"When called with a single string argument, post the string to 
	the clipboard. When called with zero arguments, return a 
	string containing the current clipboard contents."
	| s sz |
	argumentCount = 1
		ifTrue: [s := self stackTop.
			(self isBytes: s) ifFalse: [^ self primitiveFail].
			successFlag
				ifTrue: [sz := self stSizeOf: s.
					self clipboardWrite: sz From: s + self baseHeaderSize At: 0.
					self pop: 1]]
		ifFalse: [sz := self clipboardSize.
			(self sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail].
			s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
			self clipboardRead: sz Into: s + self baseHeaderSize At: 0.
			self pop: 1 thenPush: s]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 4/25/2005 19:41'!
primitiveClone
	"Return a shallow copy of the receiver."

	| newCopy |
	newCopy := self clone: (self stackTop).
	newCopy = 0
		ifTrue:["not enough memory most likely" ^self primitiveFail].
	self pop: 1 thenPush: newCopy.! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl 5/18/2010 21:44'!
primitiveClosureCopyWithCopiedValues
	| newClosure copiedValues numCopiedValues numArgs |
	numArgs := self stackIntegerValue: 1.
	copiedValues := self stackTop.
	self success: (self fetchClassOf: copiedValues) = (self splObj: ClassArray).
	successFlag ifFalse:
		[^self primitiveFail].
	numCopiedValues := self fetchWordLengthOf: copiedValues.
	newClosure := self
					closureNumArgs: numArgs
									"greater by 1 due to preIncrement of localIP"
					instructionPointer: instructionPointer + 2 - (method + self baseHeaderSize)
					numCopiedValues: numCopiedValues.
	"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
	self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
	numCopiedValues > 0 ifTrue:
		["Allocation may have done a GC and copiedValues may have moved."
		 copiedValues := self stackTop.
		 0 to: numCopiedValues - 1 do:
			[:i|
			"Assume: have just allocated a new BlockClosure; it must be young.
			 Thus, can use unchecked stores."
			 self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
				ofObject: newClosure
				withValue: (self fetchPointer: i ofObject: copiedValues)]].
	self pop: 3 thenPush: newClosure! !
!Interpreter methodsFor: 'control primitives' stamp: 'eem 9/23/2010 21:00'!
primitiveClosureValue
	| blockClosure blockArgumentCount closureMethod outerContext |
	blockClosure := self stackValue: argumentCount.
	blockArgumentCount := self argumentCountOfClosure: blockClosure.
	argumentCount = blockArgumentCount ifFalse:
		[^self primitiveFail].

	"Somewhat paranoiac checks we need while debugging that we may be able to discard
	 in a robust system."
	outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
	(self isContext: outerContext) ifFalse:
		[^self primitiveFail].
	closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
	"Check if the closure's method is actually a CompiledMethod."
	(self isOopCompiledMethod: closureMethod) ifFalse:
		[^self primitiveFail].

	self activateNewClosureMethod: blockClosure.
	self quickCheckForInterrupts! !
!Interpreter methodsFor: 'control primitives' stamp: 'eem 9/23/2010 21:00'!
primitiveClosureValueNoContextSwitch
	"An exact clone of primitiveClosureValue except that this version will not
	 check for interrupts on stack overflow."
	| blockClosure blockArgumentCount closureMethod outerContext |
	blockClosure := self stackValue: argumentCount.
	blockArgumentCount := self argumentCountOfClosure: blockClosure.
	argumentCount = blockArgumentCount ifFalse:
		[^self primitiveFail].

	"Somewhat paranoiac checks we need while debugging that we may be able to discard
	 in a robust system."
	outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
	(self isContext: outerContext) ifFalse:
		[^self primitiveFail].
	closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
	"Check if the closure's method is actually a CompiledMethod."
	(self isOopCompiledMethod: closureMethod) ifFalse:
		[^self primitiveFail].

	self activateNewClosureMethod: blockClosure! !
!Interpreter methodsFor: 'control primitives' stamp: 'eem 9/23/2010 21:00'!
primitiveClosureValueWithArgs
	| argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext |
	argumentArray := self stackTop.
	(self isArray: argumentArray) ifFalse:
		[^self primitiveFail].

	"Check for enough space in thisContext to push all args"
	arraySize := self fetchWordLengthOf: argumentArray.
	cntxSize := self fetchWordLengthOf: activeContext.
	(self stackPointerIndex + arraySize) < cntxSize ifFalse:
		[^self primitiveFail].

	blockClosure := self stackValue: argumentCount.
	blockArgumentCount := self argumentCountOfClosure: blockClosure.
	arraySize = blockArgumentCount ifFalse:
		[^self primitiveFail].

	"Somewhat paranoiac checks we need while debugging that we may be able to discard
	 in a robust system."
	outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
	(self isContext: outerContext) ifFalse:
		[^self primitiveFail].
	closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
	"Check if the closure's method is actually a CompiledMethod."
	(self isOopCompiledMethod: closureMethod) ifFalse:
		[^self primitiveFail].

	self popStack.

	"Copy the arguments to the stack, and activate"
	index := 1.
	[index <= arraySize]
		whileTrue:
		[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
		index := index + 1].

	argumentCount := arraySize.
	self activateNewClosureMethod: blockClosure.
	self quickCheckForInterrupts! !
!Interpreter methodsFor: 'array primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:45'!
primitiveConstantFill
	"Fill the receiver, which must be an indexable bytes or words 
	objects, with the given integer value."
	| fillValue rcvr rcvrIsBytes end i |
	<var: #end type: 'usqInt'>
	<var: #i type: 'usqInt'>
	fillValue := self positive32BitValueOf: self stackTop.
	rcvr := self stackValue: 1.
	self success: (self isWordsOrBytes: rcvr).
	rcvrIsBytes := self isBytes: rcvr.
	rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])].
	successFlag
		ifTrue: [end := rcvr + (self sizeBitsOf: rcvr).
			i := rcvr + self baseHeaderSize.
			rcvrIsBytes
				ifTrue: [[i < end]
						whileTrue: [self byteAt: i put: fillValue.
							i := i + 1]]
				ifFalse: [[i < end]
						whileTrue: [self long32At: i put: fillValue.
							i := i + 4]].
			self pop: 1]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/23/2004 17:40'!
primitiveCopyObject
	"Primitive. Copy the state of the receiver from the argument. 
		Fail if receiver and argument are of a different class. 
		Fail if the receiver or argument are non-pointer objects.
		Fail if receiver and argument have different lengths (for indexable objects).
	"
	| rcvr arg length |
	self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
	arg := self stackObjectValue: 0.
	rcvr := self stackObjectValue: 1.

	self failed ifTrue:[^nil].
	(self isPointers: rcvr) ifFalse:[^self primitiveFail].
	(self fetchClassOf: rcvr) = (self fetchClassOf: arg) ifFalse:[^self primitiveFail].
	length := self lengthOf: rcvr.
	length = (self lengthOf: arg) ifFalse:[^self primitiveFail].
	
	"Now copy the elements"
	0 to: length-1 do:[:i|
		self storePointer: i ofObject: rcvr withValue: (self fetchPointer: i ofObject: arg)].

	"Note: The above could be faster for young receivers but I don't think it'll matter"
	self pop: 1. "pop arg; answer receiver"
! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:16'!
primitiveDeferDisplayUpdates
	"Set or clear the flag that controls whether modifications of 
	the Display object are propagated to the underlying 
	platform's screen."
	| flag |
	flag := self stackTop.
	flag = trueObj
		ifTrue: [deferDisplayUpdates := true]
		ifFalse: [flag = falseObj
				ifTrue: [deferDisplayUpdates := false]
				ifFalse: [self primitiveFail]].
	successFlag
		ifTrue: [self pop: 1]! !
!Interpreter methodsFor: 'system control primitives' stamp: 'tpr (auto pragmas 12/08) 5/9/2005 18:58'!
primitiveDisablePowerManager
	"Pass in a non-negative value to disable the architectures powermanager if any, zero to enable. This is a named (not numbered) primitive in the null module (ie the VM)"

	| integer |
	<export: true>
	integer := self stackIntegerValue: 0.
	successFlag ifTrue: [
		self ioDisablePowerManager: integer.
		self pop: 1].  "integer; leave rcvr on stack"
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'tpr 3/15/2004 20:24'!
primitiveDiv
	| quotient |
	quotient := self doPrimitiveDiv: (self stackValue: 1) by: (self stackTop).
	self pop2AndPushIntegerIfOK: quotient! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/20/2008 22:52'!
primitiveDivLargeIntegers
	"Primitive arithmetic operations for large integers in 64 bit range"
	| integerRcvr integerArg result posArg posRcvr oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'posRcvr' type: 'sqLong'>
	<var: 'posArg' type: 'sqLong'>
	<var: 'result' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).
	integerArg = 0 ifTrue:[self primitiveFail].
	successFlag ifFalse:[^nil].

	integerRcvr > 0
		ifTrue: [integerArg > 0
					ifTrue: [result := integerRcvr // integerArg]
					ifFalse: ["round negative result toward negative infinity"
							posArg := 0 - integerArg.
							posRcvr := integerRcvr + (posArg - 1). "can overflow!!"
							posRcvr < 0 ifTrue:[self primitiveFail].
							result := 0 - (posRcvr // posArg)]]
		ifFalse: [posRcvr := 0 - integerRcvr.
				integerArg > 0
					ifTrue: ["round negative result toward negative infinity"
							posRcvr := posRcvr + (integerArg - 1). "can overflow!!"
							posRcvr < 0 ifTrue:[self primitiveFail].
							result := 0 - (posRcvr // integerArg)]
					ifFalse: [posArg := 0 - integerArg.
							result := posRcvr // posArg]].
	successFlag ifTrue:[oopResult := self signed64BitIntegerFor: result].
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/30/1998 10:25'!
primitiveDivide
	| integerReceiver integerArgument |
	integerReceiver := self stackIntegerValue: 1.
	integerArgument := self stackIntegerValue: 0.
	(integerArgument ~= 0 and: [integerReceiver \\ integerArgument = 0])
		ifTrue: [self pop2AndPushIntegerIfOK: integerReceiver // integerArgument]
		ifFalse: [self primitiveFail]! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveDivideLargeIntegers
	"Primitive arithmetic operations for large integers in 64 bit range"
	| integerRcvr integerArg result oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'result' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).
	(integerArg ~= 0 and:[integerRcvr \\ integerArg = 0]) ifFalse:[self primitiveFail].
	successFlag ifFalse:[^nil].
	result := integerRcvr // integerArg.
	oopResult := self signed64BitIntegerFor: result.
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'control primitives' stamp: 'tpr 3/23/2004 17:55'!
primitiveDoPrimitiveWithArgs
	| argumentArray arraySize index cntxSize primIdx |
	argumentArray := self stackTop.
	arraySize := self fetchWordLengthOf: argumentArray.
	cntxSize := self fetchWordLengthOf: activeContext.
	self success: self stackPointerIndex + arraySize < cntxSize.
	(self isArray: argumentArray) ifFalse: [^ self primitiveFail].

	primIdx := self stackIntegerValue: 1.
	successFlag ifFalse: [^ self primitiveFail]. "invalid args"

	"Pop primIndex and argArray, then push args in place..."
	self pop: 2.
	primitiveIndex := primIdx.
	argumentCount := arraySize.
	index := 1.
	[index <= argumentCount]
		whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray).
			index := index + 1].

	"Run the primitive (sets successFlag)"
	self pushRemappableOop: argumentArray. "prim might alloc/gc"
	lkupClass := nilObj.
	self primitiveResponse.
	argumentArray := self popRemappableOop.
	successFlag
		ifFalse: ["If primitive failed, then restore state for failure code"
			self pop: arraySize.
			self pushInteger: primIdx.
			self push: argumentArray.
			argumentCount := 2]! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/27/1998 15:43'!
primitiveEqual
	| integerReceiver integerArgument result |
	integerArgument := self popStack.
	integerReceiver := self popStack.
	result := self compare31or32Bits: integerReceiver equal: integerArgument.
	self checkBooleanResult: result! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveEqualLargeIntegers
	"Primitive comparison operations for large integers in 64 bit range"
	| integerRcvr integerArg |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).

	successFlag ifTrue:[
		self pop: 2.
		self pushBool: integerRcvr = integerArg
	].
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/23/2004 17:41'!
primitiveEquivalent
"is the receiver the same object as the argument?"
	| thisObject otherObject |
	otherObject := self popStack.
	thisObject := self popStack.
	self pushBool: thisObject = otherObject! !
!Interpreter methodsFor: 'control primitives' stamp: 'tpr 11/2/2004 18:04'!
primitiveExecuteMethod
	"receiver, args, then method are on top of stack. Execute method against receiver and args"
	newMethod := self popStack.
	primitiveIndex := self primitiveIndexOf: newMethod.
	self success: argumentCount - 1 = (self argumentCountOf: newMethod).
	successFlag
		ifTrue: [argumentCount := argumentCount - 1.
			self executeNewMethod]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl 11/23/2010 10:59'!
primitiveExecuteMethodArgsArray
	"receiver, argsArray, then method are on top of stack.  Execute method against receiver and args"

	| methodArgument argCnt argumentArray |
	methodArgument := self popStack.
	argumentArray := self popStack.
	((self isOopCompiledMethod: methodArgument)
	 and: [self isArray: argumentArray]) ifFalse:
		[self unPop: 2. ^self primitiveFail].
	argCnt := self argumentCountOf: methodArgument.
	argCnt = (self fetchWordLengthOf: argumentArray) ifFalse:
		[self unPop: 2. ^self primitiveFail].
	self transfer: argCnt from: argumentArray + self baseHeaderSize to: stackPointer + self bytesPerWord.
	self unPop: argCnt.
	newMethod := methodArgument.
	primitiveIndex := self primitiveIndexOf: newMethod.
	argumentCount := argCnt.
	self executeNewMethod.
	"Recursive xeq affects successFlag"
	successFlag := true! !
!Interpreter methodsFor: 'system control primitives'!
primitiveExitToDebugger

	self error: 'Exit to debugger at user request'.! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:27'!
primitiveExp
	"Computes E raised to the receiver power."

	| rcvr |
	<var: #rcvr type: 'double '>
	rcvr := self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'exp(rcvr)' inSmalltalk: [rcvr exp])]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:28'!
primitiveExponent
	"Exponent part of this float."

	| rcvr frac pwr |
	<var: #rcvr type: 'double '>
	<var: #frac type: 'double '>
	<var: #pwr type: 'int '>
	rcvr := self popFloat.
	successFlag
		ifTrue: [  "rcvr = frac * 2^pwr, where frac is in [0.5..1.0)"
			self cCode: 'frac = frexp(rcvr, &pwr)'
					inSmalltalk: [pwr := rcvr exponent].
			self pushInteger: pwr - 1]
		ifFalse: [self unPop: 1].! !
!Interpreter methodsFor: 'plugin primitives' stamp: 'dtl 12/14/2010 08:13'!
primitiveExternalCall
	"Call an external primitive. The external primitive methods 
	contain as first literal an array consisting of: 
	* The module name (String | Symbol) 
	* The function name (String | Symbol) 
	* The session ID (SmallInteger) [OBSOLETE] 
	* The function index (Integer) in the externalPrimitiveTable 
	For fast failures the primitive index of any method where the 
	external prim is not found is rewritten in the method cache 
	with zero. This allows for ultra fast responses as long as the 
	method stays in the cache. 
	The fast failure response relies on lkupClass being properly 
	set. This is done in 
	#addToMethodCacheSel:class:method:primIndex: to 
	compensate for execution of methods that are looked up in a 
	superclass (such as in primitivePerformAt). 
	With the latest modifications (e.g., actually flushing the 
	function addresses from the VM), the session ID is obsolete. 
	But for backward compatibility it is still kept around. Also, a 
	failed lookup is reported specially. If a method has been 
	looked up and not been found, the function address is stored 
	as -1 (e.g., the SmallInteger -1 to distinguish from 
	16rFFFFFFFF which may be returned from the lookup). 
	It is absolutely okay to remove the rewrite if we run into any 
	problems later on. It has an approximate speed difference of 
	30% per failed primitive call which may be noticable but if, 
	for any reasons, we run into problems (like with J3) we can 
	always remove the rewrite. 
	"
	| lit addr moduleName functionName moduleLength functionLength index |
	<var: #addr type: 'void *'>
	
	"Fetch the first literal of the method"
	self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
	successFlag ifFalse: [^ nil].

	lit := self literal: 0 ofMethod: newMethod. 
	"Check if it's an array of length 4"
	self success: ((self isArray: lit) and: [(self lengthOf: lit) = 4]).
	successFlag ifFalse: [^ nil].

	"Look at the function index in case it has been loaded before"
	index := self fetchPointer: 3 ofObject: lit.
	index := self checkedIntegerValueOf: index.
	successFlag ifFalse: [^ nil].
	"Check if we have already looked up the function and failed."
	index < 0
		ifTrue: ["Function address was not found in this session, 
			Rewrite the mcache entry with a zero primitive index."
			self
				rewriteMethodCacheSel: messageSelector
				class: lkupClass
				primIndex: 0.
			^ self success: false].

	"Try to call the function directly"
	(index > 0 and: [index <= MaxExternalPrimitiveTableSize])
		ifTrue: [addr := externalPrimitiveTable at: index - 1.
			addr ~= 0
				ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
					self callExternalPrimitive: addr.
					^ nil].
			"if we get here, then an index to the external prim was 
			kept on the ST side although the underlying prim 
			table was already flushed"
			^ self primitiveFail].

	"Clean up session id and external primitive index"
	self storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
	self storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.

	"The function has not been loaded yet. Fetch module and function name."
	moduleName := self fetchPointer: 0 ofObject: lit.
	moduleName = nilObj
		ifTrue: [moduleLength := 0]
		ifFalse: [self success: (self isBytes: moduleName).
				moduleLength := self lengthOf: moduleName.
				self cCode: '' inSmalltalk:
					[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName))
						ifTrue: [moduleLength := 0  "Cause all of these to fail"]]].
	functionName := self fetchPointer: 1 ofObject: lit.
	self success: (self isBytes: functionName).
	functionLength := self lengthOf: functionName.
	successFlag ifFalse: [^ nil].

	addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
				OfLength: functionLength
				FromModule: moduleName + self baseHeaderSize
				OfLength: moduleLength.
	addr = 0
		ifTrue: [index := -1]
		ifFalse: ["add the function to the external primitive table"
			index := self addToExternalPrimitiveTable: addr].
	self success: index >= 0.
	"Store the index (or -1 if failure) back in the literal"
	self storePointerUnchecked: 3 ofObject: lit withValue: (self integerObjectOf: index).

	"If the function has been successfully loaded process it"
	(successFlag and: [addr ~= 0])
		ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
				self callExternalPrimitive: addr]
		ifFalse: ["Otherwise rewrite the primitive index"
			self
				rewriteMethodCacheSel: messageSelector
				class: lkupClass
				primIndex: 0]! !
!Interpreter methodsFor: 'primitive support'!
primitiveFail

	successFlag := false.! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'dtl 5/18/2010 21:45'!
primitiveFailAfterCleanup: outPointerArray
	"If the storeSegment primitive fails, it must clean up first."

	| i lastAddr |   "Store nils throughout the outPointer array."
	lastAddr := outPointerArray + (self lastPointerOf: outPointerArray).
	i := outPointerArray + self baseHeaderSize.
	[i <= lastAddr] whileTrue:
		[self longAt: i put: nilObj.
		i := i + self bytesPerWord].

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self primitiveFail! !
!Interpreter methodsFor: 'primitive support' stamp: 'John M McIntosh 11/23/2008 22:15'!
primitiveFailFor: reasonCode
	"Set specific primitive failure."
	primFailCode := reasonCode.
	self primitiveFail.! !
!Interpreter methodsFor: 'process primitives' stamp: 'ar 3/6/2001 14:57'!
primitiveFindHandlerContext
	"Primitive. Search up the context stack for the next method context marked for exception handling starting at the receiver. Return nil if none found"
	| thisCntx nilOop |
	thisCntx := self popStack.
	nilOop := nilObj.

	[(self isHandlerMarked: thisCntx) ifTrue:[
			self push: thisCntx.
			^nil].
		thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx.
		thisCntx = nilOop] whileFalse.

	^self push: nilObj! !
!Interpreter methodsFor: 'process primitives' stamp: 'ar 7/8/2003 11:33'!
primitiveFindNextUnwindContext
	"Primitive. Search up the context stack for the next method context marked for unwind handling from the receiver up to but not including the argument. Return nil if none found."
	| thisCntx nilOop aContext unwindMarked |
	aContext := self popStack.
	thisCntx := self fetchPointer: SenderIndex ofObject: self popStack.
	nilOop := nilObj.

	[(thisCntx = aContext) or: [thisCntx = nilOop]] whileFalse: [
		unwindMarked := self isUnwindMarked: thisCntx.
		unwindMarked ifTrue:[
			self push: thisCntx.
			^nil].
		thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx].

	^self push: nilOop! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'di 11/27/1998 11:45'!
primitiveFloatAdd
	^ self primitiveFloatAdd: (self stackValue: 1) toArg: self stackTop! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:29'!
primitiveFloatAdd: rcvrOop toArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self pop: 2.
		self pushFloat: rcvr + arg].! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'di 11/27/1998 11:45'!
primitiveFloatDivide
	^ self primitiveFloatDivide: (self stackValue: 1) byArg: self stackTop! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:29'!
primitiveFloatDivide: rcvrOop byArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self success: arg ~= 0.0.
		successFlag ifTrue: [
			self pop: 2.
			self pushFloat: (self cCode: 'rcvr / arg' inSmalltalk: [rcvr / arg])]].! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'acg 8/30/2002 17:30'!
primitiveFloatEqual
	| aBool |
	aBool := self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: aBool].
! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:29'!
primitiveFloatEqual: rcvrOop toArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr = arg]! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:29'!
primitiveFloatGreater: rcvrOop thanArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr > arg].
! !
!Interpreter methodsFor: 'float primitives' stamp: 'nice 1/4/2009 21:24'!
primitiveFloatGreaterOrEqual
	| aBool |
	aBool := self primitiveFloatGreaterOrEqual: (self stackValue: 1) toArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: aBool].! !
!Interpreter methodsFor: 'float primitives' stamp: 'nice (auto pragmas dtl 2010-09-26) 1/4/2009 21:22'!
primitiveFloatGreaterOrEqual: rcvrOop toArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr >= arg].
! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'acg 8/30/2002 17:31'!
primitiveFloatGreaterThan
	| aBool |
	aBool := self primitiveFloatGreater: (self stackValue: 1) thanArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: aBool].
! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:29'!
primitiveFloatLess: rcvrOop thanArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr < arg].
! !
!Interpreter methodsFor: 'float primitives' stamp: 'nice 1/4/2009 21:24'!
primitiveFloatLessOrEqual
	| aBool |
	aBool := self primitiveFloatLessOrEqual: (self stackValue: 1) toArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: aBool].! !
!Interpreter methodsFor: 'float primitives' stamp: 'nice (auto pragmas dtl 2010-09-26) 1/4/2009 21:23'!
primitiveFloatLessOrEqual: rcvrOop toArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr <= arg].
! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'acg 8/30/2002 17:31'!
primitiveFloatLessThan
	| aBool |
	aBool := self primitiveFloatLess: (self stackValue: 1) thanArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: aBool].
! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'di 11/27/1998 11:46'!
primitiveFloatMultiply
	^ self primitiveFloatMultiply: (self stackValue: 1) byArg: self stackTop! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:29'!
primitiveFloatMultiply: rcvrOop byArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self pop: 2.
		self pushFloat: rcvr * arg].! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'acg 8/30/2002 17:31'!
primitiveFloatNotEqual
	| aBool |
	aBool := self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: aBool not].
! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'di 11/27/1998 11:46'!
primitiveFloatSubtract
	^ self primitiveFloatSubtract: (self stackValue: 1) fromArg: self stackTop! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:30'!
primitiveFloatSubtract: rcvrOop fromArg: argOop
	| rcvr arg |
	<var: #rcvr type: 'double '>
	<var: #arg type: 'double '>

	rcvr := self loadFloatOrIntFrom: rcvrOop.
	arg := self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self pop: 2.
		self pushFloat: rcvr - arg].! !
!Interpreter methodsFor: 'system control primitives' stamp: 'md 2/12/2001 16:41'!
primitiveFlushCache
	"Clear the method lookup cache. This must be done after every programming change."

	self flushMethodCache.
	self compilerFlushCacheHook: nil.		"Flush the dynamic compiler's inline caches."
! !
!Interpreter methodsFor: 'system control primitives' stamp: 'ikp 1/4/1999 11:31'!
primitiveFlushCacheByMethod
	"The receiver is a compiledMethod.  Clear all entries in the method lookup cache that refer to this method, presumably because it has been redefined, overridden or removed."
	| probe oldMethod |
	oldMethod := self stackTop.
	probe := 0.
	1 to: MethodCacheEntries do:
		[:i | (methodCache at: probe + MethodCacheMethod) = oldMethod ifTrue:
			[methodCache at: probe + MethodCacheSelector put: 0].
		probe := probe + MethodCacheEntrySize].
	self compilerFlushCacheHook: oldMethod.		"Flush the dynamic compiler's inline caches."! !
!Interpreter methodsFor: 'system control primitives' stamp: 'jm 12/14/1998 14:32'!
primitiveFlushCacheSelective
	"The receiver is a message selector.  Clear all entries in the method lookup cache with this selector, presumably because an associated method has been redefined."
	| selector probe |
	selector := self stackTop.
	probe := 0.
	1 to: MethodCacheEntries do:
		[:i | (methodCache at: probe + MethodCacheSelector) = selector ifTrue:
			[methodCache at: probe + MethodCacheSelector put: 0].
		probe := probe + MethodCacheEntrySize]! !
!Interpreter methodsFor: 'plugin primitives' stamp: 'ar 3/26/2000 16:03'!
primitiveFlushExternalPrimitives
	"Primitive. Flush all the existing external primitives in the image thus forcing a reload on next invokation."
	^self flushExternalPrimitives! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'jm 5/17/1998 07:06'!
primitiveForceDisplayUpdate
	"On some platforms, this primitive forces enqueued display updates to be processed immediately. On others, it does nothing."

	self ioForceDisplayUpdate.
! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'JMM (auto pragmas 12/08) 1/27/2005 13:21'!
primitiveForceTenure
	"Set force tenure flag to true, this forces a tenure operation on the next incremental GC"

	<export: true>
	forceTenureFlag := 1! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:01'!
primitiveFormPrint
	"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."

	| landscapeFlag vScale hScale rcvr bitsArray w h
	 depth pixelsPerWord wordsPerLine bitsArraySize ok |

	<var: #vScale type: 'double '>
	<var: #hScale type: 'double '>
	landscapeFlag := self booleanValueOf: self stackTop.
	vScale := self floatValueOf: (self stackValue: 1).
	hScale := self floatValueOf: (self stackValue: 2).
	rcvr := self stackValue: 3.
	(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
	successFlag ifTrue: [
		((self  isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
			ifFalse: [self success: false]].
	successFlag ifTrue: [
		bitsArray := self fetchPointer: 0 ofObject: rcvr.
		w := self fetchInteger: 1 ofObject: rcvr.
		h := self fetchInteger: 2 ofObject: rcvr.
		depth := self fetchInteger: 3 ofObject: rcvr.
		(w > 0 and: [h > 0]) ifFalse: [self success: false].
		pixelsPerWord := 32 // depth.
		wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
		((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
			ifTrue: [
				bitsArraySize := self byteLengthOf: bitsArray.
				self success: (bitsArraySize = (wordsPerLine * h * 4))]
			ifFalse: [self success: false]].	
	successFlag ifTrue: [
		self bytesPerWord = 8
			ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
			ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
		self success: ok].
	successFlag ifTrue: [
		self pop: 3].  "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:30'!
primitiveFractionalPart
	| rcvr frac trunc |
	<var: #rcvr type: 'double '>
	<var: #frac type: 'double '>
	<var: #trunc type: 'double '>
	rcvr := self popFloat.
	successFlag
		ifTrue: [self cCode: 'frac = modf(rcvr, &trunc)' inSmalltalk: [frac := rcvr fractionPart].
				self pushFloat: frac]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'dtl 11/2/2010 09:30'!
primitiveFullGC
	"Do a full garbage collection and return the number of bytes available (including swap space if dynamic memory management is supported)."

	self pop: 1.
	self incrementalGC.  "maximimize space for forwarding table"
	self fullGC.
	self push: (self positive64BitIntegerFor: (self bytesLeft: true))
! !
!Interpreter methodsFor: 'system control primitives' stamp: 'dtl 5/18/2010 21:45'!
primitiveGetAttribute
	"Fetch the system attribute with the given integer ID. The 
	result is a string, which will be empty if the attribute is not 
	defined."
	| attr sz s |
	attr := self stackIntegerValue: 0.
	successFlag
		ifTrue: [sz := self attributeSize: attr].
	successFlag
		ifTrue: [s := self
						instantiateClass: (self splObj: ClassString)
						indexableSize: sz.
			self
				getAttribute: attr
				Into: s + self baseHeaderSize
				Length: sz.
			self pop: 2 thenPush: s]! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'John M McIntosh (auto pragmas dtl 2010-09-26) 7/8/2010 12:01'!
primitiveGetNextEvent
	"Primitive. Return the next input event from the VM event queue."
	| evtBuf arg value eventTypeIs |
	<var: #evtBuf declareC: 'int evtBuf[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }'>
	self cCode:'' inSmalltalk:[evtBuf := CArrayAccessor on: (IntegerArray new: 8)].
	arg := self stackTop.
	((self isArray: arg) and:[(self slotSizeOf: arg) = 8])  ifFalse:[^self primitiveFail].

	self ioGetNextEvent: (self cCoerce: evtBuf to: 'sqInputEvent*').
	successFlag ifFalse:[^nil].

	"Event type"
	eventTypeIs := evtBuf at: 0.
	self storeInteger: 0 ofObject: arg withValue: (evtBuf at: 0).
	successFlag ifFalse:[^nil].

	"Event is Complex, assume evtBuf is populated correctly and return"
	eventTypeIs = 6 ifTrue: 
		[1 to: 7 do: [:i |
			value := evtBuf at: i.
			self storePointer: i ofObject: arg withValue: value]]
	ifFalse: [
		"Event time stamp"
		self storeInteger: 1 ofObject: arg withValue: ((evtBuf at: 1) bitAnd: MillisecondClockMask).
		successFlag ifFalse:[^nil].

		"Event arguments"
		2 to: 7 do:[:i|
			value := evtBuf at: i.
			(self isIntegerValue: value)
				ifTrue:[self storeInteger: i ofObject: arg withValue: value]
				ifFalse:["Need to remap because allocation may cause GC"
					self pushRemappableOop: arg.
					value := self positive32BitIntegerFor: value.
					arg := self popRemappableOop.
					self storePointer: i ofObject: arg withValue: value]]].
	successFlag ifFalse:[^nil].
	self pop: 1.! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/27/1998 15:43'!
primitiveGreaterOrEqual
	| integerReceiver integerArgument |
	integerArgument := self popInteger.
	integerReceiver := self popInteger.
	self checkBooleanResult: integerReceiver >= integerArgument! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveGreaterOrEqualLargeIntegers
	"Primitive comparison operations for large integers in 64 bit range"
	| integerRcvr integerArg |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).

	successFlag ifTrue:[
		self pop: 2.
		self pushBool: integerRcvr >= integerArg
	].
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/27/1998 15:43'!
primitiveGreaterThan
	| integerReceiver integerArgument |
	integerArgument := self popInteger.
	integerReceiver := self popInteger.
	self checkBooleanResult: integerReceiver > integerArgument! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveGreaterThanLargeIntegers
	"Primitive comparison operations for large integers in 64 bit range"
	| integerRcvr integerArg |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).

	successFlag ifTrue:[
		self pop: 2.
		self pushBool: integerRcvr > integerArg
	].
! !
!Interpreter methodsFor: 'other primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/10/2010 12:32'!
primitiveImageFormatVersion
	"Answer an integer identifying the type of image. The image version number may
	identify the format of the image (e.g. 32 or 64-bit word size) or specific requirements
	of the image (e.g. block closure support required).
	
	This is a named (not numbered) primitive in the null module (ie the VM)"

	<export: true>
	self pop: 1 thenPush: (self positive32BitIntegerFor: self imageFormatVersion)
! !
!Interpreter methodsFor: 'other primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:45'!
primitiveImageName
	"When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."

	| s sz sCRIfn okToRename |
	<var: #sCRIfn type: 'void *'>
	argumentCount = 1 ifTrue: [
		"If the security plugin can be loaded, use it to check for rename permission.
		If not, assume it's ok"
		sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'.
		sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))sCRIfn)()'.
			okToRename ifFalse:[^self primitiveFail]].
		s := self stackTop.
		self assertClassOf: s is: (self splObj: ClassString).
		successFlag ifTrue: [
			sz := self stSizeOf: s.
			self imageNamePut: (s + self baseHeaderSize) Length: sz.
			self pop: 1.  "pop s, leave rcvr on stack"
		].
	] ifFalse: [
		sz := self imageNameSize.
		s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
		self imageNameGet: (s + self baseHeaderSize) Length: sz.
		self pop: 1.  "rcvr"
		self push: s.
	].
! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'dtl 11/2/2010 09:31'!
primitiveIncrementalGC
	"Do a quick, incremental garbage collection and return the number of bytes immediately available. (Note: more space may be made available by doing a full garbage collection."

	self pop: 1.
	self incrementalGC.
	self push: (self positive64BitIntegerFor: (self bytesLeft: false))
! !
!Interpreter methodsFor: 'compiled methods' stamp: 'ls 6/22/2000 14:35'!
primitiveIndexOf: methodPointer
	"Note: We now have 10 bits of primitive index, but they are in two places
	for temporary backward compatibility.  The time to unpack is negligible,
	since the reconstituted full index is stored in the method cache."
	| primBits |
	primBits := ((self headerOf: methodPointer) >> 1) bitAnd: 16r100001FF.
	
	^ (primBits bitAnd: 16r1FF) + (primBits >> 19)
! !
!Interpreter methodsFor: 'compiled methods' stamp: 'eem 11/25/2008 13:54'!
primitiveIndexOfMethodHeader: methodHeader
	"Note: We now have 10 bits of primitive index, but they are in two places
	for temporary backward compatibility.  The time to unpack is negligible,
	 since the derived primitive function pointer is stored in the method cache."
	| primBits |
	primBits := (methodHeader >> 1).
	^(primBits bitAnd: 16r1FF) + ((primBits >> 19) bitAnd: 16r200)! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/29/2006 12:20'!
primitiveInputSemaphore
	"Register the input semaphore. The argument is an index into the ExternalObjectsArray part of the specialObjectsArray and must have been allocated via 'Smalltalk registerExternalObject: the Semaphore' "
	| arg |
	arg := self stackTop.
	(self isIntegerObject: arg)
		ifTrue: ["If arg is integer, then condsider it as an index  into the external objects array and install it  as the new event semaphore"
			self ioSetInputSemaphore: (self integerValueOf: arg).
			successFlag
				ifTrue: [self pop: 1].
			^ nil]! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 5/13/2005 10:17'!
primitiveInputWord
	"Return an integer indicating the reason for the most recent input interrupt."

	self pop: 1 thenPushInteger: 0.	"noop for now"! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/23/2004 17:42'!
primitiveInstVarAt
	| index rcvr hdr fmt totalLength fixedFields value |
	index := self stackIntegerValue: 0.
	rcvr := self stackValue: 1.
	successFlag
		ifTrue: [hdr := self baseHeader: rcvr.
			fmt := hdr >> 8 bitAnd: 15.
			totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
			fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength.
			(index >= 1 and: [index <= fixedFields])
				ifFalse: [successFlag := false]].
	successFlag ifTrue: [value := self subscript: rcvr with: index format: fmt].
	successFlag ifTrue: [self pop: argumentCount + 1 thenPush: value]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/23/2004 17:43'!
primitiveInstVarAtPut
	| newValue index rcvr hdr fmt totalLength fixedFields |
	newValue := self stackTop.
	index := self stackIntegerValue: 1.
	rcvr := self stackValue: 2.
	successFlag
		ifTrue: [hdr := self baseHeader: rcvr.
			fmt := hdr >> 8 bitAnd: 15.
			totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
			fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength.
			(index >= 1 and: [index <= fixedFields]) ifFalse: [successFlag := false]].
	successFlag ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt].
	successFlag ifTrue: [self pop: argumentCount + 1 thenPush: newValue]! !
!Interpreter methodsFor: 'quick primitives' stamp: 'dtl 4/22/2007 23:35'!
primitiveInstVarsPutFromStack
	"Note:  this primitive has been decommissioned.  It is only here for short-term compatibility with an internal 2.3beta-d image that used this.  It did not save much time and it complicated several things.  Plus Jitter will do it right anyway."
	| rcvr offsetBits |
	rcvr := self stackValue: argumentCount.
	"Mark dirty so stores below can be unchecked"
	(self oop: rcvr isLessThan: youngStart) ifTrue: [ self beRootIfOld: rcvr ].
	0 to: argumentCount-1 do:
		[:i | (i bitAnd: 3) = 0 ifTrue:
			[offsetBits := self positive32BitValueOf: (self literal: i//4 ofMethod: newMethod)].
		self storePointerUnchecked: (offsetBits bitAnd: 16rFF) ofObject: rcvr
						withValue: (self stackValue: i).
		offsetBits := offsetBits >> 8].
	self pop: argumentCount! !
!Interpreter methodsFor: 'array primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:45'!
primitiveIntegerAt
	"Return the 32bit signed integer contents of a words receiver"

	| index rcvr sz addr value intValue |
	<var: #intValue type: 'int'>
	index := self stackIntegerValue: 0.
	rcvr := self stackValue: 1.
	(self isIntegerObject: rcvr) ifTrue: [^self success: false].
	(self isWords: rcvr) ifFalse: [^self success: false].
	sz := self lengthOf: rcvr.  "number of fields"
	self success: ((index >= 1) and: [index <= sz]).
	successFlag ifTrue: [
		addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
		value := self intAt: addr.
		self pop: 2.  "pop rcvr, index"
		"push element value"
		(self isIntegerValue: value)
			ifTrue: [self pushInteger: value]
			ifFalse: [
				intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt"
				self push: (self signed32BitIntegerFor: intValue)]. "intValue may be sign extended to 64 bit sqInt"
	].! !
!Interpreter methodsFor: 'array primitives' stamp: 'dtl 5/18/2010 21:45'!
primitiveIntegerAtPut
	"Return the 32bit signed integer contents of a words receiver"
	| index rcvr sz addr value valueOop |
	valueOop := self stackValue: 0.
	index := self stackIntegerValue: 1.
	rcvr := self stackValue: 2.
	(self isIntegerObject: rcvr) ifTrue:[^self success: false].
	(self isWords: rcvr) ifFalse:[^self success: false].
	sz := self lengthOf: rcvr.  "number of fields"
	((index >= 1) and: [index <= sz]) ifFalse:[^self success: false].
	(self isIntegerObject: valueOop)
		ifTrue:[value := self integerValueOf: valueOop]
		ifFalse:[value := self signed32BitValueOf: valueOop].
	successFlag ifTrue:[
		addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
		value := self intAt: addr put: value.
		self pop: 3 thenPush: valueOop. "pop all; return value"
	].
! !
!Interpreter methodsFor: 'other primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/9/2010 00:44'!
primitiveInterpreterSourceVersion
	"Answer a string corresponding to the version of the interpreter source. This
	represents the version level of the Smalltalk source code (interpreter and various
	plugins) that is translated to C by a CCodeGenerator, as distinct from the external
	platform source code, typically written in C and managed separately for each platform.
	This is a named (not numbered) primitive in the null module (ie the VM)"
	
	| len versionString p cString |
	<export: true>
	<var: #p type: 'char *'>
	<var: #cString type: 'char *'>
	cString := InterpreterSourceVersion.
	len := self cCode: 'strlen(cString)' inSmalltalk: [0].
	versionString := interpreterProxy
		instantiateClass: interpreterProxy classString
		indexableSize: len.
	p := interpreterProxy arrayValueOf: versionString.
	self cCode: 'strncpy(p, cString, len)'.
	self pop: 1 thenPush: versionString
! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:37'!
primitiveInterruptSemaphore
	"Register the user interrupt semaphore. If the argument is 
	not a Semaphore, unregister the current interrupt 
	semaphore. "
	| arg |
	arg := self popStack.
	(self fetchClassOf: arg) = (self splObj: ClassSemaphore)
		ifTrue: [self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: arg]
		ifFalse: [self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: nilObj]! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl 5/18/2010 21:45'!
primitiveInvokeObjectAsMethod
	"Primitive. 'Invoke' an object like a function, sending the special message 
		run: originalSelector with: arguments in: aReceiver.
	"
	| runSelector runReceiver runArgs newReceiver lookupClass |
	runArgs := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
	self beRootIfOld: runArgs. "do we really need this?"
	self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * self bytesPerWord) to: runArgs + self baseHeaderSize.

	runSelector := messageSelector.
	runReceiver := self stackValue: argumentCount.
	self pop: argumentCount+1.

	"stack is clean here"

	newReceiver := newMethod.
	messageSelector := self splObj: SelectorRunWithIn.
	argumentCount := 3.

	self push: newReceiver.
	self push: runSelector.
	self push: runArgs.
	self push: runReceiver.

	lookupClass := self fetchClassOf: newReceiver.
	self findNewMethodInClass: lookupClass.
	self executeNewMethodFromCache.  "Recursive xeq affects successFlag"
	successFlag := true.
! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 12:38'!
primitiveIsRoot
	"Primitive. Answer whether the argument to the primitive is a root for young space"
	| oop |
	<export: true>
	oop := self stackObjectValue: 0.
	successFlag ifTrue:[
		self pop: argumentCount + 1.
		self pushBool: ((self baseHeader: oop) bitAnd: self rootBit).
	].! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 22:51'!
primitiveIsYoung
	"Primitive. Answer whether the argument to the primitive resides in young space."
	| oop |
	<export: true>
	oop := self stackObjectValue: 0.
	successFlag ifTrue:[
		self pop: argumentCount + 1.
		self pushBool: (self oop: oop isGreaterThanOrEqualTo: youngStart).
	].! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:38'!
primitiveKbdNext
	"Obsolete on virtually all platforms; old style input polling code.
	Return the next keycode and remove it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."

	| keystrokeWord |
	self pop: 1.
	keystrokeWord := self ioGetKeystroke.
	keystrokeWord >= 0
		ifTrue: [self pushInteger: keystrokeWord]
		ifFalse: [self push: nilObj].! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:39'!
primitiveKbdPeek
	"Obsolete on virtually all platforms; old style input polling code.
	Return the next keycode and without removing it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."

	| keystrokeWord |
	self pop: 1.
	keystrokeWord := self ioPeekKeystroke.
	keystrokeWord >= 0
		ifTrue: [self pushInteger: keystrokeWord]
		ifFalse: [self push: nilObj].! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/27/1998 15:43'!
primitiveLessOrEqual
	| integerReceiver integerArgument |
	integerArgument := self popInteger.
	integerReceiver := self popInteger.
	self checkBooleanResult: integerReceiver <= integerArgument! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveLessOrEqualLargeIntegers
	"Primitive comparison operations for large integers in 64 bit range"
	| integerRcvr integerArg |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).

	successFlag ifTrue:[
		self pop: 2.
		self pushBool: integerRcvr <= integerArg
	].
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/27/1998 15:43'!
primitiveLessThan
	| integerReceiver integerArgument |
	integerArgument := self popInteger.
	integerReceiver := self popInteger.
	self checkBooleanResult: integerReceiver < integerArgument! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveLessThanLargeIntegers
	"Primitive comparison operations for large integers in 64 bit range"
	| integerRcvr integerArg |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).

	successFlag ifTrue:[
		self pop: 2.
		self pushBool: integerRcvr < integerArg
	].
! !
!Interpreter methodsFor: 'plugin primitives' stamp: 'tpr (auto pragmas 12/08) 3/25/2004 20:02'!
primitiveListBuiltinModule
	"Primitive. Return the n-th builtin module name."
	| moduleName index length nameOop |
	<var: #moduleName type: 'char *'>
	self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
	index := self stackIntegerValue: 0.
	index <= 0 ifTrue:[^self primitiveFail].
	moduleName := self ioListBuiltinModule: index.
	moduleName == nil ifTrue:[
		self pop: 2. "arg+rcvr"
		^self push: self nilObject].
	length := self strlen: moduleName.
	nameOop := self instantiateClass: self classString indexableSize: length.
	0 to: length-1 do:[:i|
		self storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
	self forceInterruptCheck.
	self pop: 2 thenPush: nameOop! !
!Interpreter methodsFor: 'plugin primitives' stamp: 'tpr (auto pragmas 12/08) 3/25/2004 20:00'!
primitiveListExternalModule
	"Primitive. Return the n-th loaded external module name."
	| moduleName index length nameOop |
	<var: #moduleName type: 'char *'>
	self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
	index := self stackIntegerValue: 0.
	index <= 0 ifTrue:[^self primitiveFail].
	moduleName := self ioListLoadedModule: index.
	moduleName == nil ifTrue:[
		self pop: 2. "arg+rcvr"
		^self push: self nilObject].
	length := self strlen: moduleName.
	nameOop := self instantiateClass: self classString indexableSize: length.
	0 to: length-1 do:[:i|
		self storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
	self forceInterruptCheck.
	self pop: 2 thenPush: nameOop! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:41'!
primitiveLoadImageSegment
	"This primitive is called from Squeak as...
		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."

"This primitive will load a binary image segment created by primitiveStoreImageSegment.  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.  It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"

	| outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |

	<var: #endSeg type: 'usqInt'>
	<var: #segOop type: 'usqInt'>
	<var: #fieldPtr type: 'usqInt'>
	<var: #lastOut type: 'usqInt'>
	<var: #outPtr type: 'usqInt'>
	<var: #lastPtr type: 'usqInt'>

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	outPointerArray := self stackTop.
	lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
	segmentWordArray := self stackValue: 1.
	endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self baseHeaderSize.

	"Essential type checks"
	((self formatOf: outPointerArray) = 2				"Must be indexable pointers"
		and: [(self formatOf: segmentWordArray) = 6])	"Must be indexable words"
		ifFalse: [^ self primitiveFail].

	"Version check.  Byte order of the WordArray now"
	data := self longAt: segmentWordArray + self baseHeaderSize.
	(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
		"Not readable -- try again with reversed bytes..."
		self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self bytesPerWord.
		data := self longAt: segmentWordArray + self baseHeaderSize.
		(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
			"Still NG -- put things back and fail"
			self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self bytesPerWord.
			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
			^ self primitiveFail]].
	"Reverse the Byte type objects if the is data from opposite endian machine."
	"Test top byte.  $d on the Mac or $s on the PC.  Rest of word is equal."
	(data >> 16) = (self imageSegmentVersion >> 16) ifFalse: [
		"Reverse the byte-type objects once"
		segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord.
			 "Oop of first embedded object"
		self byteSwapByteObjectsFrom: segOop to: endSeg + self bytesPerWord].

	"Proceed through the segment, remapping pointers..."
	segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord.
	[segOop <= endSeg] whileTrue:
		[(self headerType: segOop) <= 1
			ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
					fieldPtr := segOop - self bytesPerWord.  doingClass := true]
			ifFalse: ["No class field -- start with first data field"
					fieldPtr := segOop + self baseHeaderSize.  doingClass := false].
		lastPtr := segOop + (self lastPointerOf: segOop).	"last field"
		lastPtr > endSeg ifTrue: [
			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
			^ self primitiveFail "out of bounds"].

		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop := self longAt: fieldPtr.
			doingClass ifTrue:
				[hdrTypeBits := self headerType: fieldPtr.
				fieldOop := fieldOop - hdrTypeBits].
			(self isIntegerObject: fieldOop)
				ifTrue:
					["Integer -- nothing to do"
					fieldPtr := fieldPtr + self bytesPerWord]
				ifFalse:
					[(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"].
					(fieldOop bitAnd: 16r80000000) = 0
						ifTrue: ["Internal pointer -- add segment offset"
								mapOop := fieldOop + segmentWordArray]
						ifFalse: ["External pointer -- look it up in outPointers"
								outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
								outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"].
								mapOop := self longAt: outPtr].
					doingClass
						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
								fieldPtr := fieldPtr + 8.
								doingClass := false]
						ifFalse: [self longAt: fieldPtr put: mapOop.
								fieldPtr := fieldPtr + self bytesPerWord].
					segOop < youngStart
						ifTrue: [self possibleRootStoreInto: segOop value: mapOop].
					]].
		segOop := self objectAfter: segOop].

	"Again, proceed through the segment checking consistency..."
	segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord.
	[segOop <= endSeg] whileTrue:
		[(self oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
		fieldPtr := segOop + self baseHeaderSize.		"first field"
		lastPtr := segOop + (self lastPointerOf: segOop).	"last field"
		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop := self longAt: fieldPtr.
			(self oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
			fieldPtr := fieldPtr + self bytesPerWord].
		segOop := self objectAfter: segOop].

	"Truncate the segment word array to size = self bytesPerWord (vers stamp only)"
	extraSize := self extraHeaderBytes: segmentWordArray.
	hdrTypeBits := self headerType: segmentWordArray.
	extraSize = 8
		ifTrue: [self longAt: segmentWordArray-extraSize put: self baseHeaderSize + self bytesPerWord + hdrTypeBits]
		ifFalse: [header := self longAt: segmentWordArray.
				self longAt: segmentWordArray
					put: header - (header bitAnd: self sizeMask) + self baseHeaderSize + self bytesPerWord].	
	"and return the roots array which was first in the segment"
	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord).
! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitiveLoadInstVar
	| thisReceiver |
	thisReceiver := self popStack.
	self push: (self fetchPointer: primitiveIndex-264 ofObject: thisReceiver)! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:31'!
primitiveLogN
	"Natural log."

	| rcvr |
	<var: #rcvr type: 'double '>
	rcvr := self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'log(rcvr)' inSmalltalk: [rcvr ln])]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'tpr 3/15/2004 14:27'!
primitiveLowSpaceSemaphore
	"Register the low-space semaphore. If the argument is not a 
	Semaphore, unregister the current low-space Semaphore."
	| arg |
	arg := self popStack.
	(self fetchClassOf: arg) = (self splObj: ClassSemaphore)
		ifTrue: [self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: arg]
		ifFalse: [self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: nilObj]! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'tpr 3/23/2004 17:01'!
primitiveMakePoint
	| rcvr argument pt |
	argument := self stackTop.
	rcvr := self stackValue: 1.
	(self isIntegerObject: rcvr)
		ifTrue: [(self isIntegerObject: argument)
				ifTrue: [pt := self makePointwithxValue: (self integerValueOf: rcvr) yValue: (self integerValueOf: argument)]
				ifFalse: [pt := self makePointwithxValue: (self integerValueOf: rcvr) yValue: 0.
					"Above may cause GC!!"
					self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)]]
		ifFalse: [(self isFloatObject: rcvr)
				ifFalse: [^ self success: false].
			pt := self makePointwithxValue: 0 yValue: 0.
			"Above may cause GC!!"
			self storePointer: 0 ofObject: pt withValue: (self stackValue: 1).
			self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)].

	self pop: 2 thenPush: pt! !
!Interpreter methodsFor: 'process primitives' stamp: 'tpr (auto pragmas 12/08) 2/20/2004 19:46'!
primitiveMarkHandlerMethod
	"Primitive. Mark the method for exception handling. The primitive must fail after marking the context so that the regular code is run."
	<inline: false>
	^self primitiveFail! !
!Interpreter methodsFor: 'process primitives' stamp: 'tpr (auto pragmas 12/08) 2/20/2004 19:46'!
primitiveMarkUnwindMethod
	"Primitive. Mark the method for exception unwinding. The primitive must fail after marking the context so that the regular code is run."
	<inline: false>
	^self primitiveFail! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'ar 11/28/1999 17:42'!
primitiveMethod
	"Return the method an external primitive was defined in"
	^newMethod! !
!Interpreter methodsFor: 'system control primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 3/27/2010 17:44'!
primitiveMicrosecondClock
	"This is a named (not numbered) primitive in the null module (ie the VM)"
	<export: true>
	self pop: 1 thenPush: (self positive64BitIntegerFor: (self ioMicroSecondClock)).
! !
!Interpreter methodsFor: 'system control primitives' stamp: 'tpr 3/9/2004 08:54'!
primitiveMillisecondClock
	"Return the value of the millisecond clock as an integer. Note that the millisecond clock wraps around periodically. On some platforms it can wrap daily. The range is limited to SmallInteger maxVal / 2 to allow delays of up to that length without overflowing a SmallInteger."

	self pop: 1 thenPush: (self integerObjectOf: (self ioMSecs bitAnd: MillisecondClockMask)).
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'tpr 3/15/2004 20:27'!
primitiveMod
	| mod |
	mod := self doPrimitiveMod: (self stackValue: 1) by: (self stackTop).
	self pop2AndPushIntegerIfOK: mod! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveModLargeIntegers
	"Primitive arithmetic operations for large integers in 64 bit range"
	| integerRcvr integerArg result oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'result' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).
	integerArg = 0 ifTrue:[self primitiveFail].
	successFlag ifFalse:[^nil].

	result := integerRcvr \\ integerArg.

	"ensure that the result has the same sign as the integerArg"
	integerArg < 0
		ifTrue: [result > 0
			ifTrue: [result := result + integerArg]]
		ifFalse: [result < 0
			ifTrue: [result := result + integerArg]].

	oopResult := self signed64BitIntegerFor: result.
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:39'!
primitiveMouseButtons
	"Obsolete on virtually all platforms; old style input polling code.
	Return the mouse button state. The low three bits encode the state of the <red><yellow><blue> mouse buttons. The next four bits encode the Smalltalk modifier bits <cmd><option><ctrl><shift>."

	| buttonWord |
	self pop: 1.
	buttonWord := self ioGetButtonState.
	self pushInteger: buttonWord.! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:39'!
primitiveMousePoint
	"Obsolete on virtually all platforms; old style input polling code.
	Return a Point indicating current position of the mouse. Note that mouse coordinates may be negative if the mouse moves above or to the left of the top-left corner of the Smalltalk window."

	| pointWord x y |
	self pop: 1.
	pointWord := self ioMousePoint.
	x := self signExtend16: ((pointWord >> 16) bitAnd: 16rFFFF).
	y := self signExtend16: (pointWord bitAnd: 16rFFFF).
	self push: (self makePointwithxValue: x  yValue: y).! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/30/1998 10:27'!
primitiveMultiply
	| integerRcvr integerArg integerResult |
	integerRcvr := self stackIntegerValue: 1.
	integerArg := self stackIntegerValue: 0.
	successFlag ifTrue:
		[integerResult := integerRcvr * integerArg.
		"check for C overflow by seeing if computation is reversible"
		((integerArg = 0) or: [(integerResult // integerArg) = integerRcvr])
			ifTrue: [self pop2AndPushIntegerIfOK: integerResult]
			ifFalse: [self primitiveFail]]! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:38'!
primitiveMultiplyLargeIntegers
	"Primitive arithmetic operations for large integers in 64 bit range"
	| integerRcvr integerArg result oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'result' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).
	successFlag ifFalse:[^nil].

	result := integerRcvr * integerArg.
	"check for C overflow by seeing if computation is reversible"
	((integerArg = 0) or: [(result // integerArg) = integerRcvr])
		ifTrue:[oopResult := self signed64BitIntegerFor: result]
		ifFalse: [self primitiveFail].

	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/23/2004 17:43'!
primitiveNew
	"Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC"

	| class spaceOkay |
	class := self stackTop.
	"The following may cause GC!!"
	spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: 0.
	self success: spaceOkay.
	successFlag ifTrue: [ self push: (self instantiateClass: self popStack indexableSize: 0) ]! !
!Interpreter methodsFor: 'compiled methods' stamp: 'dtl 5/18/2010 21:02'!
primitiveNewMethod
	| header bytecodeCount class size theMethod literalCount |
	header := self popStack.
	bytecodeCount := self popInteger.
	self success: (self isIntegerObject: header).
	successFlag ifFalse:
		[self unPop: 2. ^nil].
	class := self popStack.
	size := (self literalCountOfHeader: header) + 1 * self bytesPerWord + bytecodeCount.
	theMethod := self instantiateClass: class indexableSize: size.
	self storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
	literalCount := self literalCountOfHeader: header.
	1 to: literalCount do:
		[:i | self storePointer: i ofObject: theMethod withValue: nilObj].
	self push: theMethod! !
!Interpreter methodsFor: 'object access primitives' stamp: 'dtl 11/2/2010 18:16'!
primitiveNewWithArg
	"Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."
	| size class spaceOkay |
	<var: #size type: 'usqInt'>

	self isDefinedTrueExpression: 'SQ_IMAGE64 && SQ_HOST64'
		inSmalltalk: [size := self positive32BitValueOf: self stackTop]
		comment: 'permit large object allocation on 64 bit image and host'
		ifTrue: [size := self positive64BitValueOf: self stackTop]
		ifFalse: [size := self positive32BitValueOf: self stackTop].
	class := self stackValue: 1.
	self success: size >= 0.
	successFlag
		ifTrue: ["The following may cause GC!!"
			spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: size.
			self success: spaceOkay.
			class := self stackValue: 1].
	successFlag ifTrue: [self pop: 2 thenPush: (self instantiateClass: class indexableSize: size)]! !
!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/14/1998 14:58'!
primitiveNext
	"PrimitiveNext will succeed only if the stream's array is in the atCache.
	Otherwise failure will lead to proper message lookup of at: and
	subsequent installation in the cache if appropriate."
	| stream array index limit result atIx |
	stream := self stackTop.
	((self isPointers: stream)
		and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
		ifFalse: [^ self primitiveFail].

	array := self fetchPointer: StreamArrayIndex ofObject: stream.
	index := self fetchInteger: StreamIndexIndex ofObject: stream.
	limit := self fetchInteger: StreamReadLimitIndex ofObject: stream.
	atIx := array bitAnd: AtCacheMask.
	(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
		ifFalse: [^ self primitiveFail].

	"OK -- its not at end, and the array is in the cache"
	index := index + 1.
	result := self commonVariable: array at: index cacheIndex: atIx.
	"Above may cause GC, so can't use stream, array etc. below it"
	successFlag ifTrue:
		[stream := self stackTop.
		self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
		^ self pop: 1 thenPush: result].
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/15/2004 20:28'!
primitiveNextInstance
	| object instance |
	object := self stackTop.
	instance := self instanceAfter: object.
	instance = nilObj
		ifTrue: [self primitiveFail]
		ifFalse: [self pop: argumentCount+1 thenPush: instance]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 5/13/2005 10:20'!
primitiveNextObject
	"Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects."

	| object instance |
	object := self stackTop.
	instance := self accessibleObjectAfter: object.
	instance = nil
		ifTrue: [ self pop: argumentCount+1 thenPushInteger: 0 ]
		ifFalse: [ self pop: argumentCount+1 thenPush: instance ].! !
!Interpreter methodsFor: 'array and stream primitives' stamp: 'dtl 11/27/2009 16:18'!
primitiveNextPut
	"PrimitiveNextPut will succeed only if the stream's array is in the atPutCache.
	Otherwise failure will lead to proper message lookup of at:put: and
	subsequent installation in the cache if appropriate."
	| value stream index limit array atIx |
	value := self stackTop.
	stream := self stackValue: 1.
	((self isPointers: stream)
		and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
		ifFalse: [^ self primitiveFail].

	array := self fetchPointer: StreamArrayIndex ofObject: stream.
	index := self fetchInteger: StreamIndexIndex ofObject: stream.
	limit := self fetchInteger: StreamWriteLimitIndex ofObject: stream.
	atIx := (array bitAnd: AtCacheMask) + AtPutBase.
	(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
		ifFalse: [^ self primitiveFail].

	"OK -- its not at end, and the array is in the cache"
	index := index + 1.
	self commonVariable: array at: index put: value cacheIndex: atIx.
	successFlag ifTrue:
		[self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
		^ self pop: 2 thenPush: value].
! !
!Interpreter methodsFor: 'system control primitives'!
primitiveNoop
	"A placeholder for primitives that haven't been implemented or are being withdrawn gradually. Just absorbs any arguments and returns the receiver."

	self pop: argumentCount.  "pop args, leave rcvr on stack"! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/27/1998 15:43'!
primitiveNotEqual
	| integerReceiver integerArgument result |
	integerArgument := self popStack.
	integerReceiver := self popStack.
	result := (self compare31or32Bits: integerReceiver equal: integerArgument) not.
	self checkBooleanResult: result! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:39'!
primitiveNotEqualLargeIntegers
	"Primitive comparison operations for large integers in 64 bit range"
	| integerRcvr integerArg |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).

	successFlag ifTrue:[
		self pop: 2.
		self pushBool: integerRcvr ~= integerArg
	].
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/23/2004 17:45'!
primitiveObjectAt
"Defined for CompiledMethods only"
	| thisReceiver index |
	index  := self popInteger.
	thisReceiver := self popStack.
	self success: index > 0.
	self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).
	successFlag
		ifTrue: [self push: (self fetchPointer: index - 1 ofObject: thisReceiver)]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/23/2004 17:45'!
primitiveObjectAtPut
"Defined for CompiledMethods only"
	| thisReceiver index newValue |
	newValue := self popStack.
	index := self popInteger.
	thisReceiver := self popStack.
	self success: index > 0.
	self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).
	successFlag
		ifTrue: [self storePointer: index - 1 ofObject: thisReceiver withValue: newValue.
			self push: newValue]
		ifFalse: [self unPop: 3]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'dtl 5/18/2010 21:46'!
primitiveObjectPointsTo
	| rcvr thang lastField |
	thang := self popStack.
	rcvr := self popStack.
	(self isIntegerObject: rcvr) ifTrue: [^self pushBool: false].

	lastField := self lastPointerOf: rcvr.
	self baseHeaderSize to: lastField by: self bytesPerWord do:
		[:i | (self longAt: rcvr + i) = thang
			ifTrue: [^ self pushBool: true]].
	self pushBool: false.! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl 11/23/2010 11:02'!
primitivePerform
	| performSelector newReceiver selectorIndex lookupClass performMethod |
	performSelector := messageSelector.
	performMethod := newMethod.
	messageSelector := self stackValue: argumentCount - 1.
	newReceiver := self stackValue: argumentCount.

	"NOTE: the following lookup may fail and be converted to #doesNotUnderstand:, so we must adjust argumentCount and slide args now, so that would work."

	"Slide arguments down over selector"
	argumentCount := argumentCount - 1.
	selectorIndex := self stackPointerIndex - argumentCount.
	self
		transfer: argumentCount
		fromIndex: selectorIndex + 1
		ofObject: activeContext
		toIndex: selectorIndex
		ofObject: activeContext.
	self pop: 1.
	lookupClass := self fetchClassOf: newReceiver.
	self findNewMethodInClass: lookupClass.

	"Only test CompiledMethods for argument count - other objects will have to take their chances"
	(self isOopCompiledMethod: newMethod)
		ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].

	successFlag
		ifTrue: [self executeNewMethodFromCache.
			"Recursive xeq affects successFlag"
			successFlag := true]
		ifFalse: ["Slide the args back up (sigh) and re-insert the 
			selector. "
			1 to: argumentCount do: [:i | self
						storePointer: argumentCount - i + 1 + selectorIndex
						ofObject: activeContext
						withValue: (self fetchPointer: argumentCount - i + selectorIndex ofObject: activeContext)].
			self unPop: 1.
			self storePointer: selectorIndex
				ofObject: activeContext
				withValue: messageSelector.
			argumentCount := argumentCount + 1.
			newMethod := performMethod.
			messageSelector := performSelector]! !
!Interpreter methodsFor: 'control primitives' stamp: 'dtl 11/23/2010 11:06'!
primitivePerformAt: lookupClass
	"Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"

	"NOTE:  The case of doesNotUnderstand: is not a failure to perform.
	The only failures are arg types and consistency of argumentCount."

	| performSelector argumentArray arraySize index cntxSize performMethod performArgCount |
	argumentArray := self stackTop.
	(self isArray: argumentArray) ifFalse:[^self primitiveFail].

	successFlag ifTrue:
		["Check for enough space in thisContext to push all args"
		arraySize := self fetchWordLengthOf: argumentArray.
		cntxSize := self fetchWordLengthOf: activeContext.
		self success: (self stackPointerIndex + arraySize) < cntxSize].
	successFlag ifFalse: [^nil].

	performSelector := messageSelector.
	performMethod := newMethod.
	performArgCount := argumentCount.
	"pop the arg array and the selector, then push the args out of the array, as if they were on the stack"
	self popStack.
	messageSelector := self popStack.

	"Copy the arguments to the stack, and execute"
	index := 1.
	[index <= arraySize]
		whileTrue:
		[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
		index := index + 1].
	argumentCount := arraySize.

	self findNewMethodInClass: lookupClass.

	"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
	(self isOopCompiledMethod: newMethod)
		ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].

	successFlag
		ifTrue: [self executeNewMethodFromCache.  "Recursive xeq affects successFlag"
				successFlag := true]
		ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
				self pop: argumentCount.
				self push: messageSelector.
				self push: argumentArray.
				messageSelector := performSelector.
				newMethod := performMethod.
				argumentCount := performArgCount]
! !
!Interpreter methodsFor: 'control primitives' stamp: 'di 4/12/1999 10:57'!
primitivePerformInSuperclass
	| lookupClass rcvr currentClass |
	lookupClass := self stackTop.
	rcvr := self stackValue: argumentCount.
	currentClass := self fetchClassOf: rcvr.
	[currentClass ~= lookupClass]
		whileTrue:
		[currentClass := self superclassOf: currentClass.
		currentClass = nilObj ifTrue: [^ self primitiveFail]].

	self popStack.
	self primitivePerformAt: lookupClass.
	successFlag ifFalse:
		[self push: lookupClass]! !
!Interpreter methodsFor: 'control primitives' stamp: 'di 4/12/1999 10:55'!
primitivePerformWithArgs

	| lookupClass rcvr |
	rcvr := self stackValue: argumentCount.
	lookupClass := self fetchClassOf: rcvr.
	self primitivePerformAt: lookupClass.
! !
!Interpreter methodsFor: 'other primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/9/2010 00:49'!
primitivePlatformSourceVersion
	"Answer a string corresponding to the version of the external platform source
	code, typically written in C and managed separately for each platform.
	This is a named (not numbered) primitive in the null module (ie the VM)"
	| len versionString p |
	<export: true>
	<var: #p type: 'char *'>
	self isDefined: 'PLATFORM_SOURCE_VERSION'
		inSmalltalk: [versionString := '']
		comment: 'version level of platform support code'
		ifTrue: [len := self cCode: 'strlen(PLATFORM_SOURCE_VERSION)' inSmalltalk: [0].
			versionString := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: len.
			p := interpreterProxy arrayValueOf: versionString.
			self cCode: 'strncpy(p, PLATFORM_SOURCE_VERSION, len)']
		ifFalse: [^interpreterProxy primitiveFail].
	self pop: 1 thenPush: versionString! !
!Interpreter methodsFor: 'object access primitives' stamp: 'jm (auto pragmas 12/08) 12/10/1998 18:49'!
primitivePointX
	| rcvr | 
	<inline: false>
	rcvr := self popStack.
	self assertClassOf: rcvr is: (self splObj: ClassPoint).
	successFlag
		ifTrue: [self push: (self fetchPointer: XIndex ofObject: rcvr)]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'jm (auto pragmas 12/08) 12/10/1998 18:50'!
primitivePointY
	| rcvr | 
	<inline: false>
	rcvr := self popStack.
	self assertClassOf: rcvr is: (self splObj: ClassPoint).
	successFlag
		ifTrue: [self push: (self fetchPointer: YIndex ofObject: rcvr)]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushFalse
	self popStack.
	self push: falseObj! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushMinusOne
	self popStack.
	self push: ConstMinusOne! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushNil
	self popStack.
	self push: nilObj! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushOne
	self popStack.
	self push: ConstOne! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushSelf
"	no-op, really...
	thisReceiver := self popStack.
	self push: thisReceiver
"! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushTrue
	self popStack.
	self push: trueObj! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushTwo
	self popStack.
	self push: ConstTwo! !
!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushZero
	self popStack.
	self push: ConstZero! !
!Interpreter methodsFor: 'system control primitives'!
primitiveQuit

	self ioExit.
! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/30/1998 10:19'!
primitiveQuo
	"Rounds negative results towards zero."
	| integerRcvr integerArg integerResult |
	integerRcvr := self stackIntegerValue: 1.
	integerArg := self stackIntegerValue: 0.
	self success: integerArg ~= 0.
	successFlag ifTrue: [
		integerRcvr > 0 ifTrue: [
			integerArg > 0 ifTrue: [
				integerResult := integerRcvr // integerArg.
			] ifFalse: [
				integerResult := 0 - (integerRcvr // (0 - integerArg)).
			].
		] ifFalse: [
			integerArg > 0 ifTrue: [
				integerResult := 0 - ((0 - integerRcvr) // integerArg).
			] ifFalse: [
				integerResult := (0 - integerRcvr) // (0 - integerArg).
			].
		]].
	self pop2AndPushIntegerIfOK: integerResult! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'ar (auto pragmas 12/08) 3/19/2008 21:39'!
primitiveQuoLargeIntegers
	"Primitive arithmetic operations for large integers in 64 bit range"
	| integerRcvr integerArg result oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'result' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).
	integerArg = 0 ifTrue:[self primitiveFail].
	successFlag ifFalse:[^nil].

	integerRcvr > 0 ifTrue: [
		integerArg > 0 
			ifTrue: [result := integerRcvr // integerArg]
			ifFalse: [result := 0 - (integerRcvr // (0 - integerArg))].
	] ifFalse: [
		integerArg > 0 
			ifTrue: [result := 0 - ((0 - integerRcvr) // integerArg)]
			ifFalse: [result := (0 - integerRcvr) // (0 - integerArg)].
	].

	oopResult := self signed64BitIntegerFor: result.
	successFlag ifTrue:[self pop: 2 thenPush: oopResult].
! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:40'!
primitiveRelinquishProcessor
	"Relinquish the processor for up to the given number of microseconds. The exact behavior of this primitive is platform dependent."

	| microSecs |
	microSecs := self stackIntegerValue: 0.
	successFlag ifTrue: [
		self ioRelinquishProcessorForMicroseconds: microSecs.
		self pop: 1]  "microSecs; leave rcvr on stack"
! !
!Interpreter methodsFor: 'primitive support' stamp: 'ar 6/8/2006 11:13'!
primitiveResponse
	"NB: tpr removed the timer checks here and moved them to the primitiveExternalCall method.
	We make the possibly unwarranted assumption that numbered prims are quick and external prims are slow."

	| delta primIdx nArgs |
	DoBalanceChecks ifTrue:["check stack balance"
		nArgs := argumentCount.
		delta := stackPointer - activeContext.
	].
	primIdx := primitiveIndex.
	successFlag := true.
	"self dispatchOn: primitiveIndex in: primitiveTable."
	self dispatchFunctionPointerOn: primIdx in: primitiveTable.
	"replace with fetch entry primitiveIndex from table and branch there"
	DoBalanceChecks ifTrue:[
		(self balancedStack: delta afterPrimitive: primIdx withArgs: nArgs) 
			ifFalse:[self printUnbalancedStack: primIdx].
	].
	primitiveIndex := 0. "clear out primIndex so VM knows we're no longer in primitive"
	^ successFlag
! !
!Interpreter methodsFor: 'process primitives' stamp: 'tpr 3/15/2004 14:32'!
primitiveResume
"put this process on the scheduler's lists thus allowing it to proceed next time there is a chance for processes of it's priority level"
	| proc |
	proc := self stackTop.  "rcvr"
	"self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))."
	successFlag ifTrue: [ self resume: proc ].! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'ar (auto pragmas 12/08) 1/18/2005 17:10'!
primitiveRootTable
	"Primitive. Answer a copy (snapshot) element of the root table.
	The primitive can cause GC itself and if so the return value may
	be inaccurate - in this case one should guard the read operation
	by looking at the gc counter statistics."
	| oop sz |
	<export: true>
	sz := rootTableCount.
	oop := self instantiateClass: self classArray indexableSize: sz. "can cause GC"
	sz > rootTableCount ifTrue:[sz := rootTableCount].
	1 to: sz do:[:i| 
		self storePointer: i-1 ofObject: oop withValue: (rootTable at: i).
	].
	self pop: argumentCount + 1.
	self push: oop.! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'ar (auto pragmas 12/08) 1/18/2005 15:59'!
primitiveRootTableAt
	"Primitive. Answer the nth element of the root table.
	This primitive avoids the creation of an extra array;
	it is intended for enumerations of the form:
		index := 1.
		[root := Smalltalk rootTableAt: index.
		root == nil] whileFalse:[index := index + 1].
	"
	| index |
	<export: true>
	index := self stackIntegerValue: 0.
	self success: (index > 0 and:[index <= rootTableCount]).
	successFlag ifTrue:[
		self pop: argumentCount + 1.
		self push: (rootTable at: index).
	].! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 12:56'!
primitiveScanCharacters
	"The character scanner primitive."
	| kernDelta stops sourceString scanStopIndex scanStartIndex rcvr scanDestX scanLastIndex scanXTable scanMap maxGlyph ascii stopReason glyphIndex sourceX sourceX2 nextDestX scanRightX nilOop |

	self methodArgumentCount = 6
		ifFalse: [^ self primitiveFail].

	"Load the arguments"
	kernDelta := self stackIntegerValue: 0.
	stops := self stackObjectValue: 1.
	(self isArray: stops) ifFalse: [^ self primitiveFail].
	(self slotSizeOf: stops) >= 258 ifFalse: [^ self primitiveFail].
	scanRightX := self stackIntegerValue: 2.
	sourceString := self stackObjectValue: 3.
	(self isBytes: sourceString) ifFalse: [^ self primitiveFail].
	scanStopIndex := self stackIntegerValue: 4.
	scanStartIndex := self stackIntegerValue: 5.
	(scanStartIndex > 0 and: [scanStopIndex > 0 and: [scanStopIndex <= (self byteSizeOf: sourceString)]])
		ifFalse: [^ self primitiveFail].

	"Load receiver and required instVars"
	rcvr := self stackObjectValue: 6.
	((self isPointers: rcvr) and: [(self slotSizeOf: rcvr) >= 4]) ifFalse: [^ self primitiveFail].
	scanDestX := self fetchInteger: 0 ofObject: rcvr.
	scanLastIndex := self fetchInteger: 1 ofObject: rcvr.
	scanXTable := self fetchPointer: 2 ofObject: rcvr.
	scanMap := self fetchPointer: 3 ofObject: rcvr.
	((self isArray: scanXTable) and: [self isArray: scanMap]) ifFalse: [^ self primitiveFail].
	(self slotSizeOf: scanMap) = 256 ifFalse: [^ self primitiveFail].
	successFlag ifFalse: [^ nil].
	maxGlyph := (self slotSizeOf: scanXTable) - 2.

	"Okay, here we go. We have eliminated nearly all failure 
	conditions, to optimize the inner fetches."
	scanLastIndex := scanStartIndex.
	nilOop := self nilObject.
	[scanLastIndex <= scanStopIndex]
		whileTrue: [
			"Known to be okay since scanStartIndex > 0 and scanStopIndex <= sourceString size"
			ascii := self fetchByte: scanLastIndex - 1 ofObject: sourceString.
			"Known to be okay since stops size >= 258"
			(stopReason := self fetchPointer: ascii ofObject: stops) = nilOop
				ifFalse: ["Store everything back and get out of here since some stop conditionn needs to be checked"
					(self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
					self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
					self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex.
					self pop: 7. "args+rcvr"
					^ self push: stopReason].
			"Known to be okay since scanMap size = 256"
			glyphIndex := self fetchInteger: ascii ofObject: scanMap.
			"fail if the glyphIndex is out of range"
			(self failed or: [glyphIndex < 0 	or: [glyphIndex > maxGlyph]]) ifTrue: [^ self primitiveFail].
			sourceX := self fetchInteger: glyphIndex ofObject: scanXTable.
			sourceX2 := self fetchInteger: glyphIndex + 1 ofObject: scanXTable.
			"Above may fail if non-integer entries in scanXTable"
			self failed ifTrue: [^ nil].
			nextDestX := scanDestX + sourceX2 - sourceX.
			nextDestX > scanRightX
				ifTrue: ["Store everything back and get out of here since we got to the right edge"
					(self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
					self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
					self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex.
					self pop: 7. "args+rcvr"
					^ self push: (self fetchPointer: CrossedX - 1 ofObject: stops)].
			scanDestX := nextDestX + kernDelta.
			scanLastIndex := scanLastIndex + 1].
	(self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
	self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
	self storeInteger: 1 ofObject: rcvr withValue: scanStopIndex.
	self pop: 7. "args+rcvr"
	^ self push: (self fetchPointer: EndOfRun - 1 ofObject: stops)! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr (auto pragmas 12/08) 5/13/2005 10:20'!
primitiveScreenDepth
	"Return a SmallInteger indicating the current depth of the OS screen. Negative values are used to imply LSB type pixel format an there is some support in the VM for handling either MSB or LSB"
	| depth |
	<export: true>
	depth := self ioScreenDepth.
	self failed ifTrue:[^self primitiveFail].
	self pop: 1 thenPushInteger: depth.! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 14:22'!
primitiveScreenSize
	"Return a point indicating the current size of the Smalltalk window. Currently there is a limit of 65535 in each direction because the point is encoded into a single 32bit value in the image header. This might well become a problem one day"
	| pointWord |
	self pop: 1.
	pointWord := self ioScreenSize.
	self push: (self makePointwithxValue: (pointWord >> 16 bitAnd: 65535) yValue: (pointWord bitAnd: 65535))! !
!Interpreter methodsFor: 'system control primitives' stamp: 'tpr 3/9/2004 08:57'!
primitiveSecondsClock
	"Return the number of seconds since January 1, 1901 as an integer."

	self pop: 1 thenPush: (self positive32BitIntegerFor: self ioSeconds).! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 20:29'!
primitiveSetDisplayMode
	"Set to OS to the requested display mode.
	See also DisplayScreen setDisplayDepth:extent:fullscreen:"
	| fsFlag h w d okay |
	fsFlag := self booleanValueOf: (self stackTop).
	h := self stackIntegerValue: 1.
	w := self stackIntegerValue: 2.
	d := self stackIntegerValue: 3.
	successFlag ifTrue: [okay := self cCode:'ioSetDisplayMode(w, h, d, fsFlag)'].
	successFlag ifTrue: [
		self pop: 5. "Pop args+rcvr"
		self pushBool: okay].! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 14:23'!
primitiveSetFullScreen
	"On platforms that support it, set full-screen mode to the value of the boolean argument."

	| argOop |
	argOop := self stackTop.
	argOop = trueObj
		ifTrue: [self ioSetFullScreen: true]
		ifFalse: [ argOop = falseObj
				ifTrue: [self ioSetFullScreen: false]
				ifFalse: [self primitiveFail]].
	successFlag ifTrue: [self pop: 1].
! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'JMM (auto pragmas 12/08) 1/27/2005 12:30'!
primitiveSetGCBiasToGrow
	"Primitive. Indicate if the GC logic should have bias to grow"
	| flag |
	<export: true>
	flag := self stackIntegerValue: 0.
	successFlag ifTrue:[
		gcBiasToGrow := flag.
		self pop: argumentCount.
	].! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'JMM (auto pragmas 12/08) 1/27/2005 15:55'!
primitiveSetGCBiasToGrowGCLimit
	"Primitive. If the GC logic has  bias to grow, set growth limit"
	| value |
	<export: true>
	value := self stackIntegerValue: 0.
	successFlag ifTrue:[
		gcBiasToGrowGCLimit := value.
		gcBiasToGrowThreshold := youngStart - (self cCoerce: memory to: 'int').
		self pop: argumentCount.
	].! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'ar (auto pragmas 12/08) 1/18/2005 15:42'!
primitiveSetGCSemaphore
	"Primitive. Indicate the semaphore to be signalled for upon garbage collection"
	| index |
	<export: true>
	index := self stackIntegerValue: 0.
	successFlag ifTrue:[
		gcSemaphoreIndex := index.
		self pop: argumentCount.
	].! !
!Interpreter methodsFor: 'I/O primitives'!
primitiveSetInterruptKey
	"Set the user interrupt keycode. The keycode is an integer whose encoding is described in the comment for primitiveKbdNext."

	| keycode |
	keycode := self popInteger.
	successFlag
		ifTrue: [ interruptKeycode := keycode ]
		ifFalse: [ self unPop: 1 ].! !
!Interpreter methodsFor: 'array primitives' stamp: 'dtl 5/18/2010 21:46'!
primitiveShortAt
	"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."

	| index rcvr sz addr value |
	index := self stackIntegerValue: 0.
	rcvr := self stackValue: 1.
	self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
	successFlag ifFalse: [ ^ nil ].
	sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2.  "number of 16-bit fields"
	self success: ((index >= 1) and: [index <= sz]).
	successFlag ifTrue: [
		addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
		value := self shortAt: addr.
		self pop: 2 thenPushInteger: value. 
	]! !
!Interpreter methodsFor: 'array primitives' stamp: 'dtl 5/18/2010 21:46'!
primitiveShortAtPut
	"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."

	| index rcvr sz addr value |
	value := self stackIntegerValue: 0.
	index := self stackIntegerValue: 1.
	rcvr := self stackValue: 2.
	self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
	successFlag ifFalse: [ ^ nil ].
	sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2.  "number of 16-bit fields"
	self success: ((index >= 1) and: [index <= sz]).
	self success: ((value >= -32768) and: [value <= 32767]).
	successFlag ifTrue: [
		addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
		self shortAt: addr put: value.
		self pop: 2.  "pop index and value; leave rcvr on stack"
	]! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'tpr 3/15/2004 14:24'!
primitiveShowDisplayRect
	"Force the given rectangular section of the Display to be 
	copied to the screen."
	| bottom top right left |
	bottom := self stackIntegerValue: 0.
	top := self stackIntegerValue: 1.
	right := self stackIntegerValue: 2.
	left := self stackIntegerValue: 3.
	self displayBitsOf: (self splObj: TheDisplay) Left: left Top: top Right: right Bottom: bottom.
	successFlag
		ifTrue: [self ioForceDisplayUpdate.
			self pop: 4]! !
!Interpreter methodsFor: 'process primitives' stamp: 'tpr 3/15/2004 14:33'!
primitiveSignal
"synchromously signal the semaphore. This may change the active process as a result"
	| sema |
	sema := self stackTop.  "rcvr"
	self assertClassOf: sema is: (self splObj: ClassSemaphore).
	successFlag ifTrue: [ self synchronousSignal: sema ].! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'tpr 3/15/2004 14:28'!
primitiveSignalAtBytesLeft
	"Set the low-water mark for free space. When the free space 
	falls below this level, the new and new: primitives fail and 
	system attempts to allocate space (e.g., to create a method 
	context) cause the low-space semaphore (if one is 
	registered) to be signalled."
	| bytes |
	bytes := self popInteger.
	successFlag
		ifTrue: [lowSpaceThreshold := bytes]
		ifFalse: [lowSpaceThreshold := 0.
			self unPop: 1]! !
!Interpreter methodsFor: 'system control primitives' stamp: 'tpr 5/9/2005 18:58'!
primitiveSignalAtMilliseconds
	"Cause the time semaphore, if one has been registered, to
	be signalled when the millisecond clock is greater than or
	equal to the given tick value. A tick value of zero turns off
	timer interrupts."
	| tick sema |
	tick := self popInteger.
	sema := self popStack.
	successFlag
		ifTrue: [(self fetchClassOf: sema) = (self splObj: ClassSemaphore)
				ifTrue: [self
						storePointer: TheTimerSemaphore
						ofObject: specialObjectsOop
						withValue: sema.
					nextWakeupTick := tick]
				ifFalse: [self
						storePointer: TheTimerSemaphore
						ofObject: specialObjectsOop
						withValue: nilObj.
					nextWakeupTick := 0]]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:31'!
primitiveSine

	| rcvr |
	<var: #rcvr type: 'double '>
	rcvr := self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'sin(rcvr)' inSmalltalk: [rcvr sin])]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'array primitives' stamp: 'di 3/29/1999 11:28'!
primitiveSize
	| rcvr sz |
	rcvr := self stackTop.
	(self isIntegerObject: rcvr) ifTrue: [^ self primitiveFail].  "Integers are not indexable"
	(self formatOf: rcvr) < 2 ifTrue: [^ self primitiveFail].  "This is not an indexable object"
	sz := self stSizeOf: rcvr.
	successFlag ifTrue:
		[self pop: 1 thenPush: (self positive32BitIntegerFor: sz)]
! !
!Interpreter methodsFor: 'system control primitives' stamp: 'tpr (auto pragmas 12/08) 5/9/2005 19:03'!
primitiveSnapshot
"save a normal snapshot under the same name as it was loaded unless it has been renamed by the last primitiveImageName"
	<inline: false>
	^self snapshot: false
! !
!Interpreter methodsFor: 'system control primitives' stamp: 'tpr (auto pragmas 12/08) 3/9/2004 09:20'!
primitiveSnapshotEmbedded
"save an embedded snapshot"
	<inline: false>
	^self snapshot: true! !
!Interpreter methodsFor: 'object access primitives' stamp: 'tpr 3/15/2004 20:29'!
primitiveSomeInstance
	| class instance |
	class := self stackTop.
	instance := self initialInstanceOf: class.
	instance = nilObj
		ifTrue: [self primitiveFail]
		ifFalse: [self pop: argumentCount+1 thenPush: instance]! !
!Interpreter methodsFor: 'object access primitives' stamp: 'ls 7/4/2003 15:14'!
primitiveSomeObject
	"Return the first object in the heap."

	self pop: argumentCount+1.
	self push: self firstAccessibleObject.! !
!Interpreter methodsFor: 'system control primitives' stamp: 'tpr 3/9/2004 09:20'!
primitiveSpecialObjectsOop
	"Return the oop of the SpecialObjectsArray."

	self pop: 1 thenPush: specialObjectsOop.! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:31'!
primitiveSquareRoot
	| rcvr |
	<var: #rcvr type: 'double '>
	rcvr := self popFloat.
	self success: rcvr >= 0.0.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'sqrt(rcvr)' inSmalltalk: [rcvr sqrt])]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:02'!
primitiveStoreImageSegment
	"This primitive is called from Squeak as...
		<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray."

"This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  All pointers from within the tree to objects outside the tree will be copied into the array of outpointers.  In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set."

"The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers).  If either array is too small, the primitive will fail, but in no other case.

During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values.  To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type).  Tables are kept of both kinds of oops, as well as of the original headers for restoration.

To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray.  Each grows oops from the bottom up, and preserved headers from halfway up.

In case of either success or failure, the headers must be restored.  In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded."

	| outPointerArray segmentWordArray savedYoungStart lastOut lastIn firstIn lastSeg endSeg segOop fieldPtr fieldOop mapOop doingClass lastPtr extraSize hdrTypeBits arrayOfRoots hdrBaseIn hdrBaseOut header firstOut versionOffset |

	<var: #firstIn type: 'usqInt'>
	<var: #lastIn type: 'usqInt'>
	<var: #firstOut type: 'usqInt'>
	<var: #lastOut type: 'usqInt'>
	<var: #hdrBaseIn type: 'usqInt'>
	<var: #hdrBaseOut type: 'usqInt'>
	<var: #lastSeg type: 'usqInt'>
	<var: #endSeg type: 'usqInt'>
	<var: #fieldPtr type: 'usqInt'>
	<var: #lastPtr type: 'usqInt'>
	<var: #segOop type: 'usqInt'>
	<var: #savedYoungStart type: 'usqInt'>

	outPointerArray := self stackTop.
	segmentWordArray := self stackValue: 1.
	arrayOfRoots := self stackValue: 2.

	"Essential type checks"
	((self formatOf: arrayOfRoots) = 2				"Must be indexable pointers"
		and: [(self formatOf: outPointerArray) = 2				"Must be indexable pointers"
		and: [(self formatOf: segmentWordArray) = 6]])	"Must be indexable words"
		ifFalse: [^ self primitiveFail].
	((self headerType: outPointerArray) = HeaderTypeSizeAndClass	"Must be 3-word header"
		and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass])	"Must be 3-word header"
		ifFalse: [^ self primitiveFail].

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	"Use the top half of outPointers for saved headers."
	firstOut := outPointerArray + self baseHeaderSize.
	lastOut := firstOut - self bytesPerWord.
	hdrBaseOut := outPointerArray + ((self lastPointerOf: outPointerArray) // (self bytesPerWord * 2) * self bytesPerWord). "top half"

	lastSeg := segmentWordArray.
	endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self bytesPerWord.

	"Write a version number for byte order and version check"
	versionOffset := self bytesPerWord.
	lastSeg := lastSeg + versionOffset.
	lastSeg > endSeg ifTrue: [^ self primitiveFail].
	self longAt: lastSeg put: self imageSegmentVersion.

	"Allocate top 1/8 of segment for table of internal oops and saved headers"
	firstIn := endSeg - ((self sizeBitsOf: segmentWordArray) // (self bytesPerWord * 8) * self bytesPerWord).  "Take 1/8 of seg"
	lastIn := firstIn - self bytesPerWord.
	hdrBaseIn := firstIn + ((self sizeBitsOf: segmentWordArray) // (self bytesPerWord * 16) * self bytesPerWord). "top half of that"

	"First mark the rootArray and all root objects."
	self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitOr: self markBit).
	lastPtr := arrayOfRoots + (self lastPointerOf: arrayOfRoots).
	fieldPtr := arrayOfRoots + self baseHeaderSize.
	[fieldPtr <= lastPtr] whileTrue:
		[fieldOop := self longAt: fieldPtr.
		(self isIntegerObject: fieldOop) ifFalse:
			[self longAt: fieldOop put: ((self longAt: fieldOop) bitOr: self markBit)].
		fieldPtr := fieldPtr + self bytesPerWord].

	"Then do a mark pass over all objects.  This will stop at our marked roots,
	thus leaving our segment unmarked in their shadow."
	savedYoungStart := youngStart.
	youngStart := self startOfMemory.  "process all of memory"
		"clear the recycled context lists"
		freeContexts := NilContext.
		freeLargeContexts := NilContext.
	self markAndTraceInterpreterOops.	"and special objects array"
	youngStart := savedYoungStart.
	
	"Finally unmark the rootArray and all root objects."
	self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitAnd: self allButMarkBit).
	fieldPtr := arrayOfRoots + self baseHeaderSize.
	[fieldPtr <= lastPtr] whileTrue:
		[fieldOop := self longAt: fieldPtr.
		(self isIntegerObject: fieldOop) ifFalse:
			[self longAt: fieldOop put: ((self longAt: fieldOop) bitAnd: self allButMarkBit)].
		fieldPtr := fieldPtr + self bytesPerWord].

	"All external objects, and only they, are now marked.
	Copy the array of roots into the segment, and forward its oop."
	lastIn := lastIn + self bytesPerWord.
	lastIn >= hdrBaseIn ifTrue: [successFlag := false].
	lastSeg := self copyObj: arrayOfRoots toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn).
	successFlag ifFalse:
		[lastIn := lastIn - self bytesPerWord.
		self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
		^ self primitiveFailAfterCleanup: outPointerArray].

	"Now run through the segment fixing up all the pointers.
	Note that more objects will be added to the segment as we make our way along."
	segOop := self oopFromChunk: segmentWordArray + versionOffset + self baseHeaderSize.
	[segOop <= lastSeg] whileTrue:
		[(self headerType: segOop) <= 1
			ifTrue: ["This object has a class field (type=0 or 1) -- start with that."
					fieldPtr := segOop - self bytesPerWord.  doingClass := true]
			ifFalse: ["No class field -- start with first data field"
					fieldPtr := segOop + self baseHeaderSize.  doingClass := false].
		lastPtr := segOop + (self lastPointerOf: segOop).	"last field"

		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop := self longAt: fieldPtr.
			doingClass ifTrue:
				[hdrTypeBits := fieldOop bitAnd: TypeMask.
				fieldOop := fieldOop - hdrTypeBits].
			(self isIntegerObject: fieldOop)
				ifTrue: ["Just an integer -- nothing to do"
						fieldPtr := fieldPtr + self bytesPerWord]
				ifFalse:
				[header := self longAt: fieldOop.
				(header bitAnd: TypeMask) = HeaderTypeFree
					ifTrue: ["Has already been forwarded -- this is the link"
							mapOop := header bitAnd: self allButTypeMask]
					ifFalse:
					[((self longAt: fieldOop) bitAnd: self markBit) = 0
						ifTrue:
							["Points to an unmarked obj -- an internal pointer.
							Copy the object into the segment, and forward its oop."
							lastIn := lastIn + self bytesPerWord.
							lastIn >= hdrBaseIn ifTrue: [successFlag := false].
							lastSeg := self copyObj: fieldOop toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn).
							successFlag ifFalse:
								["Out of space in segment"
								lastIn := lastIn - self bytesPerWord.
								self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
								^ self primitiveFailAfterCleanup: outPointerArray].
							mapOop := (self longAt: fieldOop) bitAnd: self allButTypeMask]
						ifFalse:
							["Points to a marked obj -- an external pointer.
							Map it as a tagged index in outPointers, and forward its oop."
							lastOut := lastOut + self bytesPerWord.
							lastOut >= hdrBaseOut ifTrue:
								["Out of space in outPointerArray"
								lastOut := lastOut - self bytesPerWord.
								self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
								^ self primitiveFailAfterCleanup: outPointerArray].
.							mapOop := lastOut - outPointerArray bitOr: 16r80000000.
							self forward: fieldOop to: mapOop
								savingOopAt: lastOut andHeaderAt: hdrBaseOut + (lastOut - firstOut)]].
					"Replace the oop by its mapped value"
					doingClass
						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
								fieldPtr := fieldPtr + (self bytesPerWord*2).
								doingClass := false]
						ifFalse: [self longAt: fieldPtr put: mapOop.
								fieldPtr := fieldPtr + self bytesPerWord].
]].
		segOop := self objectAfter: segOop].

	self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.

	"Truncate the outPointerArray..."
	((outPointerArray + (self lastPointerOf: outPointerArray) - lastOut) < 12
		or: [(endSeg - lastSeg) < 12]) ifTrue:
			["Not enough room to insert simple 3-word headers"
			^ self primitiveFailAfterCleanup: outPointerArray].
	extraSize := self extraHeaderBytes: segmentWordArray.
	hdrTypeBits := self headerType: segmentWordArray.
	"Copy the 3-word wordArray header to establish a free chunk."
	self transfer: 3
		from: segmentWordArray - extraSize
		to: lastOut+self bytesPerWord.
	"Adjust the size of the original as well as the free chunk."
	self longAt: lastOut+self bytesPerWord
		put: outPointerArray + (self lastPointerOf: outPointerArray) - lastOut - extraSize + hdrTypeBits.
	self longAt: outPointerArray-extraSize
		put: lastOut - firstOut + (self bytesPerWord*2) + hdrTypeBits.
	"Note that pointers have been stored into roots table"
	self beRootIfOld: outPointerArray.

	"Truncate the image segment..."
	"Copy the 3-word wordArray header to establish a free chunk."
	self transfer: 3
		from: segmentWordArray - extraSize
		to: lastSeg+self bytesPerWord.
	"Adjust the size of the original as well as the free chunk."
	self longAt: segmentWordArray-extraSize
		put: lastSeg - segmentWordArray + self baseHeaderSize + hdrTypeBits.
	self longAt: lastSeg+self bytesPerWord
		put: endSeg - lastSeg - extraSize + hdrTypeBits.

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self pop: 3.  "...leaving the receiver on the stack as return value"
! !
!Interpreter methodsFor: 'object access primitives' stamp: 'dtl 5/19/2010 11:27'!
primitiveStoreStackp
	"Atomic store into context stackPointer. 
	Also ensures that any newly accessible cells are initialized to nil "
	| ctxt newStackp stackp |
	ctxt := self stackValue: 1.
	newStackp := self stackIntegerValue: 0.
	self success: (self oop: newStackp isGreaterThanOrEqualTo: 0).
	self success: (self oop: newStackp isLessThanOrEqualTo: (self largeContextSize - self baseHeaderSize // self bytesPerWord - CtxtTempFrameStart)).
	successFlag ifFalse: [^ self primitiveFail].
	stackp := self fetchStackPointerOf: ctxt.
	(self oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells"
			stackp + 1 to: newStackp do: [:i | self storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj]].
	self storeStackPointerValue: newStackp inContext: ctxt.
	self pop: 1! !
!Interpreter methodsFor: 'array primitives'!
primitiveStringAt

	self commonAt: true.! !
!Interpreter methodsFor: 'array primitives'!
primitiveStringAtPut

	self commonAtPut: true.! !
!Interpreter methodsFor: 'array primitives' stamp: 'ikp 3/29/2005 22:34'!
primitiveStringReplace
	" 
	<array> primReplaceFrom: start to: stop with: replacement 
	startingAt: repStart  
	<primitive: 105>
	"
	| array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex |
	array := self stackValue: 4.
	start := self stackIntegerValue: 3.
	stop := self stackIntegerValue: 2.
	repl := self stackValue: 1.
	replStart := self stackIntegerValue: 0.

	successFlag ifFalse: [^ self primitiveFail].
	(self isIntegerObject: repl) ifTrue: ["can happen in LgInt copy"
			^ self primitiveFail].

	hdr := self baseHeader: array.
	arrayFmt := hdr >> 8 bitAnd: 15.
	totalLength := self lengthOf: array baseHeader: hdr format: arrayFmt.
	arrayInstSize := self fixedFieldsOf: array format: arrayFmt length: totalLength.
	(start >= 1 and: [start - 1 <= stop and: [stop + arrayInstSize <= totalLength]])
		ifFalse: [^ self primitiveFail].

	hdr := self baseHeader: repl.
	replFmt := hdr >> 8 bitAnd: 15.
	totalLength := self lengthOf: repl baseHeader: hdr format: replFmt.
	replInstSize := self fixedFieldsOf: repl format: replFmt length: totalLength.
	(replStart >= 1 and: [stop - start + replStart + replInstSize <= totalLength])
		ifFalse: [^ self primitiveFail].

	"Array formats (without byteSize bits, if bytes array) must be same "
	arrayFmt < 8
		ifTrue: [arrayFmt = replFmt
				ifFalse: [^ self primitiveFail]]
		ifFalse: [(arrayFmt bitAnd: 12) = (replFmt bitAnd: 12)
				ifFalse: [^ self primitiveFail]].

	srcIndex := replStart + replInstSize - 1.
	"- 1 for 0-based access"

	arrayFmt <= 4
		ifTrue: ["pointer type objects"
			start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i |
				self storePointer: i ofObject: array withValue: (self fetchPointer: srcIndex ofObject: repl).
					srcIndex := srcIndex + 1]]
		ifFalse: [arrayFmt < 8
				ifTrue: ["32-bit-word type objects"
					start + arrayInstSize - 1 to: stop + arrayInstSize - 1
						do: [:i | self storeLong32: i ofObject: array withValue: (self fetchLong32: srcIndex ofObject: repl).
							srcIndex := srcIndex + 1]]
				ifFalse: ["byte-type objects"
					start + arrayInstSize - 1 to: stop + arrayInstSize - 1
						do: [:i |  self storeByte: i ofObject: array withValue: (self fetchByte: srcIndex ofObject: repl).
							srcIndex := srcIndex + 1]]].
	"We might consider  comparing stop - start to some value here and using forceInterruptCheck"

	self pop: argumentCount "leave rcvr on stack"! !
!Interpreter methodsFor: 'arithmetic integer primitives' stamp: 'di 11/30/1998 10:13'!
primitiveSubtract

	self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) - (self stackIntegerValue: 0)! !
!Interpreter methodsFor: 'arithmetic largeint primitives' stamp: 'eem 1/13/2009 15:12'!
primitiveSubtractLargeIntegers
	"Primitive arithmetic operations for large integers in 64 bit range"
	| integerRcvr integerArg integerArgNegated result oopResult |
	<export: true>
	<var: 'integerRcvr' type: 'sqLong'>
	<var: 'integerArg' type: 'sqLong'>
	<var: 'integerArgNegated' type: 'sqLong'>
	<var: 'result' type: 'sqLong'>

	integerArg := self signed64BitValueOf: (self stackValue: 0).
	integerRcvr := self signed64BitValueOf: (self stackValue: 1).
	successFlag ifFalse:
		[^nil].

	"In the test for the argument being most -ve we would
	 have to check for zero if we don't do so here.
	 So do so here and short-circuit the whole subtraction."
	integerArg = 0
		ifTrue: [result := integerRcvr]
		ifFalse:
			["Reverse the argument so that we can recycle the overflow code from addition.
			 But the most -ve 64-bit value can overflow, so check; 0 - most -ve = most -ve"
			integerArgNegated := 0 - integerArg.
			integerArgNegated = integerArg ifTrue:
				[^self primitiveFail].

			"Compute the preliminary result (which may overflow)"
			result := integerRcvr + integerArgNegated.

			"Now check overflow conditions. First is whether rcvr and arg are of the same sign.
			 If they are we need to check for overflow more carefully."
			(integerRcvr bitXor: integerArgNegated) < 0 ifFalse:
				"Second is whether rcvr and result are of the same sign. If not, we have an overflow."
				[(integerRcvr bitXor: result) < 0 ifTrue:
					[^self primitiveFail]]].

	oopResult := self signed64BitIntegerFor: result.
	successFlag ifTrue:
		[self pop: 2 thenPush: oopResult]! !
!Interpreter methodsFor: 'process primitives' stamp: 'ar 12/31/2010 10:28'!
primitiveSuspend
	"Primitive. Suspend the receiver, aProcess such that it can be executed again
	by sending #resume. If the given process is not currently running, take it off
	its corresponding list. The primitive returns the list the receiver was previously on."

	| process activeProc myList |
	process := self stackTop.
	activeProc := self fetchPointer: ActiveProcessIndex
						 ofObject: self schedulerPointer.
	process == activeProc ifTrue:[
		self pop: 1.
		self push: nilObj.
		self transferTo: self wakeHighestPriority.
	] ifFalse:[
		myList := self fetchPointer: MyListIndex ofObject: process.
		"XXXX Fixme. We should really check whether myList is a kind of LinkedList or not
		but we can't easily so just do a quick check for nil which is the most common case."
		myList == self nilObject ifTrue:[^self primitiveFail].
		self removeProcess: process fromList: myList.
		successFlag ifTrue:[
			self storePointer: MyListIndex ofObject: process withValue: self nilObject.
			self pop: 1.
			self push: myList.
		].
	].
! !
!Interpreter methodsFor: 'process primitives' stamp: 'ajh 1/28/2003 12:58'!
primitiveTerminateTo
	"Primitive. Terminate up the context stack from the receiver up to but not including the argument, if previousContext is on my Context stack. Make previousContext my sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct"
	| thisCntx currentCntx aContext nextCntx nilOop |
	aContext := self popStack.
	thisCntx := self popStack.

	"make sure that aContext is in my chain"
	(self context: thisCntx hasSender: aContext) ifTrue:[
		nilOop := nilObj.
		currentCntx := self fetchPointer: SenderIndex ofObject: thisCntx.
		[currentCntx = aContext] whileFalse: [
			nextCntx := self fetchPointer: SenderIndex ofObject: currentCntx.
			self storePointer: SenderIndex ofObject: currentCntx withValue: nilOop.
			self storePointer: InstructionPointerIndex ofObject: currentCntx withValue: nilOop.
			currentCntx := nextCntx]].

	self storePointer: SenderIndex ofObject: thisCntx withValue: aContext.
	^self push: thisCntx! !
!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 5/1/1999 09:41'!
primitiveTestDisplayDepth
	"Return true if the host OS does support the given display depth."
	| bitsPerPixel okay|
	bitsPerPixel := self stackIntegerValue: 0.
	successFlag ifTrue: [okay := self ioHasDisplayDepth: bitsPerPixel].
	successFlag ifTrue: [
		self pop: 2. "Pop arg+rcvr"
		self pushBool: okay].! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:32'!
primitiveTimesTwoPower
	| rcvr arg |
	<var: #rcvr type: 'double '>
	arg := self popInteger.
	rcvr := self popFloat.
	successFlag
		ifTrue: [ self pushFloat: (self cCode: 'ldexp(rcvr, arg)' inSmalltalk: [rcvr timesTwoPower: arg]) ]
		ifFalse: [ self unPop: 2 ].! !
!Interpreter methodsFor: 'arithmetic float primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:32'!
primitiveTruncated 
	| rcvr frac trunc |
	<var: #rcvr type: 'double '>
	<var: #frac type: 'double '>
	<var: #trunc type: 'double '>
	rcvr := self popFloat.
	successFlag ifTrue:
		[self cCode: 'frac = modf(rcvr, &trunc)'
			inSmalltalk: [trunc := rcvr truncated].
		self flag: #Dan.		"The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
		self cCode: 'success((-1073741824.0 <= trunc) && (trunc <= 1073741823.0))'
			inSmalltalk: [self success: (trunc between: SmallInteger minVal and: SmallInteger maxVal)]].
	successFlag
		ifTrue: [self cCode: 'pushInteger((sqInt) trunc)' inSmalltalk: [self pushInteger: trunc]]
		ifFalse: [self unPop: 1]! !
!Interpreter methodsFor: 'plugin primitives' stamp: 'tpr 3/23/2005 15:28'!
primitiveUnloadModule
	"Primitive. Unload the module with the given name."
	"Reloading of the module will happen *later* automatically, when a 
	function from it is called. This is ensured by invalidating current sessionID."
	| moduleName |
	self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
	moduleName := self stackTop.
	(self isIntegerObject: moduleName) ifTrue:[^self primitiveFail].
	(self isBytes: moduleName) ifFalse:[^self primitiveFail].
	(self ioUnloadModule: (self oopForPointer: (self firstIndexableField: moduleName))
		OfLength: (self byteSizeOf: moduleName)) ifFalse:[^self primitiveFail].
	self flushExternalPrimitives.
	self forceInterruptCheck.
	self pop: 1 "pop moduleName; return receiver"! !
!Interpreter methodsFor: 'system control primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 8/14/2010 14:53'!
primitiveUtcWithOffset
	"Answer an array with UTC microseconds since the Posix epoch and
	the current seconds offset from GMT in the local time zone.
	This is a named (not numbered) primitive in the null module (ie the VM)"
	| clock offset resultArray |

	<export: true>
	<var: #clock type: 'sqLong'>
	<var: #offset type: 'int'>
	(self cCode: 'ioUtcWithOffset(&clock, &offset)' inSmalltalk: [-1]) = -1
		ifTrue: [^ self primitiveFail].
	self pushRemappableOop: (self positive64BitIntegerFor: clock).
	resultArray := self instantiateClass: self classArray indexableSize: 2.
	self stObject: resultArray at: 1 put: self popRemappableOop.
	self stObject: resultArray at: 2 put: (self integerObjectOf: offset).
	self pop: 1 thenPush: resultArray
! !
!Interpreter methodsFor: 'system control primitives' stamp: 'dtl 11/2/2010 11:36'!
primitiveVMParameter
	"Behaviour depends on argument count:
		0 args:	return an Array of VM parameter values;
		1 arg:	return the indicated VM parameter;
		2 args:	set the VM indicated parameter.
	VM parameters are numbered as follows:
		1	end of old-space (0-based, read-only)
		2	end of young-space (read-only)
		3	end of memory (read-only)
		4	allocationCount (read-only)
		5	allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs since startup (read-only)
		10	total milliseconds in incremental GCs since startup (read-only)
		11	tenures of surving objects since startup (read-only)
		12-20 specific to the translating VM
		21	root table size (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc.
		24	memory threshold above which shrinking object memory (rw)
		25	memory headroom when growing object memory (rw)
		26  interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image  is not calling getNextEvent often (rw)
		27	number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking
		28	number of times sweep loop iterated  for current IGC/FGC (read-only)
		29	number of times make forward loop iterated for current IGC/FGC (read-only)
		30	number of times compact move loop iterated for current IGC/FGC (read-only)
		31	number of grow memory requests (read-only)
		32	number of shrink memory requests (read-only)
		33	number of root table entries used for current IGC/FGC (read-only)
		34	number of allocations done before current IGC/FGC (read-only)
		35	number of survivor objects after current IGC/FGC (read-only)
		36  millisecond clock when current IGC/FGC completed (read-only)
		37  number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only)
		38  milliseconds taken by current IGC  (read-only)
		39  Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only)
		40 BytesPerWord for this image
		
	Note: Thanks to Ian Piumarta for this primitive."

	| mem paramsArraySize result arg index statIGCDeltaTimeObj statGCTimeObj statIncrGCMSecsObj statFullGCMSecsObj resultLargePositiveInteger |
	<var: #resultLargePositiveInteger type: 'sqLong'>
	mem := self startOfMemory.
	paramsArraySize := 40.
	argumentCount = 0 ifTrue: [
		result := self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize.
		self pushRemappableOop:  result.
		self pushRemappableOop:  (self positive64BitIntegerFor: statFullGCMSecs).
		self pushRemappableOop:  (self positive64BitIntegerFor: statIncrGCMSecs).
		self pushRemappableOop:  (self positive64BitIntegerFor: statGCTime).
		self pushRemappableOop:  (self positive64BitIntegerFor: statIGCDeltaTime).
		statIGCDeltaTimeObj := self popRemappableOop.
		statGCTimeObj := self popRemappableOop.
		statIncrGCMSecsObj := self popRemappableOop.
		statFullGCMSecsObj := self popRemappableOop.
		result := self popRemappableOop.
		0 to: paramsArraySize - 1 do:
			[:i | self storePointer: i ofObject: result withValue: ConstZero].
	
		self storePointer: 0	ofObject: result withValue: (self positive64BitIntegerFor: youngStart - mem).
		self storePointer: 1	ofObject: result withValue: (self positive64BitIntegerFor: freeBlock - mem).
		self storePointer: 2	ofObject: result withValue: (self positive64BitIntegerFor: endOfMemory - mem).
		self storePointer: 3	ofObject: result withValue: (self integerObjectOf: allocationCount).
		self storePointer: 4	ofObject: result withValue: (self integerObjectOf: allocationsBetweenGCs).
		self storePointer: 5	ofObject: result withValue: (self integerObjectOf: tenuringThreshold).
		self storePointer: 6	ofObject: result withValue: (self integerObjectOf: statFullGCs).
		self storePointer: 7	ofObject: result withValue: statFullGCMSecsObj.
		self storePointer: 8	ofObject: result withValue: (self integerObjectOf: statIncrGCs).
		self storePointer: 9	ofObject: result withValue: statIncrGCMSecsObj.
		self storePointer: 10	ofObject: result withValue: (self integerObjectOf: statTenures).
		self storePointer: 20	ofObject: result withValue: (self integerObjectOf: rootTableCount).
		self storePointer: 21	ofObject: result withValue: (self integerObjectOf: statRootTableOverflows).
		self storePointer: 22	ofObject: result withValue: (self positive64BitIntegerFor: extraVMMemory).
		self storePointer: 23	ofObject: result withValue: (self positive64BitIntegerFor: shrinkThreshold).
		self storePointer: 24	ofObject: result withValue: (self positive64BitIntegerFor: growHeadroom).
		self storePointer: 25	ofObject: result withValue: (self integerObjectOf: interruptChecksEveryNms).
		self storePointer: 26	ofObject: result withValue: (self integerObjectOf: statMarkCount).
		self storePointer: 27	ofObject: result withValue: (self integerObjectOf: statSweepCount).
		self storePointer: 28	ofObject: result withValue: (self integerObjectOf: statMkFwdCount).
		self storePointer: 29	ofObject: result withValue: (self integerObjectOf: statCompMoveCount).
		self storePointer: 30	ofObject: result withValue: (self integerObjectOf: statGrowMemory).
		self storePointer: 31	ofObject: result withValue: (self integerObjectOf: statShrinkMemory).
		self storePointer: 32	ofObject: result withValue: (self integerObjectOf: statRootTableCount).
		self storePointer: 33	ofObject: result withValue: (self integerObjectOf: statAllocationCount).
		self storePointer: 34	ofObject: result withValue: (self integerObjectOf: statSurvivorCount).
		self storePointer: 35	ofObject: result withValue: statGCTimeObj.
		self storePointer: 36	ofObject: result withValue: (self integerObjectOf: statSpecialMarkCount).
		self storePointer: 37	ofObject: result withValue: statIGCDeltaTimeObj.
		self storePointer: 38	ofObject: result withValue: (self integerObjectOf: statpendingFinalizationSignals).
		self storePointer: 39	ofObject: result withValue: (self integerObjectOf: self bytesPerWord).
		self pop: 1 thenPush: result.
		^nil].

	arg := self stackTop.
	(self isIntegerObject: arg) ifFalse: [^self primitiveFail].
	arg := self integerValueOf: arg.
	resultLargePositiveInteger := -1.
	argumentCount = 1 ifTrue: [	 "read VM parameter"
		(arg < 1 or: [arg > paramsArraySize]) ifTrue: [^self primitiveFail].
		arg = 1		ifTrue: [resultLargePositiveInteger := youngStart - mem].
		arg = 2		ifTrue: [resultLargePositiveInteger := freeBlock - mem].
		arg = 3		ifTrue: [resultLargePositiveInteger := endOfMemory - mem].
		arg = 4		ifTrue: [result := allocationCount].
		arg = 5		ifTrue: [result := allocationsBetweenGCs].
		arg = 6		ifTrue: [result := tenuringThreshold].
		arg = 7		ifTrue: [result := statFullGCs].
		arg = 8		ifTrue: [resultLargePositiveInteger := statFullGCMSecs].
		arg = 9		ifTrue: [result := statIncrGCs].
		arg = 10		ifTrue: [resultLargePositiveInteger := statIncrGCMSecs].
		arg = 11		ifTrue: [result := statTenures].
		((arg >= 12) and: [arg <= 20]) ifTrue: [result := 0].
		arg = 21		ifTrue: [result := rootTableCount].
		arg = 22		ifTrue: [result := statRootTableOverflows].
		arg = 23		ifTrue: [resultLargePositiveInteger := extraVMMemory].
		arg = 24		ifTrue: [resultLargePositiveInteger := shrinkThreshold].
		arg = 25		ifTrue: [resultLargePositiveInteger := growHeadroom].
		arg = 26		ifTrue: [result := interruptChecksEveryNms]. 
		arg = 27		ifTrue: [result := statMarkCount]. 
		arg = 28		ifTrue: [result := statSweepCount]. 
		arg = 29		ifTrue: [result := statMkFwdCount]. 
		arg = 30		ifTrue: [result := statCompMoveCount]. 
		arg = 31		ifTrue: [result := statGrowMemory]. 
		arg = 32		ifTrue: [result := statShrinkMemory]. 
		arg = 33		ifTrue: [result := statRootTableCount]. 
		arg = 34		ifTrue: [result := statAllocationCount]. 
		arg = 35		ifTrue: [result := statSurvivorCount]. 
		arg = 36  	ifTrue: [resultLargePositiveInteger := statGCTime]. 
		arg = 37  	ifTrue: [result := statSpecialMarkCount]. 
		arg = 38  	ifTrue: [resultLargePositiveInteger := statIGCDeltaTime]. 
		arg = 39  	ifTrue: [result := statpendingFinalizationSignals]. 
		arg = 40  	ifTrue: [result := self bytesPerWord]. 
		resultLargePositiveInteger = -1 
			ifTrue: [self pop: 2 thenPush: (self integerObjectOf: result)]
			ifFalse: [self pop: 2 thenPush: (self positive64BitIntegerFor: resultLargePositiveInteger)].
		^nil].

	"write a VM parameter"
	argumentCount = 2 ifFalse: [^self primitiveFail].
	index := self stackValue: 1.
	(self isIntegerObject: index) ifFalse: [^self primitiveFail].
	index := self integerValueOf: index.
	index <= 0 ifTrue: [^self primitiveFail].
	successFlag := false.
	index = 5 ifTrue: [
		result := allocationsBetweenGCs.
		allocationsBetweenGCs := arg.
		successFlag := true].
	index = 6 ifTrue: [
		result := tenuringThreshold.
		tenuringThreshold := arg.
		successFlag := true].
	index = 23 ifTrue: [
		result := extraVMMemory.
		extraVMMemory := arg.
		successFlag := true].
	index = 24 ifTrue: [
		result := shrinkThreshold.
		arg > 0 ifTrue:[
			shrinkThreshold := arg.
			successFlag := true]].
	index = 25 ifTrue: [
		result := growHeadroom.
		arg > 0 ifTrue:[
			growHeadroom := arg.
			successFlag := true]].
	index = 26 ifTrue: [
		arg > 1 ifTrue:[
			result := interruptChecksEveryNms.
			interruptChecksEveryNms := arg.
			successFlag := true]]. 

	successFlag ifTrue: [
		self pop: 3 thenPush: (self integerObjectOf: result).  "return old value"
		^ nil].

	self primitiveFail.  "attempting to write a read-only parameter"



! !
!Interpreter methodsFor: 'system control primitives' stamp: 'dtl 5/18/2010 21:46'!
primitiveVMPath
	"Return a string containing the path name of VM's directory."

	| s sz |
	sz := self vmPathSize.
	s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
	self vmPathGet: (s + self baseHeaderSize) Length: sz.
	self pop: 1 thenPush: s.
! !
!Interpreter methodsFor: 'other primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/9/2010 00:49'!
primitiveVMVersion
	"Answer a string corresponding to the version of virtual machine. This
	represents the version level of the Smalltalk source code (interpreter and various
	plugins) that is translated to C by a CCodeGenerator,  in addition to the external
	platform source code, typically written in C and managed separately for each platform.
	By convention, this is a string composed of the interpreter source version and the
	platform source version, e.g. '4.0.2-2172'.
	
	This is a named (not numbered) primitive in the null module (ie the VM)"
	
	| len versionString p |
	<export: true>
	<var: #p type: 'char *'>
	self isDefined: 'VM_VERSION'
		inSmalltalk: [versionString := '']
		comment: 'version level of interpreter plus platform support code'
		ifTrue: [len := self cCode: 'strlen(VM_VERSION)' inSmalltalk: [0].
			versionString := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: len.
			p := interpreterProxy arrayValueOf: versionString.
			self cCode: 'strncpy(p, VM_VERSION, len)']
		ifFalse: [^interpreterProxy primitiveFail].
	self pop: 1 thenPush: versionString
! !
!Interpreter methodsFor: 'control primitives' stamp: 'tpr 3/23/2004 18:08'!
primitiveValue
	| blockContext blockArgumentCount initialIP |
	blockContext := self stackValue: argumentCount.
	blockArgumentCount := self argumentCountOfBlock: blockContext.
	self success: (argumentCount = blockArgumentCount
			and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj]).
	successFlag
		ifTrue: [self transfer: argumentCount
				fromIndex: self stackPointerIndex - argumentCount + 1
				ofObject: activeContext
				toIndex: TempFrameStart
				ofObject: blockContext.

			"Assume: The call to transfer:... makes blockContext a root if necessary,
			 allowing use to use unchecked stored in the following code."
			self pop: argumentCount + 1.
			initialIP := self fetchPointer: InitialIPIndex	ofObject: blockContext.
			self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP.
			self storeStackPointerValue: argumentCount inContext: blockContext.
			self storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext.
			self newActiveContext: blockContext]! !
!Interpreter methodsFor: 'control primitives' stamp: 'tpr (auto pragmas 12/08) 2/20/2004 19:46'!
primitiveValueUninterruptably
	"The only purpose of this primitive is to indicate that the new EH mechanisms are supported."
	<inline: false>
	^self primitiveValue! !
!Interpreter methodsFor: 'control primitives' stamp: 'tpr 10/29/2004 19:11'!
primitiveValueWithArgs
	| argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
	argumentArray := self popStack.
	blockContext := self popStack.
	blockArgumentCount := self argumentCountOfBlock: blockContext.
	"If the argArray isnt actually an Array we ahve to unpop the above two"
	(self isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].

	successFlag ifTrue: [arrayArgumentCount := self fetchWordLengthOf: argumentArray.
			self success: (arrayArgumentCount = blockArgumentCount
						and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])].
	successFlag
		ifTrue: [self
				transfer: arrayArgumentCount
				fromIndex: 0
				ofObject: argumentArray
				toIndex: TempFrameStart
				ofObject: blockContext.
			"Assume: The call to transfer:... makes blockContext a root if necessary, 
			allowing use to use unchecked stored in the following code. "
			initialIP := self fetchPointer: InitialIPIndex ofObject: blockContext.
			self
				storePointerUnchecked: InstructionPointerIndex
				ofObject: blockContext
				withValue: initialIP.
			self storeStackPointerValue: arrayArgumentCount inContext: blockContext.
			self
				storePointerUnchecked: CallerIndex
				ofObject: blockContext
				withValue: activeContext.
			self newActiveContext: blockContext]
		ifFalse: [self unPop: 2]! !
!Interpreter methodsFor: 'process primitives'!
primitiveWait

	| sema excessSignals activeProc |
	sema := self stackTop.  "rcvr"
	self assertClassOf: sema is: (self splObj: ClassSemaphore).
	successFlag ifTrue: [
		excessSignals :=
			self fetchInteger: ExcessSignalsIndex ofObject: sema.
		excessSignals > 0 ifTrue: [
			self storeInteger: ExcessSignalsIndex
				ofObject: sema withValue: excessSignals - 1.
		] ifFalse: [
			activeProc := self fetchPointer: ActiveProcessIndex
								 ofObject: self schedulerPointer.
			self addLastLink: activeProc toList: sema.
			self transferTo: self wakeHighestPriority.
		].
	].! !
!Interpreter methodsFor: 'process primitives' stamp: 'tpr 6/1/2004 13:37'!
primitiveYield
"primitively do the equivalent of Process>yield"
	| activeProc priority processLists processList |
	activeProc := self fetchPointer: ActiveProcessIndex
						 ofObject: self schedulerPointer.
	priority := self quickFetchInteger: PriorityIndex ofObject: activeProc.
	processLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
	processList := self fetchPointer: priority - 1 ofObject: processLists.

	(self isEmptyList: processList) ifFalse:[
		self addLastLink: activeProc toList: processList.
		self transferTo: self wakeHighestPriority]! !
!Interpreter methodsFor: 'debug printing' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:32'!
print: s
	"For testing in Smalltalk, this method should be overridden in a subclass."

	<var: #s type: 'char *'>
	self cCode: 'printf("%s", s)'.! !
!Interpreter methodsFor: 'debug printing' stamp: 'dtl 1/5/2011 21:47'!
printAllStacks
	"Print all the stacks of all running processes, including those that are currently suspended."
	| oop proc ctx |
	<export: true> "exported to permit access from plugins"
	proc := self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
	self printNameOfClass: (self fetchClassOf: proc) count: 5.
	self cr.
	self printCallStackOf: activeContext. "first the active context"
	oop := self firstObject.
	[self oop: oop isLessThan: endOfMemory] whileTrue:[
		(self fetchClassOf: oop) == self classSemaphore ifTrue:[
			self cr.
			proc := self fetchPointer: FirstLinkIndex ofObject: oop.
			[proc == self nilObject] whileFalse:[
				self printNameOfClass: (self fetchClassOf: proc) count: 5.
				self cr.
				ctx := self fetchPointer: SuspendedContextIndex ofObject: proc.
				ctx == self nilObject ifFalse:[self printCallStackOf: ctx].
				proc := self fetchPointer: NextLinkIndex ofObject: proc].
		].
		oop := self objectAfter: oop.
	].! !
!Interpreter methodsFor: 'debug printing' stamp: 'ar 7/18/2001 16:23'!
printCallStack
	^self printCallStackOf: activeContext! !
!Interpreter methodsFor: 'debug printing' stamp: 'ajh (auto pragmas 12/08) 3/16/2003 13:13'!
printCallStackOf: aContext

	| ctxt home methClass methodSel message |
	<inline: false>
	ctxt := aContext.
	[ctxt = nilObj] whileFalse: [
		(self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
			ifTrue: [ home := self fetchPointer: HomeIndex ofObject: ctxt ]
			ifFalse: [ home := ctxt ].
		methClass :=
			self findClassOfMethod: (self fetchPointer: MethodIndex ofObject: home)
					   forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
		methodSel :=
			self findSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
						 forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
		self printNum: ctxt.
		self print: ' '.
		ctxt = home ifFalse: [ self print: '[] in ' ].
		self printNameOfClass: methClass count: 5.
		self print: '>'.
		methodSel = nilObj
			ifTrue: [self print: '?']
			ifFalse: [self printStringOf: methodSel].
		methodSel = (self splObj: SelectorDoesNotUnderstand) ifTrue: [
			"print arg message selector"
			message := self fetchPointer: 0 + TempFrameStart ofObject: home.
			methodSel := self fetchPointer: MessageSelectorIndex ofObject: message.
			self print: ' '.
			self printStringOf: methodSel.
		].
		self cr.

		ctxt := (self fetchPointer: SenderIndex ofObject: ctxt).
	].! !
!Interpreter methodsFor: 'debug printing'!
printChar: aByte
	"For testing in Smalltalk, this method should be overridden in a subclass."

	self putchar: aByte.! !
!Interpreter methodsFor: 'debug printing' stamp: 'dtl 5/18/2010 21:04'!
printNameOfClass: classOop count: cnt
	"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."

	cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].
	(self sizeBitsOf: classOop) = (7 * self bytesPerWord)	"(Metaclass instSize+1 * 4)"
		ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) 
					count: cnt - 1.
				self print: ' class']
	ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]! !
!Interpreter methodsFor: 'debug printing'!
printNum: n
	"For testing in Smalltalk, this method should be overridden in a subclass."

	self cCode: 'printf("%ld", (long) n)'.! !
!Interpreter methodsFor: 'debug printing' stamp: 'ar 2/20/2001 21:39'!
printStringOf: oop

	| fmt cnt i |
	(self isIntegerObject: oop) ifTrue:[^nil].
	fmt := self formatOf: oop.
	fmt < 8 ifTrue: [ ^nil ].

	cnt := 100 min: (self lengthOf: oop).
	i := 0.
	[i < cnt] whileTrue: [
		self printChar: (self fetchByte: i ofObject: oop).
		i := i + 1.
	].! !
!Interpreter methodsFor: 'debug printing' stamp: 'ar (auto pragmas 12/08) 2/20/2001 01:00'!
printUnbalancedStack: primIdx
	<inline: false>
	self print: 'Stack unbalanced after '.
	successFlag 
		ifTrue:[self print:'successful primitive '] 
		ifFalse:[self print: 'failed primitive '].
	self printNum: primIdx.
	self cr.
		! !
!Interpreter methodsFor: 'debug printing' stamp: 'ar (auto pragmas dtl 2010-09-26) 2/20/2001 21:39'!
printUnbalancedStackFromNamedPrimitive
	| lit |
	<inline: false>
	self print: 'Stack unbalanced after '.
	successFlag 
		ifTrue:[self print:'successful '] 
		ifFalse:[self print: 'failed '].
	lit := self literal: 0 ofMethod: newMethod.
	self printStringOf: (self fetchPointer: 1 ofObject: lit).
	self print:' in '.
	self printStringOf: (self fetchPointer: 0 ofObject: lit).
	self cr.
		! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 21:04'!
push: object

	| sp |
	self longAt: (sp := stackPointer + self bytesPerWord) put: object.
	stackPointer := sp.! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushActiveContextBytecode
	"Puts reclaimability of this context in question."

	self fetchNextBytecode.
	reclaimableContextCount := 0.
	self internalPush: activeContext.
! !
!Interpreter methodsFor: 'contexts'!
pushBool: trueOrFalse

	trueOrFalse
		ifTrue: [ self push: trueObj ]
		ifFalse: [ self push: falseObj ].! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl 5/18/2010 21:47'!
pushClosureCopyCopiedValuesBytecode
	"The compiler has pushed the values to be copied, if any.  Find numArgs and numCopied in the byte following.
	 Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
	 Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
	| newClosure numArgsNumCopied numArgs numCopied blockSize |
	self bytesPerWord == 4
		ifTrue: [imageFormatVersionNumber := 6504]
		ifFalse: [imageFormatVersionNumber := 68002].
	numArgsNumCopied := self fetchByte.
	numArgs := numArgsNumCopied bitAnd: 16rF.
	numCopied := numArgsNumCopied bitShift: -4.
	"Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
	blockSize := self fetchByte << 8.
	blockSize := blockSize + self fetchByte.
	self externalizeIPandSP. "This is a pain."
	newClosure := self
					closureNumArgs: numArgs
					instructionPointer: ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))
					numCopiedValues: numCopied.
	self internalizeIPandSP.
	"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
	self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
	reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed."
	numCopied > 0 ifTrue:
		[0 to: numCopied - 1 do:
			[:i|
			"Assume: have just allocated a new BlockClosure; it must be young.
			 Thus, can use unchecked stores."
			 self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
				ofObject: newClosure
				withValue: (self internalStackValue: numCopied - i - 1)].
		 self internalPop: numCopied].
	localIP := localIP + blockSize.
	self fetchNextBytecode.
	self internalPush: newClosure! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantFalseBytecode

	self fetchNextBytecode.
	self internalPush: falseObj.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantMinusOneBytecode

	self fetchNextBytecode.
	self internalPush: ConstMinusOne.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantNilBytecode

	self fetchNextBytecode.
	self internalPush: nilObj.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantOneBytecode

	self fetchNextBytecode.
	self internalPush: ConstOne.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantTrueBytecode

	self fetchNextBytecode.
	self internalPush: trueObj.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantTwoBytecode

	self fetchNextBytecode.
	self internalPush: ConstTwo.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantZeroBytecode

	self fetchNextBytecode.
	self internalPush: ConstZero.
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:32'!
pushFloat: f

	<var: #f type: 'double '>
	self push: (self floatObjectOf: f).! !
!Interpreter methodsFor: 'contexts'!
pushInteger: integerValue
	self push: (self integerObjectOf: integerValue).! !
!Interpreter methodsFor: 'stack bytecodes'!
pushLiteralConstant: literalIndex

	self internalPush: (self literal: literalIndex).! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl 7/2/2008 12:22'!
pushLiteralConstantBytecode

	self flag: #'requires currentBytecode to be expanded to a constant'.
	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushLiteralConstant: (currentBytecode bitAnd: 16r1F).
! !
!Interpreter methodsFor: 'stack bytecodes'!
pushLiteralVariable: literalIndex

	self internalPush:
		(self fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl 7/2/2008 12:23'!
pushLiteralVariableBytecode

	self flag: #'requires currentBytecode to be expanded to a constant'.
	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushLiteralVariable: (currentBytecode bitAnd: 16r1F).
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'eem 7/22/2008 16:46'!
pushNewArrayBytecode
	| size popValues array |
	size := self fetchByte.
	popValues := size > 127.
	size := size bitAnd: 127.
	self fetchNextBytecode.
	self externalizeIPandSP.
	array := self instantiateClass: (self splObj: ClassArray) indexableSize: size.
	self internalizeIPandSP.
	popValues ifTrue:
		[0 to: size - 1 do:
			[:i|
			"Assume: have just allocated a new Array; it must be young. Thus, can use unchecked stores."
			self storePointerUnchecked: i ofObject: array withValue: (self internalStackValue: size - i - 1)].
		 self internalPop: size].
	self internalPush: array! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushReceiverBytecode

	self fetchNextBytecode.
	self internalPush: receiver.
! !
!Interpreter methodsFor: 'stack bytecodes'!
pushReceiverVariable: fieldIndex

	self internalPush:
		(self fetchPointer: fieldIndex ofObject: receiver).! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl 7/2/2008 12:23'!
pushReceiverVariableBytecode

	self flag: #'requires currentBytecode to be expanded to a constant'.
	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushReceiverVariable: (currentBytecode bitAnd: 16rF).
! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'eem 5/27/2008 15:12'!
pushRemoteTemp: index inVectorAt: tempVectorIndex
	| tempVector |
	tempVector := self temporary: tempVectorIndex.
	self internalPush: (self fetchPointer: index ofObject: tempVector)! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'eem 5/27/2008 13:28'!
pushRemoteTempLongBytecode
	| remoteTempIndex tempVectorIndex |
	remoteTempIndex := self fetchByte.
	tempVectorIndex := self fetchByte.
	self fetchNextBytecode.
	self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! !
!Interpreter methodsFor: 'stack bytecodes'!
pushTemporaryVariable: temporaryIndex

	self internalPush: (self temporary: temporaryIndex).! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl 7/2/2008 12:23'!
pushTemporaryVariableBytecode

	self flag: #'requires currentBytecode to be expanded to a constant'.
	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
! !
!Interpreter methodsFor: 'image save/restore' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:32'!
putLong: aWord toFile: aFile
	"Append aWord to aFile in this platforms 'natural' byte order.  (Bytes will be swapped, if
	necessary, when the image is read on a different platform.) Set successFlag to false if
	the write fails."

	| objectsWritten |
	<var: #aFile type: 'sqImageFile '>

	objectsWritten := self cCode: 'sqImageFileWrite(&aWord, sizeof(aWord), 1, aFile)'.
	self success: objectsWritten = 1.
! !
!Interpreter methodsFor: 'process primitive support'!
putToSleep: aProcess
	"Save the given process on the scheduler process list for its priority."

	| priority processLists processList |
	priority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
	processLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
	processList := self fetchPointer: priority - 1 ofObject: processLists.
	self addLastLink: aProcess toList: processList.! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/22/2004 14:27'!
quickCheckForInterrupts
	"Quick check for possible user or timer interrupts. Decrement a counter and only do a real check when counter reaches zero or when a low space or user interrupt is pending."
	"Note: Clients that trigger interrupts should set use forceInterruptCheck to set interruptCheckCounter to zero and get immediate results."
	"Note: Requires that instructionPointer and stackPointer be external."

	((interruptCheckCounter := interruptCheckCounter - 1) <= 0)
		ifTrue: [self checkForInterrupts].
! !
!Interpreter methodsFor: 'utilities' stamp: 'tpr 3/15/2004 20:35'!
quickFetchInteger: fieldIndex ofObject: objectPointer
	"Return the integer value of the field without verifying that it is an integer value!! For use in time-critical places where the integer-ness of the field can be guaranteed."

	^ self integerValueOf: (self fetchPointer: fieldIndex ofObject: objectPointer).! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 12/30/2010 17:29'!
readImageFormatFromFile: f StartingAt: imageOffset
	"Read an image header from the given file stream, and answer the image format
	version number for the saved image. Exported to allow platform support code to
	query image files for image format number."

	<export: true>
	<var: #f type: 'sqImageFile '>
	<var: #imageOffset type: 'squeakFileOffsetType '>

	self checkImageVersionFrom: f startingAt: imageOffset.
	^ imageFormatInitialVersion
! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 10/5/2010 22:50'!
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
	"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
	"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
	"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"

	| swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
	<var: #f type: 'sqImageFile '>
	<var: #desiredHeapSize type: 'usqInt'>
	<var: #headerStart type: 'squeakFileOffsetType '>
	<var: #dataSize type: 'size_t '>
	<var: #imageOffset type: 'squeakFileOffsetType '>

	swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
	headerStart := (self sqImageFilePosition: f) - self bytesPerWord.  "record header start position"

	headerSize			:= self getLongFromFile: f swap: swapBytes.
	dataSize				:= self getLongFromFile: f swap: swapBytes.
	oldBaseAddr			:= self getLongFromFile: f swap: swapBytes.
	specialObjectsOop	:= self getLongFromFile: f swap: swapBytes.
	lastHash			:= self getLongFromFile: f swap: swapBytes.
	savedWindowSize	:= self getLongFromFile: f swap: swapBytes.
	fullScreenFlag		:= self oldFormatFullScreenFlag: (self getLongFromFile: f swap: swapBytes).
	extraVMMemory		:= self getLongFromFile: f swap: swapBytes.

	lastHash = 0 ifTrue: [
		"lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
		lastHash := 999].

	"decrease Squeak object heap to leave extra memory for the VM"
	heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.

	"compare memory requirements with availability".
	minimumMemory := dataSize + 100000.  "need at least 100K of breathing room"
	heapSize < minimumMemory ifTrue: [
		self insufficientMemorySpecifiedError].

	"allocate a contiguous block of memory for the Squeak heap"
	memory := self
		allocateMemory: heapSize
		minimum: minimumMemory
		imageFile: f
		headerSize: headerSize.
	memory = nil ifTrue: [self insufficientMemoryAvailableError].

	memStart := self startOfMemory.
	memoryLimit := (memStart + heapSize) - 24.  "decrease memoryLimit a tad for safety"
	endOfMemory := memStart + dataSize.

	"position file after the header"
	self sqImageFile: f Seek: headerStart + headerSize.

	"read in the image in bulk, then swap the bytes if necessary"
	bytesRead := self
		sqImage: (self pointerForOop: memory)
		read: f
		size: (self cCode: 'sizeof(unsigned char)')
		length: dataSize.
	bytesRead ~= dataSize ifTrue: [self unableToReadImageError].

	headerTypeBytes at: 0 put: self bytesPerWord * 2.		"3-word header (type 0)"	
	headerTypeBytes at: 1 put: self bytesPerWord.		"2-word header (type 1)"
	headerTypeBytes at: 2 put: 0.					"free chunk (type 2)"	
	headerTypeBytes at: 3 put: 0.					"1-word header (type 3)"

	swapBytes ifTrue: [self reverseBytesInImage].

	"compute difference between old and new memory base addresses"
	bytesToShift := memStart - oldBaseAddr.
	self initializeInterpreter: bytesToShift.  "adjusts all oops to new location"
	self isBigEnder. "work out the machine endianness and cache the answer"
	
	(self imageFormatInitialVersion bitAnd: 1) = 1
		ifTrue: ["Low order bit set, indicating that the image was saved from
			a StackInterpreter (Cog) VM. Storage of all Float objects must be
			returned to older object memory format."
			self normalizeFloatOrderingInImage].
 
	^ dataSize
! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 10/3/2010 15:45'!
readableFormat: imageVersion
	"Anwer true if images of the given format are readable by this interpreter. Allows
	a virtual machine to accept selected older image formats.  In our case we can
	select a newer (closure) image format as well as the existing format. Images with
	platform-ordered floats (StackInterpreter and Cog format) are readable but will be
	converted to traditional word ordering."

	self bytesPerWord = 4
		ifTrue: [^ (imageVersion = 6502	"Original 32-bit Squeak image format"
			or: [imageVersion = 6504])		"32-bit with closures"
			or: [imageVersion = 6505]]		"32-bit with closures and platform-ordered floats"
		ifFalse: [^ (imageVersion = 68000	"Original 64-bit Squeak image format"
			or: [imageVersion = 68002])	"64-bit with closures"
			or: [imageVersion = 68003]]	"64-bit with closures and platform-ordered floats"
! !
!Interpreter methodsFor: 'contexts' stamp: 'eem (auto pragmas dtl 2010-09-26) 11/30/2007 09:27'!
reestablishContextPriorToCallback: callbackContext
	"callbackContext is an activation of invokeCallback:stack:registers:jmpbuf:.  Its sender
	 is the interpreter's state prior to the callback.  Reestablish that state."
	| calloutContext |
	<export: true>
	(self fetchClassOf: callbackContext) ~~ (self splObj: ClassMethodContext) ifTrue:
		[^false].
	calloutContext := self fetchPointer: SenderIndex ofObject: callbackContext.
	self newActiveContext: calloutContext.
	^true! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/24/2004 20:54'!
removeFirstLinkOfList: aList 
	"Remove the first process from the given linked list."
	| first last next |
	first := self fetchPointer: FirstLinkIndex ofObject: aList.
	last := self fetchPointer: LastLinkIndex ofObject: aList.
	first = last
		ifTrue: [self storePointer: FirstLinkIndex ofObject: aList withValue: nilObj.
			self storePointer: LastLinkIndex ofObject: aList withValue: nilObj]
		ifFalse: [next := self fetchPointer: NextLinkIndex ofObject: first.
			self storePointer: FirstLinkIndex ofObject: aList withValue: next].
	self storePointer: NextLinkIndex ofObject: first withValue: nilObj.
	^ first! !
!Interpreter methodsFor: 'process primitive support' stamp: 'ar 12/31/2010 10:27'!
removeProcess: aProcess fromList: aList 
	"Remove a given process from a linked list. May fail if aProcess is not on the list."
	| firstLink lastLink nextLink tempLink |
	firstLink := self fetchPointer: FirstLinkIndex ofObject: aList.
	lastLink := self fetchPointer: LastLinkIndex ofObject: aList.
	aProcess  == firstLink ifTrue:[
		nextLink := self fetchPointer: NextLinkIndex ofObject: aProcess .
		self storePointer: FirstLinkIndex ofObject: aList withValue: nextLink.
		aProcess  == lastLink ifTrue:[
			self storePointer: LastLinkIndex ofObject: aList withValue: self nilObject.
		].
	] ifFalse:[
		tempLink := firstLink.
		[tempLink == self nilObject ifTrue:[^self success: false]. "fail"
		nextLink := self fetchPointer: NextLinkIndex ofObject: tempLink.
		nextLink == aProcess] whileFalse:[
			tempLink := self fetchPointer: NextLinkIndex ofObject: tempLink.
		].
		nextLink := self fetchPointer: NextLinkIndex ofObject: aProcess.
		self storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink.
		aProcess  == lastLink ifTrue:[
			self storePointer: LastLinkIndex ofObject: aList withValue: tempLink.
		].
	].
	self storePointer: NextLinkIndex ofObject: aProcess withValue: self nilObject.
! !
!Interpreter methodsFor: 'image segment in/out' stamp: 'dtl 5/19/2010 12:47'!
restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut

	"Restore headers smashed by forwarding links"
	| tablePtr oop header |
	tablePtr := firstIn.
	[self oop: tablePtr isLessThanOrEqualTo: lastIn] whileTrue:
		[oop := self longAt: tablePtr.
		header := self longAt: hdrBaseIn + (tablePtr-firstIn).
		self longAt: oop put: header.
		tablePtr := tablePtr + self bytesPerWord].
	tablePtr := firstOut.
	[self oop: tablePtr isLessThanOrEqualTo: lastOut] whileTrue:
		[oop := self longAt: tablePtr.
		header := self longAt: hdrBaseOut + (tablePtr-firstOut).
		self longAt: oop put: header.
		tablePtr := tablePtr + self bytesPerWord].
	
	"Clear all mark bits"
	oop := self firstObject.
	[self oop: oop isLessThan: endOfMemory] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[self longAt: oop put: ((self longAt: oop) bitAnd: self allButMarkBit)].
		oop := self objectAfter: oop].
! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 20:55'!
resume: aProcess 
	| activeProc activePriority newPriority |
	<inline: false>
	activeProc := self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
	activePriority := self quickFetchInteger: PriorityIndex ofObject: activeProc.
	newPriority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
	newPriority > activePriority
		ifTrue: [self putToSleep: activeProc.
			self transferTo: aProcess]
		ifFalse: [self putToSleep: aProcess]! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar 7/6/2003 21:55'!
returnFalse
	localReturnContext := self sender.
	localReturnValue := falseObj.
	self commonReturn.
! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar 7/6/2003 21:55'!
returnNil
	localReturnContext := self sender.
	localReturnValue := nilObj.
	self commonReturn.! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar 7/6/2003 21:55'!
returnReceiver
	localReturnContext := self sender.
	localReturnValue := receiver.
	self commonReturn.! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar 7/6/2003 21:55'!
returnTopFromBlock
	"Return to the caller of the method containing the block."
	localReturnContext := self caller.  "Note: caller, not sender!!"
	localReturnValue := self internalStackTop.
	self commonReturn.! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar 7/6/2003 21:55'!
returnTopFromMethod
	localReturnContext := self sender.
	localReturnValue := self internalStackTop.
	self commonReturn.! !
!Interpreter methodsFor: 'return bytecodes' stamp: 'ar 7/6/2003 21:55'!
returnTrue
	localReturnContext := self sender.
	localReturnValue := trueObj.
	self commonReturn.! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 5/18/2010 21:05'!
reverseBytesFrom: startAddr to: stopAddr
	"Byte-swap the given range of memory (not inclusive of stopAddr!!)."
	| addr |
	self flag: #Dan.
	addr := startAddr.
	[self oop: addr isLessThan: stopAddr] whileTrue:
		[self longAt: addr put: (self byteSwapped: (self longAt: addr)).
		addr := addr + self bytesPerWord].! !
!Interpreter methodsFor: 'image save/restore' stamp: 'di 10/2/97 00:31'!
reverseBytesInImage
	"Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."

	"First, byte-swap every word in the image. This fixes objects headers."
	self reverseBytesFrom: self startOfMemory to: endOfMemory.

	"Second, return the bytes of bytes-type objects to their orginal order."
	self byteSwapByteObjects.! !
!Interpreter methodsFor: 'I/O primitive support' stamp: 'dtl 5/18/2010 21:47'!
reverseDisplayFrom: startIndex to: endIndex 
	"Reverse the given range of Display words (at different bit 
	depths, this will reverse different numbers of pixels). Used to 
	give feedback during VM activities such as garbage 
	collection when debugging. It is assumed that the given 
	word range falls entirely within the first line of the Display."
	| displayObj dispBitsPtr w reversed |
	displayObj := self splObj: TheDisplay.
	((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
	w := self fetchInteger: 1 ofObject: displayObj.
	dispBitsPtr := self fetchPointer: 0 ofObject: displayObj.
	(self isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
	dispBitsPtr := dispBitsPtr + self baseHeaderSize.
	dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
		do: [:ptr | 
			reversed := (self long32At: ptr) bitXor: 4294967295.
			self longAt: ptr put: reversed].
	successFlag := true.
	self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
	self ioForceDisplayUpdate! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 5/18/2010 21:05'!
reverseWordsFrom: startAddr to: stopAddr
	"Word-swap the given range of memory, excluding stopAddr."

	| addr |
	addr := startAddr.
	[self oop: addr isLessThan: stopAddr] whileTrue:
		[self longAt: addr put: (self wordSwapped: (self longAt: addr)).
		addr := addr + self bytesPerWord].! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp (auto pragmas 12/08) 3/26/2005 14:24'!
rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex

	"Rewrite the cache entry with the given primitive index and matching function pointer"
	| primPtr |
	<var: #primPtr type: 'void *'>
	<inline: false>
	localPrimIndex = 0
		ifTrue: [primPtr := 0]
		ifFalse: [primPtr := primitiveTable at: localPrimIndex].
	self
		rewriteMethodCacheSel: selector class: class
		primIndex: localPrimIndex primFunction: primPtr! !
!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp (auto pragmas 12/08) 3/26/2005 14:24'!
rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex primFunction: localPrimAddress
	"Rewrite an existing entry in the method cache with a new primitive 
	index & function address. Used by primExternalCall to make direct jumps to found external prims"
	| probe hash |
	<inline: false>
	<var: #localPrimAddress type: 'void *'>
	hash := selector bitXor: class.
	0 to: CacheProbeMax - 1 do: [:p | 
			probe := hash >> p bitAnd: MethodCacheMask.
			((methodCache at: probe + MethodCacheSelector) = selector
					and: [(methodCache at: probe + MethodCacheClass) = class])
				ifTrue: [methodCache at: probe + MethodCachePrim put: localPrimIndex.
					methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: localPrimAddress to: 'long').
					^ nil]]! !
!Interpreter methodsFor: 'primitive support' stamp: 'dtl 5/19/2010 11:28'!
roomToPushNArgs: n
	"Answer if there is room to push n arguments onto the current stack.
	 There may be room in this stackPage but there may not be room if
	 the frame were converted into a context."
	| cntxSize |
	((self headerOf: method) bitAnd: LargeContextBit) ~= 0
		ifTrue: [cntxSize := self largeContextSize / self bytesPerWord - ReceiverIndex]
		ifFalse: [cntxSize := self smallContextSize / self bytesPerWord - ReceiverIndex].
	^self stackPointerIndex + n <= cntxSize! !
!Interpreter methodsFor: 'process primitive support' stamp: 'dtl 4/16/2005 01:36'!
saveProcessSignalingLowSpace
	"The low space semaphore is about to be signaled. Save the currently active
	process in the special objects array so that the low space handler will be able
	to determine the process that first triggered a low space condition. The low
	space handler (in the image) is expected to nil out the special objects array
	slot when it handles the low space condition."

	| lastSavedProcess sched currentProc |
	lastSavedProcess := self splObj: ProcessSignalingLowSpace.
	(lastSavedProcess == self nilObject) ifTrue:
		[sched := self schedulerPointer.
		currentProc := self fetchPointer: ActiveProcessIndex ofObject: sched.
		self storePointer: ProcessSignalingLowSpace ofObject: specialObjectsOop withValue: currentProc]! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/24/2004 20:55'!
schedulerPointer

	^ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation)! !
!Interpreter methodsFor: 'send bytecodes'!
secondExtendedSendBytecode
	"This replaces the Blue Book double-extended super-send [134],
	which is subsumed by the new double-extended do-anything [132].
	It offers a 2-byte send of 0-3 args for up to 63 literals, for which 
	the Blue Book opcode set requires a 3-byte instruction."

	| descriptor |
	descriptor := self fetchByte.
	messageSelector := self literal: (descriptor bitAnd: 16r3F).
	argumentCount := descriptor >> 6.
	self normalSend.
! !
!Interpreter methodsFor: 'alien support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:05'!
sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
	"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
	 to Alien class with the supplied args.  The arguments are raw C addresses
	 and are converted to integer objects on the way."
	| where |
	<export: true>
	self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
	self pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
	self pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
	self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
	receiver := self splObj: ClassAlien.
	lkupClass := self fetchClassOfNonInt: receiver.
	messageSelector := self splObj: InvokeCallbackSelector.
	(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
	 	[(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
			[^false]].
	primitiveIndex ~= 0 ifTrue:
		[^false].
	self storeContextRegisters: activeContext.
	self internalJustActivateNewMethod.
	where := activeContext + self baseHeaderSize + (ReceiverIndex << self shiftForWord).
	self longAt: where + (1 << self shiftForWord) put: self popRemappableOop.
	self longAt: where + (2 << self shiftForWord) put: self popRemappableOop.
	self longAt: where + (3 << self shiftForWord) put: self popRemappableOop.
	self longAt: where + (4 << self shiftForWord) put: self popRemappableOop.
	self fetchContextRegisters: activeContext.
	self callInterpreter.
	"not reached"
	^true! !
!Interpreter methodsFor: 'send bytecodes' stamp: 'tpr 3/24/2004 18:36'!
sendLiteralSelectorBytecode
	"Can use any of the first 16 literals for the selector and pass up to 2 arguments."

	messageSelector := self literal: (currentBytecode bitAnd: 16rF).
	argumentCount := ((currentBytecode >> 4) bitAnd: 3) - 1.
	self normalSend! !
!Interpreter methodsFor: 'contexts' stamp: 'eem 5/23/2008 14:53'!
sender

	| context closureOrNil |
	context := localHomeContext.
	[(closureOrNil := self fetchPointer: ClosureIndex ofObject: context) ~~ nilObj] whileTrue:
		[context := self fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil].
	^self fetchPointer: SenderIndex ofObject: context! !
!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/16/1998 01:35'!
setCompilerInitialized: newFlag
	| oldFlag |
	oldFlag := compilerInitialized.
	compilerInitialized := newFlag.
	^oldFlag! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/16/2002 13:44'!
setFullScreenFlag: value
	fullScreenFlag := value! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/16/2002 13:45'!
setInterruptCheckCounter: value
	interruptCheckCounter := value! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/16/2002 13:46'!
setInterruptKeycode: value
	interruptKeycode := value! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/16/2002 13:46'!
setInterruptPending: value
	interruptPending := value! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl 9/26/2010 11:31'!
setMicroSeconds: microSeconds andOffset: utcOffset
	"A default substitute for unimplemented ioUtcWithOffset external function."
	<var: #microSeconds type: 'sqLong *'>
	<var: #utcOffset type: 'int *'>

	self flag: #toRemove. "after implementing ioUtcWithOffset in support code for all platforms"

	^ -1

	"The corresponding platform support function for a GNU unix system is:
	sqInt ioUtcWithOffset(sqLong *microSeconds, int *offset)
	{
		struct timeval timeval;
		if (gettimeofday(&timeval, NULL) == -1) return -1;
	 	long long seconds = timeval.tv_sec;
		suseconds_t usec = timeval.tv_usec;
		*microSeconds = seconds * 1000000 + usec;
		*offset = localtime(&seconds)->tm_gmtoff;
		return 0;
	}"
! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/16/2002 13:48'!
setNextWakeupTick: value
	nextWakeupTick := value! !
!Interpreter methodsFor: 'plugin primitive support' stamp: 'JMM 4/16/2002 13:47'!
setSavedWindowSize: value
	savedWindowSize := value! !
!Interpreter methodsFor: 'jump bytecodes'!
shortConditionalJump

	self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.! !
!Interpreter methodsFor: 'jump bytecodes'!
shortUnconditionalJump

	self jump: (currentBytecode bitAnd: 7) + 1.! !
!Interpreter methodsFor: 'I/O primitive support' stamp: 'ar 2/20/2000 22:06'!
showDisplayBits: aForm Left: l Top: t Right: r Bottom: b
	"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
	deferDisplayUpdates ifTrue: [^ nil].
	self displayBitsOf: aForm Left: l Top: t Right: r Bottom: b! !
!Interpreter methodsFor: 'utilities'!
signExtend16: int16
	"Convert a signed 16-bit integer into a signed 32-bit integer value. The integer bit is not added here."

	(int16 bitAnd: 16r8000) = 0
		ifTrue: [ ^ int16 ]
		ifFalse: [ ^ int16 - 16r10000 ].! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/24/2004 20:57'!
signalExternalSemaphores
	"Signal all requested semaphores"
	| xArray xSize index sema |
	semaphoresUseBufferA := semaphoresUseBufferA not.
	xArray := self splObj: ExternalObjectsArray.
	xSize := self stSizeOf: xArray.
	semaphoresUseBufferA
		ifTrue: ["use opposite buffer during read"
			1 to: semaphoresToSignalCountB do: [:i | 
					index := semaphoresToSignalB at: i.
					index <= xSize
						ifTrue: [sema := self fetchPointer: index - 1 ofObject: xArray.
							"Note: semaphore indices are 1-based"
							(self fetchClassOf: sema) = (self splObj: ClassSemaphore)
								ifTrue: [self synchronousSignal: sema]]].
			semaphoresToSignalCountB := 0]
		ifFalse: [1 to: semaphoresToSignalCountA do: [:i | 
					index := semaphoresToSignalA at: i.
					index <= xSize
						ifTrue: [sema := self fetchPointer: index - 1 ofObject: xArray.
							"Note: semaphore indices are 1-based"
							(self fetchClassOf: sema) = (self splObj: ClassSemaphore)
								ifTrue: [self synchronousSignal: sema]]].
			semaphoresToSignalCountA := 0]! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/22/2004 14:23'!
signalFinalization: weakReferenceOop
	"If it is not there already, record the given semaphore index in the list of semaphores to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."

	self forceInterruptCheck.
	pendingFinalizationSignals := pendingFinalizationSignals + 1.! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/22/2004 14:25'!
signalSemaphoreWithIndex: index
	"Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."

	index <= 0 ifTrue: [^ nil].  "bad index; ignore it"

	semaphoresUseBufferA
		ifTrue: [semaphoresToSignalCountA < SemaphoresToSignalSize
			ifTrue: [ semaphoresToSignalCountA := semaphoresToSignalCountA + 1.
				semaphoresToSignalA at: semaphoresToSignalCountA put: index]]
		ifFalse: [semaphoresToSignalCountB < SemaphoresToSignalSize
			ifTrue: [ semaphoresToSignalCountB := semaphoresToSignalCountB + 1.
				semaphoresToSignalB at: semaphoresToSignalCountB put: index]].
	self forceInterruptCheck
! !
!Interpreter methodsFor: 'primitive support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/11/2009 19:09'!
signed32BitIntegerFor: integerValue
	"Return a full 32 bit integer object for the given integer value"
	| newLargeInteger value largeClass |
	<inline: false>
	<var: #integerValue type: 'int'>
	(self isIntegerValue: integerValue)
		ifTrue: [^ self integerObjectOf: integerValue].
	integerValue < 0
		ifTrue:[	largeClass := self classLargeNegativeInteger.
				value := 0 - integerValue]
		ifFalse:[	largeClass := self classLargePositiveInteger.
				value := integerValue].
	newLargeInteger := self instantiateClass: largeClass indexableSize: 4.
	self storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF).
	self storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF).
	self storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF).
	self storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF).
	^ newLargeInteger! !
!Interpreter methodsFor: 'primitive support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 11/29/2008 15:36'!
signed32BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a four-byte LargeInteger."
	| sz value largeClass negative |
	<inline: false>
	<returnTypeC: 'int'>
	<var: 'value' type: 'int'>
	(self isIntegerObject: oop) ifTrue: [^self integerValueOf: oop].
	(self lengthOf: oop) > 4 ifTrue: [^ self primitiveFail].
	largeClass := self fetchClassOf: oop.
	largeClass = self classLargePositiveInteger
		ifTrue:[negative := false]
		ifFalse:[largeClass = self classLargeNegativeInteger
					ifTrue:[negative := true]
					ifFalse:[^self primitiveFail]].
	sz := self lengthOf: oop.
	sz = 4 ifFalse: [^ self primitiveFail].
	value := (self fetchByte: 0 ofObject: oop) +
		  ((self fetchByte: 1 ofObject: oop) <<  8) +
		  ((self fetchByte: 2 ofObject: oop) << 16) +
		  ((self fetchByte: 3 ofObject: oop) << 24).
	"Fail if value exceeds range of a 32-bit two's-complement signed integer."
	negative
		ifTrue:[value := 0 - value.
				value >= 0 ifTrue: [^ self primitiveFail]]
		ifFalse:[value < 0 ifTrue:[^ self primitiveFail]].
	^ value! !
!Interpreter methodsFor: 'primitive support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 3/10/2009 18:08'!
signed64BitIntegerFor: integerValue
	"Return a Large Integer object for the given integer value"
	| newLargeInteger magnitude largeClass intValue highWord sz |
	<inline: false>
	<var: 'integerValue' type: 'sqLong'>
	<var: 'magnitude' type: 'unsigned sqLong'>
	<var: 'highWord' type: 'usqInt'>

	integerValue < 0
		ifTrue:[	largeClass := self classLargeNegativeInteger.
				magnitude := 0 - integerValue]
		ifFalse:[	largeClass := self classLargePositiveInteger.
				magnitude := integerValue].

	magnitude <= 16r7FFFFFFF ifTrue:[^self signed32BitIntegerFor: integerValue].

	highWord := self cCode: 'magnitude >> 32'. "shift is coerced to usqInt otherwise"
	highWord = 0 
		ifTrue:[sz := 4] 
		ifFalse:[
			sz := 5.
			(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
			(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
			(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
		].
	newLargeInteger := self instantiateClass: largeClass indexableSize:  sz.
	0 to: sz-1 do: [:i |
		intValue := self cCode: '(magnitude >> (i * 8)) & 255'.
		self storeByte: i ofObject: newLargeInteger withValue: intValue].
	^ newLargeInteger! !
!Interpreter methodsFor: 'primitive support' stamp: 'dtl (auto pragmas dtl 2010-09-26) 11/29/2008 15:36'!
signed64BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a eight-byte LargeInteger."
	| sz value largeClass negative szsqLong |
	<inline: false>
	<returnTypeC: 'sqLong'>
	<var: 'value' type: 'sqLong'>
	(self isIntegerObject: oop) ifTrue: [^self cCoerce: (self integerValueOf: oop) to: 'sqLong'].
	sz := self lengthOf: oop.
	sz > 8 ifTrue: [^ self primitiveFail].
	largeClass := self fetchClassOf: oop.
	largeClass = self classLargePositiveInteger
		ifTrue:[negative := false]
		ifFalse:[largeClass = self classLargeNegativeInteger
					ifTrue:[negative := true]
					ifFalse:[^self primitiveFail]].
	szsqLong := self cCode: 'sizeof(sqLong)'.
	sz > szsqLong 
		ifTrue: [^ self primitiveFail].
	value := 0.
	0 to: sz - 1 do: [:i |
		value := value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: 'sqLong') <<  (i*8))].
	"Fail if value exceeds range of a 64-bit two's-complement signed integer."
	negative
		ifTrue:[value := 0 - value.
				value >= 0 ifTrue: [^ self primitiveFail]]
		ifFalse:[value < 0 ifTrue:[^ self primitiveFail]].
	^ value! !
!Interpreter methodsFor: 'send bytecodes'!
singleExtendedSendBytecode
	"Can use any of the first 32 literals for the selector and pass up to 7 arguments."

	| descriptor |
	descriptor := self fetchByte.
	messageSelector := self literal: (descriptor bitAnd: 16r1F).
	argumentCount := descriptor >> 5.
	self normalSend.! !
!Interpreter methodsFor: 'send bytecodes'!
singleExtendedSuperBytecode
	"Can use any of the first 32 literals for the selector and pass up to 7 arguments."

	| descriptor |
	descriptor := self fetchByte.
	messageSelector := self literal: (descriptor bitAnd: 16r1F).
	argumentCount := descriptor >> 5.
	self superclassSend.
! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:47'!
sizeOfSTArrayFromCPrimitive: cPtr
	"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
	"Note: Only called by translated primitive code."

	| oop |
	<var: #cPtr type: 'void *'>
	oop := (self oopForPointer: (self cCoerce: cPtr to: 'char *')) - self baseHeaderSize.
	(self isWordsOrBytes: oop) ifFalse: [
		self primitiveFail.
		^0].
	^self lengthOf: oop
! !
!Interpreter methodsFor: 'object format' stamp: 'ar 10/10/1998 21:24'!
slotSizeOf: oop
	"Returns the number of slots in the receiver.
	If the receiver is a byte object, return the number of bytes.
	Otherwise return the number of words."
	(self isIntegerObject: oop) ifTrue:[^0].
	^self lengthOf: oop! !
!Interpreter methodsFor: 'image save/restore' stamp: 'ikp (auto pragmas 12/08) 8/3/2004 18:24'!
snapshot: embedded 
	"update state of active context"
	| activeProc dataSize rcvr setMacType |
	<var: #setMacType type: 'void *'>
	compilerInitialized
		ifTrue: [self compilerPreSnapshot]
		ifFalse: [self storeContextRegisters: activeContext].

	"update state of active process"
	activeProc := self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
	self
		storePointer: SuspendedContextIndex
		ofObject: activeProc
		withValue: activeContext.

	"compact memory and compute the size of the memory actually in use"
	self incrementalGC.

	"maximimize space for forwarding table"
	self fullGC.
	self snapshotCleanUp.

	dataSize := freeBlock - self startOfMemory. "Assume all objects are below the start of the free block"
	successFlag
		ifTrue: [rcvr := self popStack.
			"pop rcvr"
			self push: trueObj.
			self writeImageFile: dataSize.
			embedded
				ifFalse: ["set Mac file type and creator; this is a noop on other platforms"
					setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
					setMacType = 0
						ifFalse: [self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
			self pop: 1].

	"activeContext was unmarked in #snapshotCleanUp, mark it old "
	self beRootIfOld: activeContext.
	successFlag
		ifTrue: [self push: falseObj]
		ifFalse: [self push: rcvr].
	compilerInitialized
		ifTrue: [self compilerPostSnapshot]! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 5/18/2010 21:47'!
snapshotCleanUp
	"Clean up right before saving an image, sweeping memory and:
	* nilling out all fields of contexts above the stack pointer. 
	* flushing external primitives 
	* clearing the root bit of any object in the root table "
	| oop header fmt sz |
	oop := self firstObject.
	[self oop: oop isLessThan: endOfMemory]
		whileTrue: [(self isFreeObject: oop)
				ifFalse: [header := self longAt: oop.
					fmt := header >> 8 bitAnd: 15.
					"Clean out context"
					(fmt = 3 and: [self isContextHeader: header])
						ifTrue: [sz := self sizeBitsOf: oop.
							(self lastPointerOf: oop) + self bytesPerWord
								to: sz - self baseHeaderSize by: self bytesPerWord
								do: [:i | self longAt: oop + i put: nilObj]].
					"Clean out external functions"
					fmt >= 12
						ifTrue: ["This is a compiled method"
							(self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
								ifTrue: ["It's primitiveExternalCall"
									self flushExternalPrimitiveOf: oop]]].
			oop := self objectAfter: oop].
	self clearRootsTable! !
!Interpreter methodsFor: 'message sending'!
specialSelector: index

	^ self fetchPointer: (index * 2) ofObject: (self splObj: SpecialSelectors)! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl (auto pragmas dtl 2010-09-26) 10/30/2008 07:15'!
sqImage: memoryAddress read: fileStream size: elementSize length: length
	"Normally implemented in support code as fread().
	See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."
 
	<inline: true>
	<returnTypeC: 'size_t'>
	<var: #memoryAddress type: 'char *'>
	<var: #elementSize type: 'size_t'>
	<var: #length type: 'size_t'>
	<var: #fileStream type: 'sqImageFile'>
	^ self sqImage: memoryAddress File: elementSize  ReadEntire: length Image: fileStream 

! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl (auto pragmas dtl 2010-09-26) 7/3/2008 20:21'!
sqImage: memoryAddress write: fileStream size: elementSize length: length
	"Normally implemented in support code as fwrite()"

	<inline: true>
	<returnTypeC: 'size_t'>
	<var: #memoryAddress type: 'char *'>
	<var: #elementSize type: 'size_t'>
	<var: #length type: 'size_t'>
	<var: #fileStream type: 'sqImageFile'>
	^ self sq: memoryAddress Image: elementSize File: length Write: fileStream "sqImageFileWrite()"
! !
!Interpreter methodsFor: 'array primitive support' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 23:56'!
stObject: array at: index
	"Return what ST would return for <obj> at: index."

	| hdr fmt totalLength fixedFields stSize |
	<inline: false>
	hdr := self baseHeader: array.
	fmt := (hdr >> 8) bitAnd: 16rF.
	totalLength := self lengthOf: array baseHeader: hdr format: fmt.
	fixedFields := self fixedFieldsOf: array format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [stSize := self fetchStackPointerOf: array]
		ifFalse: [stSize := totalLength - fixedFields].
	((self oop: index isGreaterThanOrEqualTo: 1)
			and: [self oop: index isLessThanOrEqualTo: stSize])
		ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]
		ifFalse: [successFlag := false.  ^ 0].! !
!Interpreter methodsFor: 'array primitive support' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 23:56'!
stObject: array at: index put: value
	"Do what ST would return for <obj> at: index put: value."
	| hdr fmt totalLength fixedFields stSize |
	<inline: false>
	hdr := self baseHeader: array.
	fmt := (hdr >> 8) bitAnd: 16rF.
	totalLength := self lengthOf: array baseHeader: hdr format: fmt.
	fixedFields := self fixedFieldsOf: array format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [stSize := self fetchStackPointerOf: array]
		ifFalse: [stSize := totalLength - fixedFields].
	((self oop: index isGreaterThanOrEqualTo: 1)
			and: [self oop: index isLessThanOrEqualTo: stSize])
		ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
		ifFalse: [successFlag := false]! !
!Interpreter methodsFor: 'array primitive support' stamp: 'tpr (auto pragmas 12/08) 3/7/2003 19:52'!
stSizeOf: oop
	"Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)."
	"Note: Assume oop is not a SmallInteger!!"

	| hdr fmt totalLength fixedFields |
	<inline: false>
	hdr := self baseHeader: oop.
	fmt := (hdr >> 8) bitAnd: 16rF.
	totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
	fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [^ self fetchStackPointerOf: oop]
		ifFalse: [^ totalLength - fixedFields]! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:47'!
stackFloatValue: offset
	"Note: May be called by translated primitive code."
	| result floatPointer |
	<returnTypeC: 'double'>
	<var: #result type: 'double '>
	floatPointer := self longAt: stackPointer - (offset * self bytesPerWord).
	(self fetchClassOf: floatPointer) = (self splObj: ClassFloat) 
		ifFalse:[self primitiveFail. ^0.0].
	self cCode: '' inSmalltalk: [result := Float new: 2].
	self fetchFloatAt: floatPointer + self baseHeaderSize into: result.
	^ result! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 21:05'!
stackIntegerValue: offset
	| integerPointer |
	integerPointer := self longAt: stackPointer - (offset * self bytesPerWord).
	^self checkedIntegerValueOf: integerPointer! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 21:05'!
stackObjectValue: offset
	"Ensures that the given object is a real object, not a SmallInteger."

	| oop |
	oop := self longAt: stackPointer - (offset * self bytesPerWord).
	(self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
	^ oop
! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/19/2010 11:06'!
stackPointerIndex
	"Return the 0-based index rel to the current context.
	(This is what stackPointer used to be before conversion to pointer"
	^ (stackPointer - activeContext - self baseHeaderSize) >> self shiftForWord! !
!Interpreter methodsFor: 'contexts'!
stackTop
	^self longAt: stackPointer! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 21:05'!
stackValue: offset
	^ self longAt: stackPointer - (offset * self bytesPerWord)! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl 11/4/2008 17:00'!
storeAndPopReceiverVariableBytecode
	"Note: This code uses 
	storePointerUnchecked:ofObject:withValue: and does the 
	store check explicitely in order to help the translator 
	produce better code."
	| rcvr top |
	self flag: #'requires currentBytecode to be expanded to a constant'.
	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	rcvr := receiver.
	top := self internalStackTop.
	(self oop: rcvr isLessThan: youngStart)
		ifTrue: [self possibleRootStoreInto: rcvr value: top].
	self storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
	self internalPop: 1! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'eem 5/24/2008 11:01'!
storeAndPopRemoteTempLongBytecode
	self storeRemoteTempLongBytecode.
	self internalPop: 1! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'dtl 7/2/2008 12:23'!
storeAndPopTemporaryVariableBytecode

	self flag: #'requires currentBytecode to be expanded to a constant'.
	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
		ofObject: localHomeContext
		withValue: self internalStackTop.
	self internalPop: 1.
! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:48'!
storeContextRegisters: activeCntx
	"Note: internalStoreContextRegisters: should track changes to this method."

	"InstructionPointer is a pointer variable equal to
	method oop + ip + self baseHeaderSize
		-1 for 0-based addressing of fetchByte
		-1 because it gets incremented BEFORE fetching currentByte"

	<inline: true>
	self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: (instructionPointer - method - (self baseHeaderSize - 2))).
	self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
! !
!Interpreter methodsFor: 'contexts' stamp: 'tpr 5/12/2005 22:15'!
storeInstructionPointerValue: value inContext: contextPointer
	"Assume: value is an integerValue"

	self storePointerUnchecked: InstructionPointerIndex ofObject: contextPointer withValue: (self integerObjectOf: value).! !
!Interpreter methodsFor: 'utilities' stamp: 'tpr 5/12/2005 15:53'!
storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue 
	"Note: May be called by translated primitive code."
	(self isIntegerValue: integerValue)
		ifTrue: [self storePointerUnchecked: fieldIndex ofObject: objectPointer
					withValue: (self integerObjectOf: integerValue)]
		ifFalse: [self primitiveFail]! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'eem 5/24/2008 11:00'!
storeRemoteTemp: index inVectorAt: tempVectorIndex
	| tempVector |
	tempVector := self temporary: tempVectorIndex.
	self storePointer: index ofObject: tempVector withValue: self internalStackTop.! !
!Interpreter methodsFor: 'stack bytecodes' stamp: 'eem 5/27/2008 13:29'!
storeRemoteTempLongBytecode
	| remoteTempIndex tempVectorIndex |
	remoteTempIndex := self fetchByte.
	tempVectorIndex := self fetchByte.
	self fetchNextBytecode.
	self storeRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! !
!Interpreter methodsFor: 'contexts' stamp: 'tpr 5/13/2005 10:44'!
storeStackPointerValue: value inContext: contextPointer
	"Assume: value is an integerValue"

	self storePointerUnchecked: StackPointerIndex ofObject: contextPointer
		withValue: (self integerObjectOf: value).! !
!Interpreter methodsFor: 'array primitive support' stamp: 'di (auto pragmas 12/08) 7/4/2004 08:43'!
subscript: array with: index format: fmt
	"Note: This method assumes that the index is within bounds!!"

	<inline: true>
	fmt <= 4 ifTrue: [  "pointer type objects"
		^ self fetchPointer: index - 1 ofObject: array].
	fmt < 8 ifTrue: [  "long-word type objects"
		^ self positive32BitIntegerFor:
			(self fetchLong32: index - 1 ofObject: array)
	] ifFalse: [  "byte-type objects"
		^ self integerObjectOf:
			(self fetchByte: index - 1 ofObject: array)
	].! !
!Interpreter methodsFor: 'array primitive support' stamp: 'di (auto pragmas 12/08) 7/4/2004 09:00'!
subscript: array with: index storing: oopToStore format: fmt 
	"Note: This method assumes that the index is within bounds!!"
	| valueToStore |
	<inline: true>
	fmt <= 4
		ifTrue: ["pointer type objects"
			self storePointer: index - 1 ofObject: array
				withValue: oopToStore]
		ifFalse: [fmt < 8
				ifTrue: ["long-word type objects"
					valueToStore := self positive32BitValueOf: oopToStore.
					successFlag
						ifTrue: [self storeLong32: index - 1 ofObject: array
									withValue: valueToStore]]
				ifFalse: ["byte-type objects"
					(self isIntegerObject: oopToStore)
						ifFalse: [successFlag := false].
					valueToStore := self integerValueOf: oopToStore.
					(valueToStore >= 0
							and: [valueToStore <= 255])
						ifFalse: [successFlag := false].
					successFlag
						ifTrue: [self
								storeByte: index - 1
								ofObject: array
								withValue: valueToStore]]]! !
!Interpreter methodsFor: 'primitive support'!
success: successValue

	successFlag := successValue & successFlag.! !
!Interpreter methodsFor: 'object access primitives' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:06'!
sufficientSpaceToInstantiate: classOop indexableSize: size 
	"Return true if there is enough space to allocate an instance of the given class with the given number of indexable fields."
	"Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
	| format |
	<inline: true>
	<var: #size type: 'usqInt'>
	<var: #bytesNeeded type: 'usqInt'>
	format := (self formatOfClass: classOop) >> 8 bitAnd: 16rF.

	"Fail if attempting to call new: on non-indexable class"
	(size > 0 and: [format < 2])
		ifTrue: [^ false].

	format < 8
		ifTrue: ["indexable fields are words or pointers"
				(self isExcessiveAllocationRequest: size shift: self shiftForWord) ifTrue: [^ false].
				^ self sufficientSpaceToAllocate: 2500 + (size * self bytesPerWord)]
		ifFalse: ["indexable fields are bytes"
				(self isExcessiveAllocationRequest: size shift: 0) ifTrue: [^ false].
				^ self sufficientSpaceToAllocate: 2500 + size]
! !
!Interpreter methodsFor: 'message sending'!
superclassOf: classPointer

	^ self fetchPointer: SuperclassIndex ofObject: classPointer! !
!Interpreter methodsFor: 'message sending' stamp: 'ar (auto pragmas dtl 2010-09-26) 7/6/2003 22:20'!
superclassSend
	"Send a message to self, starting lookup with the superclass of the class containing the currently executing method."
	"Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"
	"Note: This method is inlined into the interpreter dispatch loop."
	| rcvr |
	<inline: true>
	self sharedCodeNamed: 'commonSupersend' inCase: 133.
	lkupClass := self superclassOf: (self methodClassOf: method).
	rcvr := self internalStackValue: argumentCount.
	receiverClass := self fetchClassOf: rcvr.
	self commonSend.! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr (auto pragmas 12/08) 3/24/2004 20:57'!
synchronousSignal: aSemaphore 
	"Signal the given semaphore from within the interpreter."
	| excessSignals |
	<inline: false>
	(self isEmptyList: aSemaphore)
		ifTrue: ["no process is waiting on this semaphore"
			excessSignals := self fetchInteger: ExcessSignalsIndex ofObject: aSemaphore.
			self storeInteger: ExcessSignalsIndex ofObject: aSemaphore withValue: excessSignals + 1]
		ifFalse: [self resume: (self removeFirstLinkOfList: aSemaphore)]! !
!Interpreter methodsFor: 'compiled methods' stamp: 'di 7/19/2004 14:59'!
tempCountOf: methodPointer
	^ ((self headerOf: methodPointer) >> 19) bitAnd: 16r3F! !
!Interpreter methodsFor: 'contexts' stamp: 'jm 12/7/1998 07:42'!
temporary: offset

	^ self fetchPointer: offset + TempFrameStart ofObject: localHomeContext! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl 9/26/2010 11:32'!
transfer: count from: src to: dst 
	| in out lastIn |
	<inline: true>
	self flag: #Dan.  "Need to check all senders before converting this for 64 bits"
	in := src - self bytesPerWord.
	lastIn := in + (count * self bytesPerWord).
	out := dst - self bytesPerWord.
	[self oop: in isLessThan: lastIn]
		whileTrue: [self
				longAt: (out := out + self bytesPerWord)
				put: (self longAt: (in := in + self bytesPerWord))]! !
!Interpreter methodsFor: 'utilities' stamp: 'dtl 9/26/2010 11:33'!
transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
	"Transfer the specified fullword fields, as from calling context to called context"
	
	"Assume: beRootIfOld: will be called on toOop."
	| fromIndex toIndex lastFrom |
	<inline: true>
	self flag: #Dan.  "Need to check all senders before converting this for 64 bits"
	fromIndex := fromOop + (firstFrom * self bytesPerWord).
	toIndex := toOop + (firstTo * self bytesPerWord).
	lastFrom := fromIndex + (count * self bytesPerWord).
	[self oop: fromIndex isLessThan: lastFrom]
		whileTrue: [fromIndex := fromIndex + self bytesPerWord.
			toIndex := toIndex + self bytesPerWord.
			self
				longAt: toIndex
				put: (self longAt: fromIndex)]! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/24/2004 20:58'!
transferTo: aProc 
	"Record a process to be awoken on the next interpreter cycle. 
	ikp 11/24/1999 06:07 -- added hook for external runtime 
	compiler "
	| sched oldProc newProc |
	newProc := aProc.
	sched := self schedulerPointer.
	oldProc := self fetchPointer: ActiveProcessIndex ofObject: sched.
	self storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
	compilerInitialized
		ifTrue: [self compilerProcessChange: oldProc to: newProc]
		ifFalse: [self storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
			self newActiveContext: (self fetchPointer: SuspendedContextIndex ofObject: newProc).
			self storePointer: SuspendedContextIndex ofObject: newProc withValue: nilObj].
	reclaimableContextCount := 0! !
!Interpreter methodsFor: 'contexts' stamp: 'dtl 5/18/2010 21:06'!
unPop: nItems
	stackPointer := stackPointer + (nItems * self bytesPerWord)! !
!Interpreter methodsFor: 'interpreter shell'!
unknownBytecode
	"This should never get called; it means that an unimplemented bytecode appears in a CompiledMethod."

	self error: 'Unknown bytecode'.! !
!Interpreter methodsFor: 'debug support' stamp: 'dtl 5/19/2010 12:30'!
verifyCleanHeaders
	| oop |
	oop := self firstObject.
	[self oop: oop isLessThan: endOfMemory] whileTrue:
		[(self isFreeObject: oop)
			ifTrue: ["There should only be one free block at end of memory."
					(self objectAfter: oop) = endOfMemory
						ifFalse: [self error: 'Invalid obj with HeaderTypeBits = Free.']]
			ifFalse: [((self longAt: oop) bitAnd: self markBit) = 0
						ifFalse: [self error: 'Invalid obj with MarkBit set.']].
		oop := self objectAfter: oop]! !
!Interpreter methodsFor: 'plugin support' stamp: 'dtl 12/28/2005 13:03'!
vmEndianness
	"return 0 for little endian, 1 for big endian"

	self isBigEnder ifTrue: [^ 1] ifFalse: [^ 0]
! !
!Interpreter methodsFor: 'process primitive support' stamp: 'tpr 3/24/2004 20:59'!
wakeHighestPriority
	"Return the highest priority process that is ready to run."
	"Note: It is a fatal VM error if there is no runnable process."
	| schedLists p processList |
	schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
	p := self fetchWordLengthOf: schedLists.
	p := p - 1.
	"index of last indexable field"
	processList := self fetchPointer: p ofObject: schedLists.
	[self isEmptyList: processList]
		whileTrue: [p := p - 1.
			p < 0 ifTrue: [self error: 'scheduler could not find a runnable process'].
			processList := self fetchPointer: p ofObject: schedLists].
	^ self removeFirstLinkOfList: processList! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:33'!
wordSwapped: w
	"Return the given 64-bit integer with its halves in the reverse order."

	<inline: true>
	self isDefinedTrueExpression: 'BYTES_PER_WORD == 8'
		inSmalltalk: [self bytesPerWord = 8]
		comment: 'swap 32-bit ends of a 64-bit object word'
		ifTrue: [^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
	  					+ ((w bitShift: Byte4Shift) bitAnd: Bytes7to4Mask)]
		ifFalse: [self error: 'This cannot happen.']
! !
!Interpreter methodsFor: 'image save/restore' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:34'!
writeImageFile: imageBytes

	| fn |
	<var: #fn type: 'void *'>
	self writeImageFileIO: imageBytes.
	"set Mac file type and creator; this is a noop on other platforms"
	fn := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
	fn = 0 ifFalse:[
		self cCode:'((sqInt (*)(char*, char*, char*))fn)(imageName, "STim", "FAST")'.
	].
! !
!Interpreter methodsFor: 'image save/restore' stamp: 'dtl 10/24/2010 21:03'!
writeImageFileIO: imageBytes

	| headerStart headerSize f bytesWritten sCWIfn okToWrite |
	<var: #f type: 'sqImageFile'>
	<var: #headerStart type: 'squeakFileOffsetType '>
	<var: #sCWIfn type: 'void *'>

	"If the security plugin can be loaded, use it to check for write permission.
	If not, assume it's ok"
	sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
	sCWIfn ~= 0 ifTrue:[okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
		okToWrite ifFalse:[^self primitiveFail]].
	
	"local constants"
	headerStart := 0.  
	headerSize := 16 * self bytesPerWord.  "header size in bytes; do not change!!"

	f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
	f = nil ifTrue: [
		"could not open the image file for writing"
		self success: false.
		^ nil].

	headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
	self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
	"position file to start of header"
	self sqImageFile: f Seek: headerStart.

	self putLong: (self imageFormatVersion) toFile: f.
	self putLong: headerSize toFile: f.
	self putLong: imageBytes toFile: f.
	self putLong: (self startOfMemory) toFile: f.
	self putLong: specialObjectsOop toFile: f.
	self putLong: lastHash toFile: f.
	self putLong: (self ioScreenSize) toFile: f.
	self putLong: fullScreenFlag toFile: f.
	self putLong: extraVMMemory toFile: f.
	1 to: 7 do: [:i | self putLong: 0 toFile: f].  "fill remaining header words with zeros"
	successFlag ifFalse: [
		"file write or seek failure"
		self cCode: 'sqImageFileClose(f)'.
		^ nil].

	"position file after the header"
	self sqImageFile: f Seek: headerStart + headerSize.

	"write the image data"
	bytesWritten := self
		sqImage: (self pointerForOop: memory)
		write: f
		size: (self cCode: 'sizeof(unsigned char)')
		length: imageBytes.
	self success: bytesWritten = imageBytes.
	self cCode: 'sqImageFileClose(f)'.

! !

Interpreter subclass: #InterpreterSimulator
	instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulator commentStamp: 'tpr 5/5/2003 12:24' prior: 0!
This class defines basic memory access and primitive simulation so that the Interpreter can run simulated in the Squeak environment.  It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.

To see the thing actually run, you could (after backing up this image and changes), execute

	(InterpreterSimulator new openOn: Smalltalk imageName) test

and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be.  We usually do this with a small and simple benchmark image. You will probably have more luck using InterpreteSimulatorLSB or InterpreterSimulatorMSB as befits your machine.!
!InterpreterSimulator class methodsFor: 'instance creation' stamp: 'nk 4/5/2005 20:22'!
new
	^ self == InterpreterSimulator
		ifTrue: [SmalltalkImage current endianness == #big
				ifTrue: [InterpreterSimulatorMSB new]
				ifFalse: [InterpreterSimulatorLSB new]]
		ifFalse: [super new]! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/20/2004 12:07'!
allObjectsDo: objBlock

	| oop |
	oop := self firstObject.
	[oop < endOfMemory] whileTrue:
			[(self isFreeObject: oop)
				ifFalse: [objBlock value: oop].
			oop := self objectAfter: oop].
! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/20/2004 12:11'!
allObjectsSelect: objBlock
	"self allObjectsSelect: [:oop | (self baseHeader: oop) = 1234]"

	| oop selected |
	oop := self firstObject.
	selected := OrderedCollection new.
	[oop < endOfMemory] whileTrue:
			[(self isFreeObject: oop)
				ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
			oop := self objectAfter: oop].
	^ selected! !
!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/20/2004 11:58'!
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord 

	| newObj |
	newObj := super allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord.
	"byteCount < 600000 ifTrue: [^ newObj]."
	"(self baseHeader: newObj) =  16r0FCC0600 ifTrue: [self halt]."
	^ newObj! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 2/26/2003 14:07'!
browserPluginInitialiseIfNeeded
"do nothing - its a macro in C code to support Mac browser plugin strangeness"! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 2/26/2003 14:03'!
browserPluginReturnIfNeeded
"do nothing - its a macro in C code to support Mac browser plugin strangeness"! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'th 4/15/2000 17:21'!
byteAt: byteAddress
	^self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'th 4/15/2000 17:21'!
byteAt: byteAddress put: byte
	^self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:09'!
byteAtPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and byte is an 8-bit quantity."

	^ self byteAt: pointer! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:13'!
byteAtPointer: pointer put: byteValue
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and byteValue is an 8-bit quantity."

	^ self byteAt: pointer  put: byteValue! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/21/2004 15:05'!
byteCount
	"So you can call this from temp debug statements in, eg, Interpreter, such as
	self byteCount = 12661 ifTrue: [self halt].
	"

	^ byteCount! !
!InterpreterSimulator methodsFor: 'UI' stamp: 'di 4/21/2004 00:09'!
byteCountText
	^ byteCount printString asText! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'dtl 5/19/2010 22:23'!
bytesPerWord
	"BytesPerWord was a class variable in ObjectMemory, permitting each object
	memory to have its own word size."

	^ bytesPerWord ifNil: [bytesPerWord := 4]! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'dtl 5/19/2010 18:44'!
bytesPerWord: fourOrEight
	"BytesPerWord was a class variable in ObjectMemory, permitting each object
	memory to have its own word size."

	bytesPerWord := fourOrEight! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'crl 3/3/2003 01:15'!
cCoerce: value to: cTypeString
	"Type coercion for translation only; just return the value when running in Smalltalk."

	^value == nil
		ifTrue: [value]
		ifFalse: [value coerceTo: cTypeString sim: self]! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/11/2000 22:01'!
callExternalPrimitive: mapIndex
	| entry |
	entry := (mappedPluginEntries at: mapIndex).
	^(entry at: 1) perform: (entry at: 2).! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'th 4/15/2000 17:22'!
charsOfLong: long
	^self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/28/2004 17:24'!
checkForInterrupts
	"Prevent interrupts so that traces are consistent during detailed debugging"

	true ifTrue: [^ self].
	^ super checkForInterrupts! !
!InterpreterSimulator methodsFor: 'debug support'!
classAndSelectorOfMethod: meth forReceiver: rcvr
	| mClass dict length methodArray |
	mClass := self fetchClassOf: rcvr.
	[dict := self fetchPointer: MessageDictionaryIndex ofObject: mClass.
	length := self fetchWordLengthOf: dict.
	methodArray := self fetchPointer: MethodArrayIndex ofObject: dict.
	0 to: length-SelectorStart-1 do: 
		[:index | 
		meth = (self fetchPointer: index ofObject: methodArray) 
			ifTrue: [^ Array
				with: mClass
				with: (self fetchPointer: index + SelectorStart ofObject: dict)]].
	mClass := self fetchPointer: SuperclassIndex ofObject: mClass.
	mClass = nilObj]
		whileFalse: [].
	^ Array
		with: (self fetchClassOf: rcvr)
		with: (self splObj: SelectorDoesNotUnderstand)! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'yo 2/14/2001 11:15'!
classNameOf: aClass Is: className
	"Check if aClass' name is className"
	| name |
	(self lengthOf: aClass) <= 6 ifTrue:[^false]. "Not a class but maybe behavior" 
	name := self fetchPointer: 6 ofObject: aClass.
	(self isBytes: name) ifFalse:[^false].
	^ className = (self stringOf: name).
! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/2001 12:26'!
clipboardRead: sz Into: actualAddress At: zeroBaseIndex
	| str |
	str := Clipboard clipboardText.
	1 to: sz do:
		[:i | self byteAt: actualAddress + zeroBaseIndex + i - 1 put: (str at: i) asciiValue]! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/2001 12:18'!
clipboardSize

	^ Clipboard clipboardText size! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'dtl 5/19/2010 18:38'!
clipboardWrite: sz From: actualDataAddress At: ignored

	Clipboard clipboardText: (self stringOf: actualDataAddress - self baseHeaderSize)! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 11/23/1998 16:46'!
close  "close any files that ST may have opened"
	filesOpen do: [:f | f close]! !
!InterpreterSimulator methodsFor: 'debug support'!
compactClassAt: ccIndex
	"Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)"

	| classArray |
	classArray := self fetchPointer: CompactClasses ofObject: specialObjectsOop.
	^ self fetchPointer: (ccIndex - 1) ofObject: classArray! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 5/8/2004 16:42'!
convertToArray
	"I dont believe it -- this *just works*"
	
	memory := memory as: Array! !
!InterpreterSimulator methodsFor: 'I/O primitives support'!
copyBits

	^ myBitBlt copyBits! !
!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:26'!
cr

	traceOn ifTrue: [ transcript cr; endEntry ].! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 4/20/2004 12:06'!
dispatchFunctionPointer: selector
"handle the primitive direct dispatch macro in simulation"
	^self perform: selector! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 4/2/2004 15:40'!
dispatchFunctionPointerOn: index in: table
"handle the primitive table dispatch macro in simulation"
	^self dispatchOn: index in: table! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 4/2/2004 15:07'!
dispatchOn: anInteger in: selectorArray
	"Simulate a case statement via selector table lookup.
	The given integer must be between 0 and selectorArray size-1, inclusive.
	For speed, no range test is done, since it is done by the at: operation.
	Note that, unlike many other arrays used in the Interpreter, this method expect NO CArrayAccessor wrapping - it would duplicate the +1. Maybe this would be better updated to make it all uniform"

	self perform: (selectorArray at: (anInteger + 1)).! !
!InterpreterSimulator methodsFor: 'I/O primitives support'!
displayLocation

	^ Display extent - displayForm extent - (10@10)! !
!InterpreterSimulator methodsFor: 'I/O primitives support'!
drawLoopX: xDelta Y: yDelta

	^ myBitBlt drawLoopX: xDelta Y: yDelta! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'dtl 5/19/2010 16:27'!
dumpHeader: hdr
	| cc |
	^ String streamContents: [:strm |
		cc := (hdr bitAnd: CompactClassMask) >> 12.
		strm nextPutAll: '<cc=', cc hex.
		cc > 0 ifTrue:
			[strm nextPutAll: ':' , (self nameOfClass: (self compactClassAt: cc))].
		strm nextPutAll: '>'.
		strm nextPutAll: '<ft=', ((hdr bitShift: -8) bitAnd: 16rF) hex , '>'.
		strm nextPutAll: '<sz=', (hdr bitAnd: self sizeMask) hex , '>'.
		strm nextPutAll: '<hdr=', (#(big class gcMark short) at: (hdr bitAnd: 3) +1) , '>']
! !
!InterpreterSimulator methodsFor: 'debug support'!
dumpMethodHeader: hdr
	^ String streamContents:
		[:strm |
		strm nextPutAll: '<nArgs=', ((hdr >> 25) bitAnd: 16r1F) printString , '>'.
		strm nextPutAll: '<nTemps=', ((hdr >> 19) bitAnd: 16r3F) printString , '>'.
		strm nextPutAll: '<lgCtxt=', ((hdr >> 18) bitAnd: 16r1) printString , '>'.
		strm nextPutAll: '<nLits=', ((hdr >> 10) bitAnd: 16rFF) printString , '>'.
		strm nextPutAll: '<prim=', ((hdr >> 1) bitAnd: 16r1FF) printString , '>'.
		]! !
!InterpreterSimulator methodsFor: 'interpreter shell'!
fetchByte

	^ self byteAt: (localIP := localIP + 1).! !
!InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 6/13/2004 10:31'!
fetchFloatAt: floatBitsAddress into: aFloat

	aFloat at: 1 put: (self long32At: floatBitsAddress).
	aFloat at: 2 put: (self long32At: floatBitsAddress+4).
! !
!InterpreterSimulator methodsFor: 'file primitives'!
fileValueOf: integerPointer
	"Convert the (integer) fileID to the actual fileStream it uses"
	self success: (self isIntegerObject: integerPointer).
	successFlag
		ifTrue: [^ filesOpen at: (self integerValueOf: integerPointer)]
		ifFalse: [^ nil]! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/11/1998 17:06'!
findNewMethodInClass: class
"
	| cName |
	traceOn ifTrue:
		[cName := (self sizeBitsOf: class) = 16r20
			ifTrue: ['class ' , (self nameOfClass: (self fetchPointer: 6 ofObject: class))]
			ifFalse: [(self nameOfClass: class)].
		self cr; print: cName , '>>' , (self stringOf: messageSelector)].
"

(self stringOf: messageSelector) = 'doesNotUnderstand:' ifTrue: [self halt].

	sendCount := sendCount + 1.

"
	(sendCount > 1000 and: [sendCount\\10 = 0]) ifTrue:
		[Transcript print: sendCount; space.
		self validate].
"
"
	(sendCount > 100150) ifTrue:
		[self qvalidate.
		messageQueue == nil ifTrue: [messageQueue := OrderedCollection new].
		messageQueue addLast: (self stringOf: messageSelector)].
"
	super findNewMethodInClass: class.! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'dtl 5/19/2010 18:38'!
firstIndexableField: oop
	"NOTE: overridden from Interpreter to add coercion to CArray"

	| hdr fmt totalLength fixedFields |
	self returnTypeC: 'void *'.
	hdr := self baseHeader: oop.
	fmt := (hdr >> 8) bitAnd: 16rF.
	totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
	fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
	fmt < 8 ifTrue:
		[fmt = 6 ifTrue:
			["32 bit field objects"
			^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)) to: 'int *'].
		"full word objects (pointer or bits)"
		^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *']
		ifFalse:
		["Byte objects"
		^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + fixedFields) to: 'char *']! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/11/2000 21:59'!
flushExternalPrimitives
	mappedPluginEntries := #().
	super flushExternalPrimitives.! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 7/9/2004 11:05'!
fullDisplay
	| t |
	displayForm == nil ifTrue: [^ self].
	t := successFlag.  successFlag := true.
	self displayBitsOf: (self splObj: TheDisplay) Left: 0 Top: 0 Right: displayForm width Bottom: displayForm height.
	successFlag := t! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/21/2004 15:58'!
fullDisplayUpdate
	"Preserve successFlag when call asynchronously from Simulator"
	| s |
	s := successFlag.
	successFlag := true.
	super fullDisplayUpdate.
	successFlag := s! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 5/11/2004 18:26'!
fullGC
	transcript cr; show:'<Running full GC ...'.
	super fullGC.
	transcript show: ' done>'.! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'ikp 8/2/2004 17:59'!
functionPointerFor: primIndex inClass: lookupClass
	"Override Interpreter to handle the external primitives caching.  See also 	internalExecuteNewMethod."

	^(primIndex between: 1 and: MaxPrimitiveIndex)
		ifTrue: [primitiveTable at: primIndex + 1]! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/16/2004 14:56'!
halfWordHighInLong32: long32
	^self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/16/2004 14:57'!
halfWordLowInLong32: long32
	^self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'debug support'!
headerStart: oop

	^ (self extraHeaderBytes: oop) negated! !
!InterpreterSimulator methodsFor: 'debug support'!
hexDump100: oop
	| byteSize val |
	^ String streamContents:
		[:strm |
		byteSize := 256.
		(self headerStart: oop) to: byteSize by: 4 do:
			[:a | val := self longAt: oop+a.
			strm cr; nextPutAll: (oop+a) hex8; space; space; 
				nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
				space; space; space; nextPutAll: val hex8;
				space; space.
			strm nextPutAll: (self charsOfLong: val).
			strm space; space; nextPutAll: (oop+a) printString]]! !
!InterpreterSimulator methodsFor: 'debug support'!
hexDump: oop
	| byteSize val |
	(self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
	^ String streamContents:
		[:strm |
		byteSize := 256 min: (self sizeBitsOf: oop)-4.
		(self headerStart: oop) to: byteSize by: 4 do:
			[:a | val := self longAt: oop+a.
			strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
				space; space; space; nextPutAll: val hex8;
				space; space.
			a=0
				ifTrue: [strm nextPutAll: (self dumpHeader: val)]
				ifFalse: [strm nextPutAll: (self charsOfLong: val)]]]! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'dtl 5/19/2010 18:47'!
imageFormatVersion
	"The imageFormatVersionNumber variable is initialized in Interpreter class>>declareCVarsIn:
	so provide the value here for simulation."

	^ imageFormatVersionNumber
		ifNil: [imageFormatVersionNumber := self bytesPerWord == 4
						ifTrue: [6502]
						ifFalse: [68000]]! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'dtl 12/11/2010 17:14'!
initialize

	"Initialize the InterpreterSimulator when running the interpreter inside
	Smalltalk. The primary responsibility of this method is to allocate
	Smalltalk Arrays for variables that will be declared as statically-allocated
	global arrays in the translated code."

	"initialize class variables"
	ObjectMemory initializeConstants.
	Interpreter initialize.

	"Note: we must initialize ConstMinusOne differently for simulation,
		due to the fact that the simulator works only with +ve 32-bit values"
	ConstMinusOne := self integerObjectOf: -1.

	methodCache := Array new: MethodCacheSize.
	atCache := Array new: AtCacheTotalSize.
	self flushMethodCache.
	rootTable := Array new: RootTableSize.
	weakRoots := Array new: RootTableSize + RemapBufferSize + 100.
	remapBuffer := Array new: RemapBufferSize.
	semaphoresUseBufferA := true.
	semaphoresToSignalA := Array new: SemaphoresToSignalSize.
	semaphoresToSignalB := Array new: SemaphoresToSignalSize.
	externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
	primitiveTable := self class primitiveTable.
	pluginList := #().
	mappedPluginEntries := #().

	"initialize InterpreterSimulator variables used for debugging"
	byteCount := 0.
	sendCount := 0.
	quitBlock := [^ self].
	traceOn := true.
	myBitBlt := BitBltSimulator new setInterpreter: self.
	filesOpen := OrderedCollection new.
	headerTypeBytes := CArrayAccessor on: (Array with: self bytesPerWord * 2 with: self bytesPerWord with: 0 with: 0).
	transcript := Transcript.
	displayForm := 'Display has not yet been installed' asDisplayText form.
	! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 2/26/2003 14:01'!
insufficientMemoryAvailableError
	self error: 'Failed to allocate memory for the heap'! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 2/26/2003 14:01'!
insufficientMemorySpecifiedError
	self error: 'Insufficient memory for this image'! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'ar 3/3/2001 22:31'!
integerAt: byteAddress
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory integerAt: (byteAddress // 4) + 1! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'ar 3/3/2001 22:31'!
integerAt: byteAddress put: a32BitValue
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory integerAt: (byteAddress // 4) + 1 put: a32BitValue! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 8/5/2004 22:09'!
integerObjectOf: value
	"The simulator works with strictly positive bit patterns"
	value < 0
		ifTrue: [^ ((16r80000000 + value) << 1) + 1]
		ifFalse: [^ (value << 1) + 1]! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 6/23/2004 15:12'!
internalExecuteNewMethod
"Override the Interpreter version to trap cached external prims.
These have a 'prim index' of 1000 + the externalPrimitiveTableIndex normally used"
	primitiveIndex < 1000 ifTrue:[^super internalExecuteNewMethod].
	self externalizeIPandSP.
	self callExternalPrimitive: (externalPrimitiveTable at: primitiveIndex - 1001).
	self internalizeIPandSP! !
!InterpreterSimulator methodsFor: 'security' stamp: 'ar 2/5/2001 18:33'!
ioCanRenameImage
	^true! !
!InterpreterSimulator methodsFor: 'security' stamp: 'ar 2/5/2001 20:42'!
ioCanWriteImage
	^true! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'ajh 8/21/2002 22:41'!
ioExit

	quitBlock value  "Cause return from #test"! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'ikp 12/15/1998 23:33'!
ioForceDisplayUpdate
	"no-op"! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'yo 2/14/2001 14:17'!
ioGetNextEvent: evtBuf

	self primitiveFail.
! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'ar 5/1/1999 09:43'!
ioHasDisplayDepth: depth
	^Display supportsDisplayDepth: depth! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'sr 7/21/2000 20:02'!
ioLoadExternalFunction: functionName OfLength: functionLength FromModule: moduleName OfLength: moduleLength
	"Load and return the requested function from a module"
	| pluginString functionString |
	pluginString := String new: moduleLength.
	1 to: moduleLength do:[:i| pluginString byteAt: i put: (self byteAt: moduleName+i-1)].
	functionString := String new: functionLength.
	1 to: functionLength do:[:i| functionString byteAt: i put: (self byteAt: functionName+i-1)].
	functionString := functionString asSymbol.
	^self ioLoadFunction: functionString From: pluginString! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'tpr 4/7/2004 21:21'!
ioLoadFunction: functionString From: pluginString
	"Load and return the requested function from a module"
	| plugin fnSymbol |
	fnSymbol := functionString asSymbol.
	Transcript cr; show:'Looking for ', functionString, ' in '.
	pluginString isEmpty
		ifTrue:[Transcript show: 'vm']
		ifFalse:[Transcript show: pluginString].
	plugin := pluginList 
				detect:[:any| any key = pluginString asString]
				ifNone:[self loadNewPlugin: pluginString].
	plugin ifNil:[
		"Transcript cr; show:'Failed ... no plugin found'." ^ 0].
	plugin := plugin value.
	mappedPluginEntries doWithIndex:[:pluginAndName :index|
		((pluginAndName at: 1) == plugin 
			and:[(pluginAndName at: 2) == fnSymbol]) ifTrue:[
				"Transcript show:' ... okay'." ^ index]].
	(plugin respondsTo: fnSymbol) ifFalse:[
		"Transcript cr; show:'Failed ... primitive not in plugin'." ^ 0].
	mappedPluginEntries := mappedPluginEntries copyWith: (Array with: plugin with: fnSymbol).
	"Transcript show:' ... okay'."
	^ mappedPluginEntries size! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 12/1/1998 00:09'!
ioLowResMSecs
	^ Time millisecondClockValue! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 7/1/2004 13:55'!
ioMSecs
	"Return the value of the millisecond clock."
	"NOT.  Actually, we want something a lot slower and, for exact debugging,
	something more repeatable than real time.  IO have an idea: use the byteCount..."

	^ byteCount // 100
	
"At 20k bytecodes per second, this gives us aobut 200 ticks per second, or about 1/5 of what you'd expect for the real time clock.  This should still service events at one or two per second"! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 3/9/1999 10:00'!
ioMicroMSecs
	"Answer the value of the high-resolution millisecond clock."

	^ Time millisecondClockValue
! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'dtl 5/19/2010 15:56'!
ioMicroSecondClock
	"Answer the value of the high-resolution millisecond clock."

	^ self ioMicroMSecs * 1000
! !
!InterpreterSimulator methodsFor: 'I/O primitives'!
ioProcessEvents! !
!InterpreterSimulator methodsFor: 'I/O primitives support'!
ioProcessEventsEveryMSecs: mSecs
	"Noop during simulation."! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'ar 2/5/2001 17:24'!
ioScreenDepth
	^DisplayScreen actualScreenDepth.! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 9/24/97 22:52'!
ioScreenSize
	"Return the screen extent packed into 32 bits."

	^ (displayForm width << 16) + displayForm height! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 9/24/97 22:52'!
ioSeconds
	"Return the value of the second clock."

	^ Time primSecondsClock! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'yo 2/14/2001 14:17'!
ioSetInputSemaphore: index

	self primitiveFail! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'dtl 10/3/2010 09:43'!
isBigEnder
	"Answer true (non-zero) if running on a big endian machine."
	^ self vmEndianness = 1
! !
!InterpreterSimulator methodsFor: 'interpreter shell'!
isIntegerValue: valueWord 
	^ valueWord >= 16r-40000000 and: [valueWord <= 16r3FFFFFFF]! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'ar 10/27/1999 14:21'!
isInterpreterProxy
	"Return false since I am a real Interpreter simulation"
	^false! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'di 7/17/2004 10:23'!
loadNewPlugin: pluginString
	| plugin simClass |
	transcript cr; show:'Looking for module ', pluginString.
	(#('FloatArrayPlugin' 'Matrix2x3Plugin')
		includes: pluginString) ifTrue:
		[transcript show: ' ... defeated'. ^ nil].
	plugin := simClass := nil.
	InterpreterPlugin allSubclassesDo:[:plg|
		plg moduleName asString = pluginString asString ifTrue:[
			simClass := plg simulatorClass.
			plugin ifNil:[plugin := simClass]
				ifNotNil:[plugin == simClass ifFalse:[^self error:'This won''t work...']].
		].
	].
	plugin ifNil:[transcript show: ' ... not found'. ^nil].
	plugin := plugin new.
	plugin setInterpreter: self. "Ignore return value from setInterpreter"
	(plugin respondsTo: #initialiseModule) ifTrue:[
		plugin initialiseModule ifFalse:[transcript show: ' ... initialiser failed'.^nil]. "module initialiser failed"
	].
	pluginList := pluginList copyWith: (pluginString asString -> plugin).
	transcript show:' ... loaded'.
	^pluginList last! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:40'!
logOfBytesVerify: nBytes fromFileNamed: fileName fromStart: loggingStart
	"Verify a questionable interpreter against a successful run"
	"self logOfBytesVerify: 10000 fromFileNamed: 'clone32Bytecodes.log' "
	
	| logFile rightByte prevCtxt |
	logFile := (FileStream readOnlyFileNamed: fileName) binary.
	logging := loggingStart.
	transcript clear.
	byteCount := 0.
	quitBlock := [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	prevCtxt := 0.  prevCtxt := prevCtxt.
	[byteCount < nBytes] whileTrue:
		[
"
byteCount > 14560 ifTrue:
[self externalizeIPandSP.
prevCtxt = activeContext ifFalse:
 [prevCtxt := activeContext.
 transcript cr; nextPutAll: (self printTop: 2); endEntry].
transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
 print: (instructionPointer - method - (BaseHeaderSize - 2));
 nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space;
 nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
 print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
byteCount = 14590 ifTrue: [self halt]].
"
		logging ifTrue: [rightByte := logFile next.
						currentBytecode = rightByte ifFalse: [self halt]].
		self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount := byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
	self inform: nBytes printString , ' bytecodes verfied.'! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:52'!
logOfBytesWrite: nBytes toFileNamed: fileName fromStart: loggingStart
	"Write a log file for testing a flaky interpreter on the same image"
	"self logOfBytesWrite: 10000 toFileNamed: 'clone32Bytecodes.log' "
	
	| logFile |
	logFile := (FileStream newFileNamed: fileName) binary.
	logging := loggingStart.
	transcript clear.
	byteCount := 0.
	quitBlock := [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	[logging not or: [byteCount < nBytes]] whileTrue:
		[logging ifTrue: [logFile nextPut: currentBytecode].
		self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount := byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:39'!
logOfSendsVerify: nSends fromFileNamed: fileName fromStart: loggingStart
	"Write a log file for testing a flaky interpreter on the same image"
	"self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' "
	
	| logFile priorContext rightSelector prevCtxt |
	logFile := FileStream readOnlyFileNamed: fileName.
	logging := loggingStart.
	transcript clear.
	byteCount := 0.
	sendCount := 0.
	priorContext := activeContext.
	quitBlock := [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	prevCtxt := 0.  prevCtxt := prevCtxt.
	[sendCount < nSends] whileTrue:
		[
"
byteCount>500 ifTrue:
[byteCount>550 ifTrue: [self halt].
self externalizeIPandSP.
prevCtxt = activeContext ifFalse:
 [prevCtxt := activeContext.
 transcript cr; nextPutAll: (self printTop: 2); endEntry].
transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
 print: (instructionPointer - method - (BaseHeaderSize - 2));
 nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space;
 nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
 print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
].
"
		self dispatchOn: currentBytecode in: BytecodeTable.
		activeContext == priorContext ifFalse:
			[sendCount := sendCount + 1.
			logging ifTrue: [rightSelector := logFile nextLine.
							(self stringOf: messageSelector) = rightSelector ifFalse: [self halt]].
			priorContext := activeContext].
		byteCount := byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
	self inform: nSends printString , ' sends verfied.'! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:53'!
logOfSendsWrite: nSends toFileNamed: fileName fromStart: loggingStart
	"Write a log file for testing a flaky interpreter on the same image"
	"self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' "
	
	| logFile priorContext |
	logFile := FileStream newFileNamed: fileName.
	logging := loggingStart.
	transcript clear.
	byteCount := 0.
	sendCount := 0.
	priorContext := activeContext.
	quitBlock := [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	[logging not or: [sendCount < nSends]] whileTrue:
		[self dispatchOn: currentBytecode in: BytecodeTable.
		activeContext == priorContext ifFalse:
			[logging ifTrue: [sendCount := sendCount + 1.
							logFile nextPutAll: (self stringOf: messageSelector); cr].
			priorContext := activeContext].
		byteCount := byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/3/2004 10:47'!
long32At: byteAddress
	"Return the 32-bit word at byteAddress which must be 0 mod 4."

	^ self longAt: byteAddress! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/3/2004 10:47'!
long32At: byteAddress put: a32BitValue
	"Store the 32-bit value at byteAddress which must be 0 mod 4."

	^ self longAt: byteAddress put: a32BitValue! !
!InterpreterSimulator methodsFor: 'memory access'!
longAt: byteAddress
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory at: (byteAddress // 4) + 1! !
!InterpreterSimulator methodsFor: 'memory access'!
longAt: byteAddress put: a32BitValue
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory at: (byteAddress // 4) + 1 put: a32BitValue! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:03'!
longAtPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and the result is the width of a machine word."

	^ self longAt: pointer! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:05'!
longAtPointer: pointer put: longValue
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and longValue is the width of a machine word."

	^ self longAt: pointer put: longValue! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'dtl 5/19/2010 18:54'!
longPrint: oop
	| lastPtr val lastLong hdrType prevVal |
	(self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
	^ String streamContents:
		[:strm |
		lastPtr := 64 * self bytesPerWord min: (self lastPointerOf: oop).
		hdrType := self headerType: oop.
		hdrType = 2 ifTrue: [lastPtr := 0].
		prevVal := 0.
		(self headerStart: oop) to: lastPtr by: self bytesPerWord do:
			[:a | val := self longAt: oop+a.
			(a > 0 and: [(val = prevVal) & (a ~= lastPtr)])
			ifTrue:
			[prevVal = (self longAt: oop + a - (self bytesPerWord * 2)) ifFalse: [strm cr; nextPutAll: '        ...etc...']]
			ifFalse:
			[strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
				space; space; space; nextPutAll: val hex8; space; space.
			a = (self bytesPerWord * 2) negated ifTrue:
				[strm nextPutAll: 'size = ' , (val - hdrType) hex].
			a = self bytesPerWord negated ifTrue:
				[strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>'].
			a = 0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)].
			a > 0 ifTrue: [strm nextPutAll: (self shortPrint: val)].
			a = self bytesPerWord ifTrue:
				[(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue:
							[strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]].
			prevVal := val].
		lastLong := 256 min: (self sizeBitsOf: oop) - self baseHeaderSize.
		hdrType = 2
			ifTrue:
			["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex;
			space; space; nextPutAll: (oop+(self longAt: oop)-2) printString]
			ifFalse:
			[(self formatOf: oop) = 3
			ifTrue:
				[strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'.
				lastPtr + self bytesPerWord to: lastPtr+(3 * self bytesPerWord) by: self bytesPerWord do:
					[:a | val := self longAt: oop+a.
					strm cr; nextPutAll: a hex; 
						space; space; space; nextPutAll: val hex8; space; space.
					(self validOop: val) ifTrue: [strm nextPutAll: (self shortPrint: val)]]]
			ifFalse:
			[lastPtr + self bytesPerWord to: lastLong by: self bytesPerWord do:
				[:a | val := self longAt: oop+a.
				strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
					space; space; space.
				strm nextPutAll: val hex8; space; space;
						nextPutAll: (self charsOfLong: val)]]].
	]! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/29/2004 14:27'!
lookupMethodInClass: class
	| currentClass dictionary found rclass |

	"This method overrides the interp, causing a halt on MNU."
	"true ifTrue: [^ super lookupMethodInClass: class]."    "Defeat debug support"

	currentClass := class.
	[currentClass ~= nilObj]
		whileTrue:
		[dictionary := self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
		dictionary = nilObj ifTrue:
			["MethodDict pointer is nil (hopefully due a swapped out stub)
				-- raise exception #cannotInterpret:."
			self pushRemappableOop: currentClass.  "may cause GC!!"
			self createActualMessageTo: class.
			currentClass := self popRemappableOop.
			messageSelector := self splObj: SelectorCannotInterpret.
			^ self lookupMethodInClass: (self superclassOf: currentClass)].

		found := self lookupMethodInDictionary: dictionary.
		found ifTrue: [^ methodClass := currentClass].
		currentClass := self superclassOf: currentClass].

	"Could not find #doesNotUnderstand: -- unrecoverable error."
	messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue:
		[self error: 'Recursive not understood error encountered'].

self halt: (self stringOf: messageSelector).

	"Cound not find a normal message -- raise exception #doesNotUnderstand:"
	self pushRemappableOop: class.  "may cause GC!!"
	self createActualMessageTo: class.
	rclass := self popRemappableOop.
	messageSelector := self splObj: SelectorDoesNotUnderstand.
	^ self lookupMethodInClass: rclass! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'tpr 12/29/2005 16:35'!
makeDirEntryName: entryName size: entryNameSize
	createDate: createDate modDate: modifiedDate
	isDir: dirFlag fileSize: fileSize

	| modDateOop createDateOop nameString results |
	self var: 'entryName' type: 'char *'.

	"allocate storage for results, remapping newly allocated
	 oops in case GC happens during allocation"
	self pushRemappableOop:
		(self instantiateClass: (self splObj: ClassArray) indexableSize: 5).
	self pushRemappableOop:
		(self instantiateClass: (self splObj: ClassString) indexableSize: entryNameSize)..
	self pushRemappableOop: (self positive32BitIntegerFor: createDate).
	self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).

	modDateOop   := self popRemappableOop.
	createDateOop := self popRemappableOop.
	nameString    := self popRemappableOop.
	results         := self popRemappableOop.

	1 to: entryNameSize do: [ :i |
		self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
	].

	self storePointer: 0 ofObject: results withValue: nameString.
	self storePointer: 1 ofObject: results withValue: createDateOop.
	self storePointer: 2 ofObject: results withValue: modDateOop.
	dirFlag
		ifTrue: [ self storePointer: 3 ofObject: results withValue: trueObj ]
		ifFalse: [ self storePointer: 3 ofObject: results withValue: falseObj ].
	self storePointer: 4 ofObject: results
		withValue: (self integerObjectOf: fileSize).
	^ results
! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'dtl 5/19/2010 18:49'!
nameOfClass: classOop
	(self sizeBitsOf: classOop) = (Metaclass instSize + 1 * self bytesPerWord) ifTrue:
		[^ (self nameOfClass:
				(self fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class'].
	^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'th 4/15/2000 17:19'!
nextLongFrom: aStream
	"Read a 32-bit quantity from the given (binary) stream."
	^self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 9/23/97 15:51'!
nextLongFrom: aStream swap: swapFlag
	swapFlag 
		ifTrue: [^ self byteSwapped: (self nextLongFrom: aStream)]
		ifFalse: [^ self nextLongFrom: aStream]! !
!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/22/2004 18:36'!
normalSend
	"Catch errors before we start the whole morphic error process"

	"(byteCount > 4000000 and: [(self stringOf: messageSelector) = 'sorts:before:'])
		ifTrue: [self halt]."
	^ super normalSend! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 10/1/97 23:36'!
objectBefore: addr
	| oop prev |
	oop := self firstObject.
	[oop < endOfMemory] whileTrue: [
		prev := oop.  "look here if debugging prev obj overlapping this one"
		oop := self objectAfter: oop.
		oop >= addr ifTrue: [^ prev]
	]! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:07'!
oopForPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	oop is the width of a machine word, and pointer is a raw address."

	^ pointer! !
!InterpreterSimulator methodsFor: 'UI' stamp: 'di 4/21/2004 00:31'!
openAsMorph
	"Open a morphic view on this simulation."
	| window localImageName |
	localImageName := FileDirectory default localNameFor: imageName.
	window := (SystemWindow labelled: 'Simulation of ' , localImageName) model: self.

	window addMorph: (displayView := ImageMorph new image: displayForm)
		frame: (0@0 corner: 1@0.8).

	transcript := TranscriptStream on: (String new: 10000).
	window addMorph: (PluggableTextMorph on: transcript text: nil accept: nil
			readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0@0.8 corner: 0.7@1).

	window addMorph: (PluggableTextMorph on: self
						text: #byteCountText accept: nil) hideScrollBarIndefinitely
		frame: (0.7@0.8 corner: 1@1).

	window openInWorld! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 7/1/2004 14:15'!
openOn: fileName
	"(InterpreterSimulator new openOn: 'clonex.image') test"

	self openOn: fileName extraMemory: 2500000.! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'dtl 10/5/2010 22:53'!
openOn: fileName extraMemory: extraBytes
	"InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"

	| f version headerSize count oldBaseAddr bytesToShift swapBytes hasPlatformFloatOrdering versionToRun |
	"open image file and read the header"

	["begin ensure block..."
	f := FileStream readOnlyFileNamed: fileName.
	imageName := f fullName.
	f binary.
	version := self nextLongFrom: f.  "current version: 16r1966 (=6502)"
	versionToRun := version bitAnd: -2. "permit loading images with platform float ordering"
	hasPlatformFloatOrdering := version ~= (version bitAnd: -2). "is low order bit set?"
	(self readableFormat: versionToRun) "permit loading images with platform float ordering"
		ifTrue: [swapBytes := false]
		ifFalse: [(versionToRun := self byteSwapped: version) = self imageFormatVersion
					ifTrue: [swapBytes := true]
					ifFalse: [self error: 'incompatible image format']].
	headerSize := self nextLongFrom: f swap: swapBytes.
	endOfMemory := self nextLongFrom: f swap: swapBytes.  "first unused location in heap"
	oldBaseAddr := self nextLongFrom: f swap: swapBytes.  "object memory base address of image"
	specialObjectsOop := self nextLongFrom: f swap: swapBytes.
	lastHash := self nextLongFrom: f swap: swapBytes.  "Should be loaded from, and saved to the image header"
	lastHash = 0 ifTrue: [lastHash := 999].

	savedWindowSize	:= self nextLongFrom: f swap: swapBytes.
	fullScreenFlag		:= self oldFormatFullScreenFlag: (self nextLongFrom: f swap: swapBytes).
	extraVMMemory		:= self nextLongFrom: f swap: swapBytes.

	"allocate interpreter memory"
	memoryLimit := endOfMemory + extraBytes.

	"read in the image in bulk, then swap the bytes if necessary"
	f position: headerSize.
	memory := Bitmap new: memoryLimit // 4.
	count := f readInto: memory startingAt: 1 count: endOfMemory // 4.
	count ~= (endOfMemory // 4) ifTrue: [self halt].
	]
		ensure: [f close].

	swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...'
								during: [self reverseBytesInImage]].
	self initialize.
	bytesToShift := 0 - oldBaseAddr.  "adjust pointers for zero base address"
	endOfMemory := endOfMemory.
	Utilities informUser: 'Relocating object pointers...'
				during: [self initializeInterpreter: bytesToShift].
	hasPlatformFloatOrdering ifTrue: [Utilities informUser: 'Swapping words in float objects...'
								during: [self normalizeFloatOrderingInImage]].
! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:07'!
pointerForOop: oop
	"This gets implemented by Macros in C, where its types will also be checked.
	oop is the width of a machine word, and pointer is a raw address."

	^ oop! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 6/29/1998 22:17'!
primBitmapcompresstoByteArray
	^ self primitiveFail! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 7/4/2004 09:01'!
primBitmapdecompressfromByteArrayat
	| indexInt index baOop bmOop baSize bmSize ba bm |
	indexInt := self stackTop.
	(self isIntegerValue: indexInt) ifFalse: [^ self primitiveFail].
	index := self integerValueOf: indexInt.
	baOop := self stackValue: 1.
	bmOop := self stackValue: 2.
	baSize := self stSizeOf: baOop.
	bmSize := self stSizeOf: bmOop.
	ba := ByteArray new: baSize.
	bm := Bitmap new: bmSize.

	"Copy the byteArray into ba"
	1 to: baSize do: [:i | ba at: i put: (self fetchByte: i-1 ofObject: baOop)].

	"Decompress ba into bm"
	bm decompress: bm fromByteArray: ba at: index.

	"Then copy bm into the Bitmap"
	1 to: bmSize do: [:i | self storeLong32: i-1 ofObject: bmOop withValue: (bm at: i)].
	self pop: 3! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 6/29/1998 22:17'!
primStringcomparewithcollated
	^ self primitiveFail! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'ikp 12/15/1998 23:30'!
primStringfindSubstringinstartingAtmatchTable
	^self primitiveFail! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 11/8/1998 13:04'!
primStringindexOfAsciiinStringstartingAt
	^ self primitiveFail! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'yo 1/29/1999 21:37'!
primStringtranslatefromtotable
	^ self primitiveFail! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 4/20/2004 23:59'!
primitiveBeDisplay
	"Extended to create a scratch Form for use by showDisplayBits."

	| rcvr destWidth destHeight destDepth |
	rcvr := self stackTop.
	self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
	successFlag ifTrue: [
		destWidth := self fetchInteger: 1 ofObject: rcvr.
		destHeight := self fetchInteger: 2 ofObject: rcvr.
		destDepth := self fetchInteger: 3 ofObject: rcvr.
	].
	successFlag ifTrue: [
		"create a scratch form the same size as Smalltalk displayObj"
		displayForm := Form extent: destWidth @ destHeight
							depth: destDepth.
		displayView ifNotNil: [displayView image: displayForm].
	].
	super primitiveBeDisplay.! !
!InterpreterSimulator methodsFor: 'other primitives'!
primitiveBeep

	Beeper beep.! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'di 7/2/2004 12:35'!
primitiveDirectoryLookup
	| index pathName array result |
	index := self stackIntegerValue: 0.
	pathName := (self stringOf: (self stackValue: 1)).
	
	successFlag ifFalse: [
		^self primitiveFail.
	].

	array := FileDirectory default primLookupEntryIn: pathName index: index.

	array == nil ifTrue: [
		self pop: 3.
		self push: nilObj.
		^array.
	].
	array == #badDirectoryPath ifTrue: [self halt.
		^self primitiveFail.
	].

	result := self makeDirEntryName: (array at: 1) size: (array at: 1) size
				createDate: (array at: 2) modDate: (array at: 3)
				isDir: (array at: 4)  fileSize: (array at: 5).
	self pop: 3.
	self push: result.
! !
!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/20/2004 10:57'!
primitiveFail

"(primitiveIndex = 61 and: [byteCount > 210000]) ifTrue: [self halt]."
	successFlag := false.! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'di 1/12/1999 15:38'!
primitiveFileDelete 

	| namePointer |
	namePointer := self stackTop.
	self success: (self isBytes: namePointer).
	self success: (StandardFileStream isAFileNamed: (self stringOf: namePointer)).
	successFlag ifTrue: [FileDirectory deleteFilePath: (self stringOf: namePointer)].
	successFlag ifTrue: [self pop: 1].  "pop fileName; leave rcvr on stack"
! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'tpr 5/13/2005 10:21'!
primitiveFileOpen
	| namePointer writeFlag fileName f |
	writeFlag := self booleanValueOf: self stackTop.
	namePointer := self stackValue: 1.
	self success: (self isBytes: namePointer).
	successFlag ifTrue:
		[fileName := self stringOf: namePointer.
		filesOpen addLast: (writeFlag
			ifTrue: [f := FileStream fileNamed: fileName.
					f ifNil: [^ self primitiveFail] ifNotNil: [f binary]]
			ifFalse: [(StandardFileStream isAFileNamed: fileName)
				ifTrue: [f := (FileStream readOnlyFileNamed: fileName).
						f ifNil:[^self primitiveFail] ifNotNil:[f binary]]
				ifFalse: [^ self primitiveFail]]).
		self pop: 3 thenPushInteger: filesOpen size]! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'jm 12/5/97 15:10'!
primitiveFileRename

	| oldNamePointer newNamePointer f |
	oldNamePointer := self stackTop.
	newNamePointer := self stackValue: 1.
	self success: (self isBytes: oldNamePointer).
	self success: (self isBytes: newNamePointer).
	self success: (StandardFileStream isAFileNamed: (self stringOf: oldNamePointer)).
	self success: (StandardFileStream isAFileNamed: (self stringOf: newNamePointer)) not.
	successFlag ifTrue: [
		f := FileStream oldFileNamed: (self stringOf: oldNamePointer).
		f rename: (self stringOf: newNamePointer).
		f close.
	].
	successFlag ifTrue: [
		self pop: 2.  "oldName, newName; leave rcvr on stack"
	].! !
!InterpreterSimulator methodsFor: 'other primitives' stamp: 'nk 4/3/2004 09:12'!
primitiveGetAttribute
	"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."

	| attr s attribute |
	attr := self stackIntegerValue: 0.
	successFlag ifTrue: [
		attribute := Smalltalk getSystemAttribute: attr.
		attribute ifNil: [ ^self primitiveFail ].
		s := self instantiateClass: (self splObj: ClassString) indexableSize: attribute size.
		1 to: attribute size do: [ :i |
			self storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
		self pop: 2.  "rcvr, attr"
		self push: s].
! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'di 7/2/2004 14:20'!
primitiveImageName
	"Note: For now, this only implements getting, not setting, the image file name."
	| result imageNameSize |
	self pop: 1.
	imageNameSize := imageName size.
	result := self instantiateClass: (self splObj: ClassString)
				   indexableSize: imageNameSize.
	1 to: imageNameSize do:
		[:i | self storeByte: i-1 ofObject: result
			withValue: (imageName at: i) asciiValue].
	self push: result.! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!
primitiveKbdNext

	self pop: 1.
	Sensor keyboardPressed
		ifTrue: [self pushInteger: Sensor primKbdNext]
		ifFalse: [self push: nilObj]! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!
primitiveKbdPeek

	self pop: 1.
	Sensor keyboardPressed
		ifTrue: [self pushInteger: Sensor primKbdPeek]
		ifFalse: [self push: nilObj]! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!
primitiveMouseButtons
	| buttons |
	self pop: 1.
	buttons := Sensor primMouseButtons.
	self pushInteger: buttons! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 4/21/2004 00:21'!
primitiveMousePoint

	| relPt |
	self pop: 1.
	displayForm == nil
		ifTrue: [self push: (self makePointwithxValue: 99 yValue: 66)]
		ifFalse: [relPt := Sensor cursorPoint - self displayLocation.
				self push: (self makePointwithxValue: relPt x yValue: relPt y)]! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 12/1/1998 00:05'!
primitiveRelinquishProcessor
	"No-op in simulator"

	^ self pop: 1! !
!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/22/2004 12:31'!
primitiveResume
	"Catch errors before we start the whole morphic error process"

	byteCount > 1000000 ifTrue: [self halt].  "Ignore early process activity"
	^ super primitiveResume! !
!InterpreterSimulator methodsFor: 'I/O primitives'!
primitiveScreenSize  "Dummied for now"

	self pop: 1.
	self push: (self makePointwithxValue: 640 yValue: 480).! !
!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/22/2004 12:31'!
primitiveSuspend
	"Catch errors before we start the whole morphic error process"

	byteCount > 1000000 ifTrue: [self halt].  "Ignore early process activity"
	^ super primitiveSuspend! !
!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:28'!
print: s

	traceOn ifTrue: [ transcript show: s ]! !
!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:28'!
printChar: aByte

	traceOn ifTrue: [ transcript nextPut: aByte asCharacter ].! !
!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:28'!
printNum: anInteger

	traceOn ifTrue: [ transcript show: anInteger printString ].! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:48'!
printStack
	^ self printStack: false! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:49'!
printStack: includeTemps
	| ctxt |
	ctxt := activeContext.
	^ String streamContents:
		[:strm |
		[self printStackFrame: ctxt onStream: strm.
		includeTemps ifTrue: [self printStackTemps: ctxt onStream: strm].
		(ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]
				whileFalse: [].
		]! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:49'!
printStackFrame: ctxt onStream: strm
	| classAndSel home |
	home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
		ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
		ifFalse: [ctxt].
	classAndSel := self
		classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
		forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
	strm cr; nextPutAll: ctxt hex8.
	ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
	strm space; nextPutAll: (self nameOfClass: classAndSel first).
	strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'dtl 5/19/2010 18:49'!
printStackTemps: ctxt onStream: strm
	| home cMethod nArgs nTemps oop |
	home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
		ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
		ifFalse: [ctxt].
	cMethod := self fetchPointer: MethodIndex ofObject: home.
	nArgs := nTemps := 0.

	home = ctxt ifTrue:
		[strm cr; tab; nextPutAll: 'args: '.
		nArgs := self argumentCountOf: cMethod.
		1 to: nArgs do:
			[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
			strm nextPutAll: oop hex; space].

		strm cr; tab; nextPutAll: 'temps: '.
		nTemps := self tempCountOf: cMethod.
		nArgs+1 to: nTemps do:
			[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
			strm nextPutAll: oop hex; space]].
	
	strm cr; tab; nextPutAll: 'stack: '.
	nTemps + 1 to: (self lastPointerOf: ctxt)//self bytesPerWord - TempFrameStart do:
		[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
			strm nextPutAll: oop hex; space].
	! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 15:28'!
printStackWithTemps
	^ self printStack: true! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'dtl 5/19/2010 18:38'!
printTop: n
	"Print important fields of the top n contexts"
	| ctxt classAndSel home top ip sp |
	ctxt := activeContext.
	^ String streamContents:
		[:strm | 1 to: n do:
			[:i |
			home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
				ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
				ifFalse: [ctxt].
			classAndSel := self
				classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
				forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
			strm cr; nextPutAll: ctxt hex8.
			ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
			strm space; nextPutAll: (self nameOfClass: classAndSel first).
			strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
			ctxt = activeContext
				ifTrue: [ip := instructionPointer - method - (self baseHeaderSize - 2).
						sp := self stackPointerIndex - TempFrameStart + 1.
						top := self stackTop]
				ifFalse: [ip := self integerValueOf:
							(self fetchPointer: InstructionPointerIndex ofObject: ctxt).
						sp := self integerValueOf:
							(self fetchPointer: StackPointerIndex ofObject: ctxt).
						top := self longAt: ctxt + (self lastPointerOf: ctxt)].
			strm cr; tab; nextPutAll: 'ip = '; print: ip.
			strm cr; tab; nextPutAll: 'sp = '; print: sp.
			strm cr; tab; nextPutAll: 'top = '; nextPutAll: (self shortPrint: top).
			(ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj
				ifTrue: [^strm contents].
			].
		]! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 5/11/2004 18:28'!
profile: nBytecodes
	"(InterpreterSimulator new openOn: 'clonex.image') profile: 60000"
	transcript clear.
	byteCount := 0.
	MessageTally spyOn: [self runForNBytes: nBytecodes].
	self close! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 11/29/2000 10:25'!
profileSends: nBytecodes
	"(InterpreterSimulator new openOn: 'clonex.image') profileSends: 5000"
	MessageTally tallySendsTo: self
		inBlock: [self runForNBytes: nBytecodes]
		showTree: true.
	self close! !
!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/12/1998 08:32'!
pushLiteralConstantBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushLiteralConstant: (currentBytecode bitAnd: 16r1F).
	self fetchNextBytecode.
! !
!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:32'!
pushLiteralVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushLiteralVariable: (currentBytecode bitAnd: 16r1F).
	self fetchNextBytecode.
! !
!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:34'!
pushReceiverVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushReceiverVariable: (currentBytecode bitAnd: 16rF).
	self fetchNextBytecode.
! !
!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:35'!
pushTemporaryVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
	self fetchNextBytecode.
! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 10/2/97 00:32'!
reverseBytesFrom: begin to: end
	"Byte-swap the given range of memory (not inclusive!!)."
	| wordAddr |
	wordAddr := begin.
	memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'nk 4/3/2004 11:56'!
runForNBytes: nBytecodes 
	"Do nByteCodes more bytecode dispatches.
	Keep byteCount up to date.
	This can be run repeatedly."
	| endCount |
	endCount := byteCount + nBytecodes.
	self internalizeIPandSP.
	self fetchNextBytecode.
	[byteCount < endCount]
		whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable.
			byteCount := byteCount + 1].
	localIP := localIP - 1.
	"undo the pre-increment of IP before returning"
	self externalizeIPandSP! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:29'!
shortAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	^self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:32'!
shortAt: byteAddress put: a16BitValue
	^ self subclassResponsibility! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'dtl 5/19/2010 18:49'!
shortPrint: oop
	| name classOop |
	(self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString , 
		' (' , (self integerValueOf: oop) hex , ')'].
	classOop := self fetchClassOf: oop.
	(self sizeBitsOf: classOop) = (Metaclass instSize + 1 * self bytesPerWord) ifTrue: [
		^ 'class ' , (self nameOfClass: oop)].
	name := self nameOfClass: classOop.
	name size = 0 ifTrue: [name := '??'].
	name = 'String' ifTrue: [^ (self stringOf: oop) printString].
	name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
	name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf: 
				(self fetchPointer: 0 ofObject: oop))) printString].
	name = 'UndefinedObject' ifTrue: [^ 'nil'].
	name = 'False' ifTrue: [^ 'false'].
	name = 'True' ifTrue: [^ 'true'].
	name = 'Float' ifTrue: [successFlag := true. ^ '=' , (self floatValueOf: oop) printString].
	name = 'Association' ifTrue: [^ '(' ,
				(self shortPrint: (self longAt: oop + self baseHeaderSize)) ,
				' -> ' ,
				(self longAt: oop + self baseHeaderSize + self bytesPerWord) hex8 , ')'].
	('AEIOU' includes: name first)
		ifTrue: [^ 'an ' , name]
		ifFalse: [^ 'a ' , name]! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 7/6/2004 10:48'!
showDisplayBits: destBits w: w h: h d: d left: left right: right top: top bottom: bottom
	| raster pixPerWord simDisp realDisp rect |
	pixPerWord := 32 // d.
	raster := displayForm width + (pixPerWord - 1) // pixPerWord.
	simDisp := Form new hackBits: memory.
	displayForm unhibernate.
	realDisp := Form new hackBits: displayForm bits.
	realDisp
		copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster))
		from: 0 @ (destBits // 4 + (top * raster))
		in: simDisp
		rule: Form over.
	displayView ifNotNil: [^ displayView changed].
	
	"If running without a view, just blat the bits onto the screen..."
	rect := 0 @ top corner: displayForm width @ bottom.
	Display
		copy: (rect translateBy: self displayLocation)
		from: rect topLeft
		in: displayForm
		rule: Form over! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'dtl 5/19/2010 16:08'!
signalSemaphoreWithIndex: index
	"Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."

	^ index ifNotNil: [super signalSemaphoreWithIndex: index]! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 8/3/2004 14:50'!
sizeof: var

	self flag: #Dan.
	^ 4! !
!InterpreterSimulator methodsFor: 'file primitives'!
sqFile: file Read: count Into: byteArrayIndex At: startIndex

	startIndex to: (startIndex + count - 1) do: [ :i |
		file atEnd ifTrue: [ ^ i - startIndex ].
		self byteAt: byteArrayIndex + i put: file next.
	].
	^ count! !
!InterpreterSimulator methodsFor: 'file primitives'!
sqFile: file SetPosition: newPosition

	file position: newPosition.! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'JMM 5/24/2001 21:59'!
sqFile: file Truncate: truncatePosition

	file truncate: truncatePosition.! !
!InterpreterSimulator methodsFor: 'file primitives'!
sqFile: file Write: count From: byteArrayIndex At: startIndex

	startIndex to: (startIndex + count - 1) do: [ :i |
		file nextPut: (self byteAt: byteArrayIndex + i).
	].
	^ count! !
!InterpreterSimulator methodsFor: 'file primitives'!
sqFileAtEnd: file

	^ file atEnd! !
!InterpreterSimulator methodsFor: 'file primitives'!
sqFileClose: file

	file close.! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'ar 2/6/2001 17:54'!
sqFileFlush: file

	^ file flush! !
!InterpreterSimulator methodsFor: 'file primitives'!
sqFileGetPosition: file

	^ file position! !
!InterpreterSimulator methodsFor: 'file primitives'!
sqFileSize: file

	^ file size! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/11/2000 21:47'!
sqGetInterpreterProxy
	"I am basically my own proxy..."
	^self! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 5/11/2004 18:29'!
sqGrowMemory: oldLimit By: delta

	transcript show: 'grow memory from ', oldLimit printString, ' by ', delta printString; cr.
	memory := memory , (memory class new: delta // 4).
	^ memory size * 4! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'ar 2/25/2001 17:16'!
sqMemoryExtraBytesLeft: includingSwap
	^0! !
!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 5/11/2004 18:29'!
sqShrinkMemory: oldLimit By: delta
	transcript show: 'shrink memory from ', oldLimit printString, ' by ', delta printString, ' remember it doesn''t actually shrink in simulation'; cr.

	^ oldLimit! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/22/1998 23:24'!
stackDepth
	| ctxt n |
	ctxt := activeContext.
	n := 0.
	[(ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]
		whileFalse: [n := n+1].
	^ n! !
!InterpreterSimulator methodsFor: 'initialization'!
startOfMemory
	"Return the start of object memory."

	^ 0! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'dtl 5/19/2010 18:49'!
stats
	| oop fieldAddr fieldOop last stats v d |
	stats := Bag new.
	oop := self firstObject.

'Scanning the image...' displayProgressAt: Sensor cursorPoint
	from: oop to: endOfMemory
	during: [:bar |

	[oop < endOfMemory] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[stats add: #objects.
			fieldAddr := oop + (self lastPointerOf: oop).
			[fieldAddr > oop] whileTrue:
				[fieldOop := self longAt: fieldAddr.
				(self isIntegerObject: fieldOop)
					ifTrue: [v := self integerValueOf: fieldOop.
							(v between: -16000 and: 16000)
								ifTrue: [stats add: #ints32k]
								ifFalse: [stats add: #intsOther]]
					ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil]
							ifFalse:
							[d := fieldOop - oop.
							(d between: -16000 and: 16000)
								ifTrue: [stats add: #oops32k]
								ifFalse: [stats add: #oopsOther]]].
				fieldAddr := fieldAddr - self bytesPerWord]].
		bar value: oop.
		last := oop.
		last := last.
		oop := self objectAfter: oop]].
	^ stats sortedElements! !
!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/12/1998 08:30'!
storeAndPopReceiverVariableBytecode
	"Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code."

	"Interpreter version has fetchNextBytecode out of order"
	| rcvr top |
	rcvr := receiver.
	top := self internalStackTop.
	(rcvr < youngStart) ifTrue: [
		self possibleRootStoreInto: rcvr value: top.
	].
	self storePointerUnchecked: (currentBytecode bitAnd: 7)
		ofObject: rcvr
		withValue: top.
	self internalPop: 1.
	self fetchNextBytecode.
! !
!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:32'!
storeAndPopTemporaryVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
		ofObject: localHomeContext
		withValue: self internalStackTop.
	self internalPop: 1.
	self fetchNextBytecode.
! !
!InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 6/13/2004 10:45'!
storeFloatAt: floatBitsAddress from: aFloat.

	self long32At: floatBitsAddress put: (aFloat at: 1).
	self long32At: floatBitsAddress+4 put: (aFloat at: 2).
! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'dtl 5/19/2010 18:50'!
stringOf: oop
	| size long nLongs chars |
	^ String streamContents:
		[:strm |
		size := 100 min: (self stSizeOf: oop).
		nLongs := size - 1 // self bytesPerWord + 1.
		1 to: nLongs do:
			[:i | long := self longAt: oop + self baseHeaderSize + (i - 1 * self bytesPerWord).
			chars := self charsOfLong: long.
			strm nextPutAll: (i=nLongs
							ifTrue: [chars copyFrom: 1 to: size - 1 \\ self bytesPerWord + 1]
							ifFalse: [chars])]]! !
!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 6/15/2004 09:53'!
symbolic: byte at: ip inMethod: meth
	"Print a bytecode in simple symbolic form"

	| type offset |
	type := byte // 16.  
	offset := byte \\ 16.  
	type=0 ifTrue: [^ 'pushRcvr ' , offset printString].
	type=1 ifTrue: [^ 'pushTemp ' , offset printString].
	type=2 ifTrue: [^ 'pushLit ' , offset printString].
	type=3 ifTrue: [^ 'pushLit ' , (offset+16) printString].
	type=4 ifTrue: [^ 'pushLitVar ' , offset printString].
	type=5 ifTrue: [^ 'pushLitVar ' , (offset+16) printString].
	type=6 ifTrue: [offset<8
					ifTrue: [^ 'storePopRcvr ' , offset printString]
					ifFalse: [^ 'storePopTemp ' , (offset-8) printString]].
	type=7 ifTrue: [offset=0 ifTrue: [^ 'pushRcvr'].
				offset<8 ifTrue: [^ 'pushConst ' , ( #(true false nil -1 0 1 2) at: offset) printString].
				offset=8 ifTrue: [^ 'returnSelf'].
				offset<12 ifTrue: [^ 'returnConst ' , ( #(true false nil -1 0 1 2) at: offset-8) printString].
				offset=12 ifTrue: [^ 'returnTop'].
				offset=13 ifTrue: [^ 'blockReturnTop'].
				offset>13 ifTrue: [^ 'unusedBytecode']].
	type=8 ifTrue: [^ self symbolicExtensions: offset at: ip inMethod: meth].
	type=9 ifTrue:  "short jumps"
			[offset<8 ifTrue: [^ 'jump ' , (offset+1) printString].
			^ 'jumpIfFalse ' , (offset-8+1) printString].
	type=10 ifTrue:  "long jumps"
			[offset<8 ifTrue: [^ 'extendedJump'].
			offset<12 ifTrue: [^ 'extendedJumpIfTrue'].
			true ifTrue: [^ 'extendedJumpIfFalse']].
	type=11 ifTrue: [^ 'sendSpl ' , (Smalltalk specialSelectorAt: offset+1)].
	type=12 ifTrue: [^ 'sendSpl ' , (Smalltalk specialSelectorAt: offset+17)].
	type>12 ifTrue: [^ 'send ' , (self stringOf: (self literal: offset))]! !
!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 6/15/2004 10:11'!
symbolicExtensions: offset at: ip inMethod: meth
	| type offset2 byte2 byte3 |
	offset <=6 ifTrue: 
		["Extended op codes 128-134"
		byte2 := self byteAt: ip+1.
		offset <= 2 ifTrue:
			["128-130:  extended pushes and pops"
			type := byte2 // 64.
			offset2 := byte2 \\ 64.
			offset = 0 ifTrue: 
				[type = 0 ifTrue: [^ 'pushRcvr ' , offset2 printString].
				type = 1 ifTrue: [^ 'pushTemp ' , offset2 printString].
				type = 2  ifTrue: [^ 'pushLit ' , (offset2 + 1) printString].
				type = 3 ifTrue: [^ 'pushLitVar ' , (offset2 + 1) printString]].
			offset = 1 ifTrue: 
				[type = 0 ifTrue: [^ 'storeIntoRcvr ' , offset2 printString].
				type = 1 ifTrue: [^ 'storeIntoTemp ' , offset2 printString].
				type = 2 ifTrue: [^ 'illegalStore'].
				type = 3 ifTrue: [^ 'storeIntoLitVar ' , (offset2 + 1) printString]].
			offset = 2 ifTrue: 
				[type = 0 ifTrue: [^ 'storePopRcvr ' , offset2 printString].
				type = 1 ifTrue: [^ 'storePopTemp ' , offset2 printString].
				type = 2 ifTrue: [^ 'illegalStore'].
				type = 3  ifTrue: [^ 'storePopLitVar ' , (offset2 + 1) printString]]].
		"131-134: extended sends"
		offset = 3 ifTrue:  "Single extended send"
			[^ 'send ' , (self stringOf: (self literal: byte2 \\ 32))].
		offset = 4 ifTrue:    "Double extended do-anything"
			[byte3 := self byteAt: ip+2.
			type := byte2 // 32.
			type = 0 ifTrue: [^ 'send ' , (self stringOf: (self literal: byte3))].
			type = 1 ifTrue: [^ 'superSend ' , (self stringOf: (self literal: byte3))].
			type = 2 ifTrue: [^ 'pushRcvr ' , byte3 printString].
			type = 3 ifTrue: [^ 'pushLit ' , byte3 printString].
			type = 4 ifTrue: [^ 'pushLitVar ' , byte3 printString].
			type = 5 ifTrue: [^ 'storeIntoRcvr ' , byte3 printString].
			type = 6 ifTrue: [^ 'storePopRcvr ' , byte3 printString].
			type = 7 ifTrue: [^ 'storeIntoLitVar ' , byte3 printString]].
		offset = 5 ifTrue:  "Single extended send to super"
			[^ 'superSend ' , (self stringOf: (self literal: byte2 \\ 32))].
		offset = 6 ifTrue:   "Second extended send"
			[^ 'send ' , (self stringOf: (self literal: byte2 \\ 64))]].
	offset = 7 ifTrue: [^ 'doPop'].
	offset = 8 ifTrue: [^ 'doDup'].
	offset = 9 ifTrue: [^ 'pushActiveContext'].
	^ 'unusedBytecode'! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/19/2004 17:30'!
test
	transcript clear.
	byteCount := 0.
	quitBlock := [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	[true] whileTrue:
		[self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount := byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplay]].
	self externalizeIPandSP.
! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'brp 9/19/2003 16:09'!
testBecome
	"Become some young things.  AA testBecome    "
	| array list1 list2 p1 p2 p3 p4 |
	array := self splObj: ClassArray.
	list1 := self instantiateClass: array indexableSize: 2.
	list2 := self instantiateClass: array indexableSize: 2.
	p1 := self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.
	self push: p1.
	self storePointer: 0 ofObject: list1 withValue: p1.
	p2 := self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.
	self push: p2.
	self storePointer: 1 ofObject: list1 withValue: p2.
	p3 := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
	self push: p3.
	self storePointer: 0 ofObject: list2 withValue: p3.
	p4 := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
	self push: p4.
	self storePointer: 1 ofObject: list2 withValue: p4.
	(self become: list1 with: list2 twoWay: true copyHash: true) ifFalse: [self error: 'failed'].
	self popStack = p2 ifFalse: [self halt].
	self popStack = p1 ifFalse: [self halt].
	self popStack = p4 ifFalse: [self halt].
	self popStack = p3 ifFalse: [self halt].
	(self fetchPointer: 0 ofObject: list1) = p3 ifFalse: [self halt].
	(self fetchPointer: 1 ofObject: list1) = p4 ifFalse: [self halt].
	(self fetchPointer: 0 ofObject: list2) = p1 ifFalse: [self halt].
	(self fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt].! !
!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 2/26/2003 14:00'!
unableToReadImageError
	self error:  'Read failed or premature end of image file'! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 4/3/1999 15:45'!
validOop: oop
	" Return true if oop appears to be valid "
	(oop bitAnd: 1) = 1 ifTrue: [^ true].  "Integer"
	(oop bitAnd: 3) = 0 ifFalse: [^ false].  "Uneven address"
	oop >= endOfMemory ifTrue: [^ false].  "Out of range"
	"could test if within the first large freeblock"
	(self longAt: oop) = 4 ifTrue: [^ false].
	(self headerType: oop) = 2 ifTrue: [^ false].	"Free object"
	^ true! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'di 5/11/2004 18:30'!
validate
	| oop prev |
	transcript show: 'Validating...'.
	oop := self firstObject.
	[oop < endOfMemory] whileTrue: [
		self validate: oop.
		prev := oop.  "look here if debugging prev obj overlapping this one"
		oop := self objectAfter: oop.
	].
	prev := prev.  "Don't offer to delete this please"
	transcript show: 'done.'; cr! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'dtl 5/19/2010 18:50'!
validate: oop
	| header type cc sz fmt nextChunk | 
	header := self longAt: oop.
	type := header bitAnd: 3.
	type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
	sz := (header bitAnd: self sizeMask) >> 2.
	(self isFreeObject: oop)
		ifTrue: [ nextChunk := oop + (self sizeOfFree: oop) ]
		ifFalse: [  nextChunk := oop + (self sizeBitsOf: oop) ].
	nextChunk > endOfMemory
		ifTrue: [oop = endOfMemory ifFalse: [self halt]].
	(self headerType: nextChunk) = 0 ifTrue: [
		(self headerType: (nextChunk + (self bytesPerWord * 2))) = 0 ifFalse: [self halt]].
	(self headerType: nextChunk) = 1 ifTrue: [
		(self headerType: (nextChunk + self bytesPerWord)) = 1 ifFalse: [self halt]].
	type = 2 ifTrue:
		["free block" ^ self].
	fmt := (header >> 8) bitAnd: 16rF.
	cc := (header >> 12) bitAnd: 31.
	cc > 16 ifTrue: [self halt].	"up to 32 are legal, but not used"
	type = 0 ifTrue:
		["three-word header"
		((self longAt: oop - self bytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
		((self longAt: oop-(self bytesPerWord * 2)) bitAnd: 3) = type ifFalse: [self halt].
		((self longAt: oop - self bytesPerWord) = type) ifTrue: [self halt].	"Class word is 0"
		sz = 0 ifFalse: [self halt]].
	type = 1 ifTrue:
		["two-word header"
		((self longAt: oop - self bytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
		cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
		sz = 0 ifTrue: [self halt]].
	type = 3 ifTrue:
		["one-word header"
		cc = 0 ifTrue: [self halt]].
	fmt = 5 ifTrue: [self halt].
	fmt = 7 ifTrue: [self halt].
	fmt >= 12 ifTrue:
		["CompiledMethod -- check for integer header"
		(self isIntegerObject: (self longAt: oop + self bytesPerWord)) ifFalse: [self halt]].! !
!InterpreterSimulator methodsFor: 'testing'!
validateActiveContext
	self validateOopsIn: activeContext.	"debug -- test if messed up"! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'dtl 5/19/2010 18:50'!
validateOopsIn: object
	| fieldPtr limit former header | 
	"for each oop in me see if it is legal"
	fieldPtr := object + self baseHeaderSize.	"first field"
	limit := object + (self lastPointerOf: object).	"a good field"
	[fieldPtr > limit] whileFalse: [
		former := self longAt: fieldPtr.
		(self validOop: former) ifFalse: [self error: 'invalid oop in pointers object'].
		fieldPtr := fieldPtr + self bytesPerWord].
	"class"
	header := self baseHeader: object.
	(header bitAnd: CompactClassMask) = 0 ifTrue: [	
		former := (self classHeader: object) bitAnd: self allButTypeMask.
		(self validOop: former) ifFalse: [self halt]].! !
!InterpreterSimulator methodsFor: 'file primitives' stamp: 'dtl 5/19/2010 18:38'!
vmPathGet: stringBase Length: stringSize
	| pathName stringOop |
	pathName := Smalltalk vmPath.
	stringOop := stringBase - self baseHeaderSize. "Due to C call in Interp"
	1 to: stringSize do:
		[:i | self storeByte: i-1 ofObject: stringOop
			withValue: (pathName at: i) asciiValue].
! !
!InterpreterSimulator methodsFor: 'file primitives'!
vmPathSize
	^ Smalltalk vmPath size! !
!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'yo 6/3/1999 16:10'!
warpBits

	^ myBitBlt warpBits! !
!InterpreterSimulator methodsFor: 'image save/restore' stamp: 'dtl 10/24/2010 21:03'!
writeImageFileIO: numberOfBytesToWrite
	"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."

	| headerSize file |
	self bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
	headerSize := 16 * self bytesPerWord.

	[
		file := (FileStream fileNamed: imageName) binary.
		file == nil ifTrue: [^nil].
	
		{
			self imageFormatVersion.
			headerSize.
			numberOfBytesToWrite.
			self startOfMemory.
			specialObjectsOop.
			lastHash.
			self ioScreenSize.
			fullScreenFlag.
			extraVMMemory
		}
			do: [:long | self putLong: long toFile: file].
	
		"Pad the rest of the header."
		7 timesRepeat: [self putLong: 0 toFile: file].
	
		"Position the file after the header."
		file position: headerSize.
	
		"Write the object memory."
		1
			to: numberOfBytesToWrite // 4
			do: [:index |
				self
					putLong: (memory at: index)
					toFile: file].
	
		self success: true
	]
		ensure: [file close]! !

InterpreterSimulator subclass: #InterpreterSimulatorLSB
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulatorLSB commentStamp: '<historical>' prior: 0!
This class overrides a few methods in InterpreterSimulator required for simulation to work on little-endian architectures (such as the x86 family of processors).  To start it up simply use InterpreterSimulatorLSB instead of InterpreterSimulator (see the class comment there for more details).  For example:

	(InterpreterSimulatorLSB new openOn: Smalltalk imageName) test

Note that the image must have been saved at least once on the local architecture, since the compiled VM performs some byte swapping that the simulator cannot cope with.!
!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'nk 4/3/2004 06:58'!
byteAt: byteAddress
	| lowBits long |
	lowBits := byteAddress bitAnd: 3.
	long := self longAt: byteAddress - lowBits.
	^(lowBits caseOf: {
		[0] -> [ long ].
		[1] -> [ long bitShift: -8  ].
		[2] -> [ long bitShift: -16 ].
		[3] -> [ long bitShift: -24 ]
	}) bitAnd: 16rFF
! !
!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'nk 4/3/2004 07:06'!
byteAt: byteAddress put: byte
	| lowBits long longAddress |
	lowBits := byteAddress bitAnd: 3.
	longAddress := byteAddress - lowBits.
	long := self longAt: longAddress.
	long := (lowBits caseOf: {
		[0] -> [ (long bitAnd: 16rFFFFFF00) bitOr: byte ].
		[1] -> [ (long bitAnd: 16rFFFF00FF) bitOr: (byte bitShift: 8) ].
		[2] -> [ (long bitAnd: 16rFF00FFFF) bitOr: (byte bitShift: 16)  ].
		[3] -> [ (long bitAnd: 16r00FFFFFF) bitOr: (byte bitShift: 24)  ]
	}).

	self longAt: longAddress put: long.
! !
!InterpreterSimulatorLSB methodsFor: 'debug support' stamp: 'ikp 12/11/1998 01:35'!
charsOfLong: long
	^ (1 to: 4) collect:
		[:i | ((long digitAt: i) between: 14 and: 126)
					ifTrue: [(long digitAt: i) asCharacter]
					ifFalse: [$?]]! !
!InterpreterSimulatorLSB methodsFor: 'debug support' stamp: 'ar 10/24/1999 21:47'!
displayForm: f
	| width height depth bits realForm simDisp realDisp |
	bits := self fetchPointer: 0 ofObject: f.
	width := self fetchInteger: 1 ofObject: f.
	height := self fetchInteger: 2 ofObject: f.
	depth := self fetchInteger: 3 ofObject: f.
	realForm := Form extent: width@height depth: depth.
	simDisp := Form new hackBits: memory.
	realDisp := Form new hackBits: realForm bits.
	realDisp
		copy: (0 @ 0 extent: 4 @ realForm bits size)
		from: (0 @ (bits + 4 // 4))
		in: simDisp
		rule: Form over.
	realForm displayOn: Display at: 0@0.! !
!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:59'!
halfWordHighInLong32: long32
	"Used by Balloon"

	^ long32 bitAnd: 16rFFFF! !
!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:59'!
halfWordLowInLong32: long32
	"Used by Balloon"

	^ long32 bitShift: -16! !
!InterpreterSimulatorLSB methodsFor: 'initialization' stamp: 'dtl 5/19/2010 18:51'!
nextLongFrom: aStream
	"Read a 32- or 64-bit quantity from the given (binary) stream."

	^ aStream nextLittleEndianNumber: self bytesPerWord! !
!InterpreterSimulatorLSB methodsFor: 'image save/restore' stamp: 'crl 2/28/2003 01:22'!
putLong: n toFile: f
	"Append the given 4-byte long word to the given file in my byte order. (Bytes will be swapped, if necessary, when the image is read on a different platform.) Set successFlag to false if the write fails."

	| remainingValue |

	remainingValue := n.
	4 timesRepeat: [
		f nextPut: (remainingValue bitAnd: 16rFF).
		remainingValue := remainingValue bitShift: -8].

	self success: true! !
!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 6/23/2004 14:29'!
shortAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	| lowBits long |
	lowBits := byteAddress bitAnd: 2.
	long := self longAt: byteAddress - lowBits.
	^ lowBits = 2
		ifTrue: [ long bitShift: -16 ]
		ifFalse: [ long bitAnd: 16rFFFF ].
! !
!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 6/23/2004 14:31'!
shortAt: byteAddress put: a16BitValue
    "Return the half-word at byteAddress which must be even."
	| lowBits long longAddress |
	lowBits := byteAddress bitAnd: 2.
	lowBits = 0
		ifTrue:
		[ "storing into LS word"
		long := self longAt: byteAddress.
		self longAt: byteAddress
				put: ((long bitAnd: 16rFFFF0000) bitOr: a16BitValue)
		]
		ifFalse:
		[longAddress := byteAddress - 2.
		long := self longAt: longAddress.
		self longAt: longAddress
				put: ((long bitAnd: 16rFFFF) bitOr: (a16BitValue bitShift: 16))
		]! !
!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'tpr 12/22/2005 17:46'!
vmEndianness
	"return 0 for little endian, 1 for big endian"
	^0! !

InterpreterSimulatorLSB subclass: #InterpreterSimulatorLSB64
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulatorLSB64 methodsFor: 'initialization' stamp: 'dtl 5/19/2010 22:21'!
initialize

	bytesPerWord := 8.
	super initialize! !
!InterpreterSimulatorLSB64 methodsFor: 'memory access' stamp: 'di 6/13/2004 10:56'!
long32At: byteAddress

	"Return the 32-bit word at byteAddress which must be 0 mod 4."
	| lowBits long |
	lowBits := byteAddress bitAnd: 4.
	long := self longAt: byteAddress - lowBits.
	^ lowBits = 4
		ifTrue: [ long bitShift: -32 ]
		ifFalse: [ long bitAnd: 16rFFFFFFFF ].
! !
!InterpreterSimulatorLSB64 methodsFor: 'memory access' stamp: 'di 6/13/2004 11:01'!
long32At: byteAddress put: a32BitValue
	"Store the 32-bit value at byteAddress which must be 0 mod 4."
	| lowBits long64 longAddress |
	lowBits := byteAddress bitAnd: 4.
	lowBits = 0
		ifTrue:
		[ "storing into LS word"
		long64 := self longAt: byteAddress.
		self longAt: byteAddress
				put: ((long64 bitAnd: 16rFFFFFFFF00000000) bitOr: a32BitValue)
		]
		ifFalse:
		[longAddress := byteAddress - 4.
		long64 := self longAt: longAddress.
		self longAt: longAddress
				put: ((long64 bitAnd: 16rFFFFFFFF) bitOr: (a32BitValue bitShift: 32))
		]! !

InterpreterSimulator subclass: #InterpreterSimulatorMSB
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'dtl 5/19/2010 18:51'!
byteAt: byteAddress
	| lowBits bpwMinus1 |
	bpwMinus1 := self bytesPerWord - 1.
	lowBits := byteAddress bitAnd: bpwMinus1.
	^ ((self longAt: byteAddress - lowBits)
		bitShift: (lowBits - bpwMinus1) * 8)
		bitAnd: 16rFF! !
!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'dtl 5/19/2010 18:51'!
byteAt: byteAddress put: byte
	| longWord shift lowBits bpwMinus1 longAddress |
	bpwMinus1 := self bytesPerWord - 1.
	lowBits := byteAddress bitAnd: bpwMinus1.
	longAddress := byteAddress - lowBits.
	longWord := self longAt: longAddress.
	shift := (bpwMinus1 - lowBits) * 8.
	longWord := longWord
				- (longWord bitAnd: (16rFF bitShift: shift))
				+ (byte bitShift: shift).
	self longAt: longAddress put: longWord! !
!InterpreterSimulatorMSB methodsFor: 'debug support' stamp: 'dtl 5/19/2010 18:51'!
charsOfLong: long
	^ (self bytesPerWord to: 1 by: -1) collect:
		[:i | ((long digitAt: i) between: 14 and: 126)
					ifTrue: [(long digitAt: i) asCharacter]
					ifFalse: [$?]]! !
!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:58'!
halfWordHighInLong32: long32
	"Used by Balloon"

	^ long32 bitShift: -16! !
!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:58'!
halfWordLowInLong32: long32
	"Used by Balloon"

	^ long32 bitAnd: 16rFFFF! !
!InterpreterSimulatorMSB methodsFor: 'initialization' stamp: 'dtl 5/19/2010 18:51'!
nextLongFrom: aStream 
	"Read a 32- or 64-bit quantity from the given (binary) stream."

	^ aStream nextNumber: self bytesPerWord! !
!InterpreterSimulatorMSB methodsFor: 'image save/restore' stamp: 'crl 6/5/2003 11:37'!
putLong: n toFile: f
	"Append the given 4-byte long word to the given file in my byte order. (Bytes will be swapped, if necessary, when the image is read on a different platform.) Set successFlag to false if the write fails."

	f
		nextPut: (n bitShift: -24);
		nextPut: ((n bitAnd: 16rFF0000) bitShift: -16);
		nextPut: ((n bitAnd: 16rFF00) bitShift: -8);
		nextPut: (n bitAnd: 16rFF).

	self success: true! !
!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'dtl 5/19/2010 18:51'!
shortAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	| lowBits bpwMinus2 |
	bpwMinus2 := self bytesPerWord - 2.
	lowBits := byteAddress bitAnd: bpwMinus2.
	^ ((self longAt: byteAddress - lowBits)
		bitShift: (lowBits - bpwMinus2) * 8)
		bitAnd: 16rFFFF
! !
!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'dtl 5/19/2010 18:51'!
shortAt: byteAddress put: a16BitValue
    "Return the half-word at byteAddress which must be even."
	| longWord shift lowBits bpwMinus2 longAddress |
	bpwMinus2 := self bytesPerWord - 2.
	lowBits := byteAddress bitAnd: bpwMinus2.
	longAddress := byteAddress - lowBits.
	longWord := self longAt: longAddress.
	shift := (bpwMinus2 - lowBits) * 8.
	longWord := longWord
				- (longWord bitAnd: (16rFFFF bitShift: shift))
				+ (a16BitValue bitShift: shift).
	self longAt: longAddress put: longWord
! !
!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'tpr 12/22/2005 17:46'!
vmEndianness
	"return 0 for little endian, 1 for big endian"
	^1! !

InterpreterSimulatorMSB subclass: #InterpreterSimulatorMSB64
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulatorMSB64 methodsFor: 'memory access' stamp: 'di 6/9/2004 12:17'!
byteSwapped: w
	"Return the given integer with its bytes in the reverse order."

	^ (super byteSwapped: ((w bitShift: -32) bitAnd: 16rFFFFFFFF)) +
	  ((super byteSwapped: (w bitAnd: 16rFFFFFFFF)) bitShift: 32)! !
!InterpreterSimulatorMSB64 methodsFor: 'initialization' stamp: 'dtl 5/19/2010 22:22'!
initialize

	bytesPerWord := 8.
	super initialize! !
!InterpreterSimulatorMSB64 methodsFor: 'memory access' stamp: 'di 7/3/2004 10:40'!
long32At: byteAddress
	"Return the 32-bit word at byteAddress which must be 0 mod 4."

	^ super longAt: byteAddress! !
!InterpreterSimulatorMSB64 methodsFor: 'memory access' stamp: 'di 7/3/2004 10:41'!
long32At: byteAddress put: a32BitValue
	"Store the 32-bit value at byteAddress which must be 0 mod 4."

	super longAt: byteAddress put: a32BitValue! !
!InterpreterSimulatorMSB64 methodsFor: 'memory access' stamp: 'di 6/9/2004 15:43'!
longAt: byteAddress
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^ ((super longAt: byteAddress) bitShift: 32) bitOr: (super longAt: byteAddress + 4)! !
!InterpreterSimulatorMSB64 methodsFor: 'memory access' stamp: 'di 6/9/2004 15:48'!
longAt: byteAddress put: a64BitValue
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	super longAt: byteAddress put: (a64BitValue bitShift: -32).
	super longAt: byteAddress + 4 put: (a64BitValue bitAnd: 16rFFFFFFFF).
	^ a64BitValue! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:04'!
byte0Mask
	^Byte0Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:20'!
byte0Shift
	^Byte0Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:04'!
byte1Mask
	^Byte1Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:20'!
byte1Shift
	^Byte1Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:08'!
byte1ShiftNegated
	^Byte1ShiftNegated! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:04'!
byte2Mask
	^Byte2Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:20'!
byte2Shift
	^Byte2Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:04'!
byte3Mask
	^Byte3Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:20'!
byte3Shift
	^Byte3Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:09'!
byte3ShiftNegated
	^Byte3ShiftNegated! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:04'!
byte4Mask
	^Byte4Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:20'!
byte4Shift
	^Byte4Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:09'!
byte4ShiftNegated
	^Byte4ShiftNegated! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:04'!
byte5Mask
	^Byte5Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:21'!
byte5Shift
	^Byte5Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:09'!
byte5ShiftNegated
	^Byte5ShiftNegated! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:04'!
byte6Mask
	^Byte6Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:21'!
byte6Shift
	^Byte6Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:05'!
byte7Mask
	^Byte7Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:21'!
byte7Shift
	^Byte7Shift! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:09'!
byte7ShiftNegated
	^Byte7ShiftNegated! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:08'!
bytes3to0Mask
	^Bytes3to0Mask! !
!ObjectMemory class methodsFor: 'accessing' stamp: 'dtl 5/17/2010 12:08'!
bytes7to4Mask
	^Bytes7to4Mask! !
!ObjectMemory class methodsFor: 'translation' stamp: 'dtl 4/14/2007 16:14'!
declareCAsOop: arrayOfVariableNames in: aCCodeGenerator
	"Declare the variables in arrayOfVariableNames with type representing position in object memory."

	arrayOfVariableNames
		do: [:varName | aCCodeGenerator var: varName type: 'usqInt']! !
!ObjectMemory class methodsFor: 'translation' stamp: 'dtl 11/2/2010 11:14'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator var: #memory type:#'usqInt'.
	aCCodeGenerator
		var: #remapBuffer
		declareC: 'sqInt remapBuffer[', (RemapBufferSize + 1) printString, ']'.
	aCCodeGenerator
		var: #rootTable
		declareC: 'sqInt rootTable[', (RootTableSize + 1) printString, ']'.
	"Weak roots must be large enough for roots+remapBuffer+sizeof(allCallsOn: #markAndTrace:)"
	aCCodeGenerator
		var: #weakRoots
		declareC: 'sqInt weakRoots[', (RootTableSize + RemapBufferSize + 100) printString, ']'.
	aCCodeGenerator
		var: #extraRoots
		declareC: 'sqInt* extraRoots[', (ExtraRootSize + 1) printString, ']'.
	aCCodeGenerator
		var: #headerTypeBytes
		declareC: 'sqInt headerTypeBytes[4]'.
	
	self declareCAsOop: {
			#youngStart .
			#endOfMemory .
			#memoryLimit .
			#youngStartLocal .
			#freeBlock .
			#compStart .
			#compEnd .
			#fwdTableNext .
			#fwdTableLast .
			#gcBiasToGrowThreshold .
			#shrinkThreshold .
			#growHeadroom }
		in: aCCodeGenerator
! !
!ObjectMemory class methodsFor: 'initialization' stamp: 'dtl 5/25/2010 23:09'!
initializeConstants
	"ObjectMemory initializeConstants"

	self initializeObjectWordConstants.

	"Translation flags (booleans that control code generation via conditional translation):"
	DoAssertionChecks := false.  "generate assertion checks"
	DoBalanceChecks := false. "generate stack balance checks"

	self initializeSpecialObjectIndices.
	self initializeObjectHeaderConstants.

	CtxtTempFrameStart := 6.  "Copy of TempFrameStart in Interp"
	ContextFixedSizePlusHeader := CtxtTempFrameStart + 1.
	
	LargeContextBit := 16r40000.  "This bit set in method headers if large context is needed."
	NilContext := 1.  "the oop for the integer 0; used to mark the end of context lists"

	RemapBufferSize := 25.
	RootTableSize := 2500.  	"number of root table entries (4 bytes/entry)"
	RootTableRedZone := RootTableSize - 100.	"red zone of root table - when reached we force IGC"

	"tracer actions"
	StartField := 1.
	StartObj := 2.
	Upward := 3.
	Done := 4.

	ExtraRootSize := 2048. "max. # of external roots"! !
!ObjectMemory class methodsFor: 'initialization' stamp: 'dtl 5/19/2010 19:12'!
initializeObjectHeaderConstants

	"masks for type field"
	TypeMask := 3.

	"type field values"
	HeaderTypeSizeAndClass := 0.
	HeaderTypeClass := 1.
	HeaderTypeFree := 2.
	HeaderTypeShort := 3.

	"type field values used during the mark phase of GC"
	HeaderTypeGC := 2.
	GCTopMarker := 3.  "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase."

	"Base header word bit fields"
	HashBits := 16r1FFE0000.
	HashBitsOffset := 17.

	CompactClassMask := 16r1F000
! !
!ObjectMemory class methodsFor: 'initialization' stamp: 'dtl 5/25/2010 23:03'!
initializeObjectWordConstants

	Byte0Shift := 0.
	Byte1Shift := 8.
	Byte2Shift := 16.
	Byte3Shift := 24.
	Byte4Shift := 32.
	Byte5Shift := 40.
	Byte6Shift := 48.
	Byte7Shift := 56.

	Byte0Mask := 16r00000000000000FF.
	Byte1Mask := 16r000000000000FF00.
	Byte2Mask := 16r0000000000FF0000.
	Byte3Mask := 16r00000000FF000000.
	Byte4Mask := 16r000000FF00000000.
	Byte5Mask := 16r0000FF0000000000.
	Byte6Mask := 16r00FF000000000000.
	Byte7Mask := 16rFF00000000000000.
	Bytes3to0Mask := 16r00000000FFFFFFFF.
	Bytes7to4Mask := 16rFFFFFFFF00000000.
							
	Byte1ShiftNegated := Byte1Shift negated.
	Byte3ShiftNegated := Byte3Shift negated.
	Byte4ShiftNegated := Byte4Shift negated.
	Byte5ShiftNegated := Byte5Shift negated.
	Byte7ShiftNegated := Byte7Shift negated! !
!ObjectMemory class methodsFor: 'initialization' stamp: 'dtl 5/24/2010 22:29'!
initializeSpecialObjectIndices
	"Initialize indices into specialObjects array."

	NilObject := 0.
	FalseObject := 1.
	TrueObject := 2.
	SchedulerAssociation := 3.
	ClassBitmap := 4.
	ClassInteger := 5.
	ClassString := 6.
	ClassArray := 7.
	"SmalltalkDictionary := 8."  "Do not delete!!"
	ClassFloat := 9.
	ClassMethodContext := 10.
	ClassBlockContext := 11.
	ClassPoint := 12.
	ClassLargePositiveInteger := 13.
	TheDisplay := 14.
	ClassMessage := 15.
	ClassCompiledMethod := 16.
	TheLowSpaceSemaphore := 17.
	ClassSemaphore := 18.
	ClassCharacter := 19.
	SelectorDoesNotUnderstand := 20.
	SelectorCannotReturn := 21.
	ProcessSignalingLowSpace := 22.	"was TheInputSemaphore"
	SpecialSelectors := 23.
	CharacterTable := 24.
	SelectorMustBeBoolean := 25.
	ClassByteArray := 26.
	ClassProcess := 27.
	CompactClasses := 28.
	TheTimerSemaphore := 29.
	TheInterruptSemaphore := 30.
	SelectorCannotInterpret := 34.
	"Was MethodContextProto := 35."
	ClassBlockClosure := 36.
	"Was BlockContextProto := 37."
	ExternalObjectsArray := 38.
	ClassPseudoContext := 39.
	ClassTranslatedMethod := 40.
	TheFinalizationSemaphore := 41.
	ClassLargeNegativeInteger := 42.

	ClassExternalAddress := 43.
	ClassExternalStructure := 44.
	ClassExternalData := 45.
	ClassExternalFunction := 46.
	ClassExternalLibrary := 47.

	SelectorAboutToReturn := 48.
	SelectorRunWithIn := 49.
	SelectorAttemptToAssign := 50.

	"PrimErrTableIndex := 51. in Interpreter class>>initializePrimitiveErrorCodes"

	ClassAlien := 52.
	InvokeCallbackSelector := 53.
	ClassUnsafeAlien := 54.

	ClassWeakFinalizer := 55
! !
!ObjectMemory class methodsFor: 'translation' stamp: 'tpr 2/17/2005 13:19'!
noteCompilationOf: aSelector meta: isMeta
	"note the recompiliation by resetting the timeStamp "
	timeStamp := Time totalSeconds.
	^super noteCompilationOf: aSelector meta: isMeta! !
!ObjectMemory class methodsFor: 'translation' stamp: 'tpr 2/29/2004 19:51'!
requiredMethodNames
	"return the list of method names that should be retained for export or other support reasons"
	^ #(checkedLongAt: allocateChunk: firstAccessibleObject noteAsRoot:headerLoc: splObj:)! !
!ObjectMemory class methodsFor: 'translation' stamp: 'tpr 3/27/2002 12:53'!
timeStamp
	^timeStamp ifNil:[0]! !
!ObjectMemory class methodsFor: 'translation' stamp: 'dtl 5/19/2010 15:21'!
unsignedIntegerSuffix
	"Answer the suffix that should be appended to unsigned integer literals in generated code."

	^ 'U'

	"The U declaration is sufficient for 64-bit cases - dtl"
	"^BytesPerWord = 4 ifTrue: ['U'] ifFalse: ['ULL']"! !
!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'eem 10/22/2008 10:29'!
aComment
	"The mark phase is based on a pointer reversing traversal. This is a little tricky because the class, which is needed by the traversal, may be in either the header (as a compact class index) or in the word above the header. See memo 'Revised object format'.
	Compact classes are marked and traced separately.
	How do you know that you are returning from having marked a class? Parent pointer has 10 in low bits.

Here are the states an object may be in, followed by what to do next in brackets []:

  Start Object: parentField is set, [obj := child]:
	obj is pointed at by a field in parent that is being traced now. obj is marked.
		[(parent goes up to the next field) field addr := obj. go to Upward]
	obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has no pointers.
		[put 10 into low bits of header. field addr := obj. go to Start Field (to process class word)]
	obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has pointers.
		[put 10 into low bits of header. point to last field. go to Start Field]

  Start Field: 
	Field ends in 10. It is the header. Short Class is not 0.
		[Set low bits to correct value. (have parent pointer) go to Upward]
	Field ends in 10. It is the header. Short Class is 0.
		[child := word above header. low bits of child := 01. class word := parentField. parentField := loc of class word. go to Start Obj]
	Field is Integer.
		[point one word up, go to Start Field]
	Field is oop.
		[child := field. field := parentField. parentField := loc of field. go to Start Obj]

  Upward [restore low bits of header (at field addr)]:
	parentField is 3. (bits 11, int 1).
		[done!!]
	parentField ends in 00.
		[child := field addr. field addr := parentField. parentField := field addr contents.
		field addr contents := child (addr of prev object. its oop). field addr - 4. go to Start Field]
	parentField ends in 01. We're tracing the class.
		[child := field addr. field addr := parentField (loc of class word). parentField := field addr contents.
		field addr contents := child (addr of prev object. its oop). field addr + 4 (header). go to Upward]
"! !
!ObjectMemory methodsFor: 'finalization' stamp: 'ar 1/18/2005 15:07'!
aFinalizationComment
	"This finalization scheme assumes to have weak classes in which the fields are not traced during the mark phase of a GC. This means, if an object is referenced only by any instances of weak classes it can be collected. In turn, we need to find out if an object referenced by a weak class is actually being collected because we have to invalidate the weak object pointer and to signal that the object has gone.
	How do we know that an object referenced by a weak class is being collected? Well,  this is based on two observations. First, objects will not change their relative locations in memory, meaning that if object A is created BEFORE object B it will always have a physical memory address which is LESS than B. Secondly, GC always works from a given starting address (youngStart during incremental GC; startOfMemory during fullGC) up to end of memory. If we can somehow garantuee that the weak reference is created after the object it points to we can easily implement the following simple scheme:
	1) Mark phase
		Do not trace the fields of any instances of weak classes.
	2) Sweep phase:
		a) Explicitly mark all free objects.
		b) 	If a weak reference is encountered check the the object it points to. 
			If the object is marked as free than we know that this weak reference's object is gone.
			Signal that it is gone.

	There is, however, one small problem with this approach. We cannot always garantuee that WeakReferences point backwards such as in the following piece of code:
		| o1 o2 w1 w2 |
		o1 := Object new.
		w1 := WeakReference on: o1.
		o2 := Object new.
		w2 := WeakReference on: o2.
		o1 become: o2.
The become: operation makes w1 point to o2 and because o2 has been created AFTER w1 the object reference in w1 points forward. Why might this be a problem? Well, if the GC would start after the weak reference AND free the object then the weak reference would simply point to an invalid memory location (since we've not been checking the weak reference during sweep phase).

	Fortunately, this can not happen in the current ObjectMemory implementation. Why? Well, the only GC not starting at the beginning of the memory is incremental GC. Incremental GC however is only executed in so-called youngSpace. If both, the weak reference AND the object it points to reside in youngSpace then we can still check the weak reference. If however, the weak reference is not in youngSpace but the object is, then the reference is itself a root for young space and will be processed by the GC.

	In the end, we just need a little adjustment in step 2b) of the above procedure which looks as follows:
		If the weak reference points 
			* backwards: check if the object header is marked free
			* forwards: check if the object has been marked in markPhase.

	Note that a number of finalizations will only be executed during a fullGC. So, if you must garantuee that some object has been finalized you definitely need to do a fullGC.

ar 3/20/98 17:20"

	self error:'Comment only'.! !
!ObjectMemory methodsFor: 'object enumeration' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 20:46'!
accessibleObjectAfter: oop 
	"Return the accessible object following the given object or 
	free chunk in the heap. Return nil when heap is exhausted."
	| obj |
	<inline: false>
	obj := self objectAfter: oop.
	[self oop: obj isLessThan: endOfMemory]
		whileTrue: [(self isFreeObject: obj) ifFalse: [^ obj].
			obj := self objectAfter: obj].
	^ nil! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar (auto pragmas dtl 2010-09-26) 6/8/2006 13:06'!
addGCRoot: varLoc
	"Add the given variable location to the extra roots table"
	<export: true>
	<var: #varLoc declareC: 'sqInt *varLoc'>
	extraRootCount >= ExtraRootSize ifTrue:[^false]. "out of space"
	extraRoots at: (extraRootCount := extraRootCount+1) put: varLoc.
	^true! !
!ObjectMemory methodsFor: 'initialization' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 20:48'!
adjustAllOopsBy: bytesToShift 
	"Adjust all oop references by the given number of bytes. This 
	is done just after reading in an image when the new base 
	address of the object heap is different from the base address 
	in the image."
	"di 11/18/2000 - return number of objects found"

	| oop totalObjects |
	<inline: false>
	bytesToShift = 0 ifTrue: [^300000].
	"this is probably an improvement over the previous answer of 
	nil, but maybe we should do the obejct counting loop and 
	simply guard the adjustFieldsAndClass... with a bytesToShift 
	= 0 ifFalse: ?"
	totalObjects := 0.
	oop := self firstObject.
	[self oop: oop isLessThan: endOfMemory]
		whileTrue:
			[(self isFreeObject: oop)
				ifFalse:
					[totalObjects := totalObjects + 1.
					 self adjustFieldsAndClassOf: oop by: bytesToShift].
			 oop := self objectAfter: oop].
	^totalObjects! !
!ObjectMemory methodsFor: 'initialization' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:02'!
adjustFieldsAndClassOf: oop by: offsetBytes 
	"Adjust all pointers in this object by the given offset."
	| fieldAddr fieldOop classHeader newClassOop |
	<inline: true>
	offsetBytes = 0 ifTrue: [^nil].
	fieldAddr := oop + (self lastPointerOf: oop).
	[self oop: fieldAddr isGreaterThan: oop]
		whileTrue: [fieldOop := self longAt: fieldAddr.
			(self isIntegerObject: fieldOop)
				ifFalse: [self longAt: fieldAddr put: fieldOop + offsetBytes].
			fieldAddr := fieldAddr - self bytesPerWord].
	(self headerType: oop) ~= HeaderTypeShort
		ifTrue: ["adjust class header if not a compact class"
			classHeader := self longAt: oop - self bytesPerWord.
			newClassOop := (classHeader bitAnd: self allButTypeMask) + offsetBytes.
			self longAt: oop - self bytesPerWord put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:50'!
allButHashBits
	"Base header word bit fields"

	<inline: true>
	^self
		cCode: 'ALL_BUT_HASH_BITS'
		inSmalltalk: [self wordMask - HashBits]
! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:48'!
allButMarkBit
	"Mask for mark bit"

	<inline: true>
	^self
		cCode: 'ALL_BUT_MARK_BIT'
		inSmalltalk: [self wordMask - self markBit]
! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:53'!
allButMarkBitAndTypeMask

	<inline: true>
	^self
		cCode: 'ALL_BUT_MARK_BIT_AND_TYPE_MASK'
		inSmalltalk: [self allButTypeMask - self markBit]
! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:47'!
allButRootBit
	"Mask for root bit"

	<inline: true>
	^self
		cCode: 'ALL_BUT_ROOT_BIT'
		inSmalltalk: [self wordMask - self rootBit]
! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:55'!
allButTypeMask
	"Mask for type field"

	<inline: true>
	^self
		cCode: 'ALL_BUT_TYPE_MASK'
		inSmalltalk: [self wordMask - TypeMask]
! !
!ObjectMemory methodsFor: 'become' stamp: 'dtl 5/18/2010 21:48'!
allYoung: array1 and: array2 
	"Return true if all the oops in both arrays, and the arrays 
	themselves, are in the young object space."
	| fieldOffset |
	(self oop: array1 isLessThan: youngStart)
		ifTrue: [^ false].
	(self oop: array2 isLessThan: youngStart)
		ifTrue: [^ false].
	fieldOffset := self lastPointerOf: array1.
	"same size as array2"
	[fieldOffset >= self baseHeaderSize] whileTrue:
		[(self oop: (self longAt: array1 + fieldOffset) isLessThan: youngStart)
			ifTrue: [^ false].
		(self oop: (self longAt: array2 + fieldOffset) isLessThan: youngStart)
			ifTrue: [^ false].
		fieldOffset := fieldOffset - self bytesPerWord].
	^ true! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:12'!
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord 
	"Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with the given value.
	May cause a GC"

	| newObj remappedClassOop end i |
	<inline: true>
	<var: #i type: 'usqInt'>
	<var: #end type: 'usqInt'>
	"remap classOop in case GC happens during allocation"
	hdrSize > 1 ifTrue: [self pushRemappableOop: classOop].
	newObj := self allocateChunk: byteSize + (hdrSize - 1 * self bytesPerWord).
	hdrSize > 1 ifTrue: [remappedClassOop := self popRemappableOop].

	hdrSize = 3
		ifTrue: [self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass).
			self longAt: newObj + self bytesPerWord put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).
			self longAt: newObj + (self bytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
			newObj := newObj + (self bytesPerWord*2)].

	hdrSize = 2
		ifTrue: [self longAt: newObj put: (remappedClassOop bitOr: HeaderTypeClass).
			self longAt: newObj + self bytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
			newObj := newObj + self bytesPerWord].

	hdrSize = 1
		ifTrue: [self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)].
	"clear new object"
	doFill ifTrue: [end := newObj + byteSize.
			i := newObj + self bytesPerWord.
			[i < end] whileTrue: [self longAt: i put: fillWord.
					i := i + self bytesPerWord]].
	DoAssertionChecks
		ifTrue: [self okayOop: newObj.
			self oopHasOkayClass: newObj.
			(self objectAfter: newObj) = freeBlock
				ifFalse: [self error: 'allocate bug: did not set header of new oop correctly'].
			(self objectAfter: freeBlock) = endOfMemory
				ifFalse: [self error: 'allocate bug: did not set header of freeBlock correctly']].

	^newObj! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:48'!
allocateChunk: byteSize 
	"Allocate a chunk of the given size. Sender must be sure that  the requested size includes enough space for the header  word(s). " 
	"Details: To limit the time per incremental GC, do one every so many allocations. The number is settable via primitiveVMParameter to tune your memory system"
	| enoughSpace newFreeSize newChunk |
	<inline: true>

	allocationCount >= allocationsBetweenGCs
		ifTrue: ["do an incremental GC every so many allocations to  keep pauses short"
			self incrementalGC].

	enoughSpace := self sufficientSpaceToAllocate: byteSize.
	enoughSpace
		ifFalse: ["signal that space is running low, but proceed with allocation if possible"
			signalLowSpace := true.
			lowSpaceThreshold := 0. "disable additional interrupts until lowSpaceThreshold is reset by image"
			self saveProcessSignalingLowSpace.
			self forceInterruptCheck].
	(self oop: (self sizeOfFree: freeBlock) isLessThan: byteSize + self baseHeaderSize)
		ifTrue: [self error: 'out of memory'].

	"if we get here, there is enough space for allocation to  succeed "
	newFreeSize := (self sizeOfFree: freeBlock) - byteSize.
	newChunk := freeBlock.
	freeBlock := freeBlock + byteSize.

	"Assume: client will initialize object header of free chunk, so following is not needed:"
	"self setSizeOfFree: newChunk to: byteSize."
	self setSizeOfFree: freeBlock to: newFreeSize.
	allocationCount := allocationCount + 1.
	^newChunk! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl 5/19/2010 11:28'!
allocateOrRecycleContext: needsLarge
	"Return a recycled context or a newly allocated one if none is available for recycling."
	| cntxt |
	needsLarge = 0
	ifTrue: [freeContexts ~= NilContext ifTrue:
				[cntxt := freeContexts.
				freeContexts := self fetchPointer: 0 ofObject: cntxt.
				^ cntxt]]
	ifFalse: [freeLargeContexts ~= NilContext ifTrue:
				[cntxt := freeLargeContexts.
				freeLargeContexts := self fetchPointer: 0 ofObject: cntxt.
				^ cntxt]].
	
	needsLarge = 0
		ifTrue: [cntxt := self instantiateContext: (self splObj: ClassMethodContext)
				sizeInBytes: self smallContextSize]
		ifFalse: [cntxt := self instantiateContext: (self splObj: ClassMethodContext)
				sizeInBytes: self largeContextSize].
	"Required init -- above does not fill w/nil.  All others get written."
	self storePointerUnchecked: 4 "InitialIPIndex" ofObject: cntxt
					withValue: nilObj.
	^ cntxt
! !
!ObjectMemory methodsFor: 'header access'!
baseHeader: oop

	^ self longAt: oop! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 18:39'!
baseHeaderSize
	"Answer the size of an object memory header word in bytes."

	<inline: true>
	^self cCode: 'BASE_HEADER_SIZE' inSmalltalk: [self bytesPerWord]
! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/22/2007 21:05'!
beRootIfOld: oop 
	"If this object is old, mark it as a root (because a new object 
	may be stored into it)"
	<inline: false>
	((self oop: oop isLessThan: youngStart)
			and: [(self isIntegerObject: oop) not])
		ifTrue: ["Yes, oop is an old object"
			self noteAsRoot: oop headerLoc: oop]! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl 5/19/2010 13:32'!
beRootWhileForwarding: oop
	"Record that the given oop in the old object area points to an object in the young area when oop may be forwarded."
	"Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."

	| header fwdBlock |
	header := self longAt: oop.
	(header bitAnd: self markBit) ~= 0
		ifTrue: ["This oop is forwarded"
				fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1.
				DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
				self noteAsRoot: oop headerLoc: fwdBlock + self bytesPerWord]
		ifFalse: ["Normal -- no forwarding"
				self noteAsRoot: oop headerLoc: oop]! !
!ObjectMemory methodsFor: 'become' stamp: 'brp 9/19/2003 16:09'!
become: array1 with: array2

	^ self become: array1 with: array2 twoWay: true copyHash: true
! !
!ObjectMemory methodsFor: 'become' stamp: 'tpr 3/23/2004 17:30'!
become: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag 
	"All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length. 
	Returns true if the primitive succeeds."
	"Implementation: Uses forwarding blocks to update references as done in compaction."
	(self isArray: array1) ifFalse: [^false].
	(self isArray: array2) ifFalse: [^false].
	(self lastPointerOf: array1) = (self lastPointerOf: array2) ifFalse: [^false].
	(self containOnlyOops: array1 and: array2) ifFalse: [^false].

	(self prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag) ifFalse: [^false]. "fail; not enough space for forwarding table"

	(self allYoung: array1 and: array2)
		ifTrue: ["sweep only the young objects plus the roots"
			self mapPointersInObjectsFrom: youngStart to: endOfMemory]
		ifFalse: ["sweep all objects"
			self mapPointersInObjectsFrom: self startOfMemory to: endOfMemory].
	twoWayFlag
		ifTrue: [self restoreHeadersAfterBecoming: array1 with: array2]
		ifFalse: [self restoreHeadersAfterForwardBecome: copyHashFlag].

	self initializeMemoryFirstFree: freeBlock. "re-initialize memory used for forwarding table"
	
	self forceInterruptCheck. "pretty much guaranteed to take a long time, so check for timers etc ASAP"

	^true "success"! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'dtl (auto pragmas dtl 2010-09-26) 10/17/2009 11:03'!
biasToGrow
	| growSize |
	<var: #growSize type: 'usqInt'>
	growSize :=  growHeadroom*3/2 - (self sizeOfFree: freeBlock).
	growSize > 0
		ifTrue: [self growObjectMemory: growSize]! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'dtl 4/22/2007 18:10'!
biasToGrowCheckGCLimit
	| growth |
	growth := (youngStart - memory) - gcBiasToGrowThreshold.
	growth < 0 ifTrue: [gcBiasToGrowThreshold := youngStart - memory].
	growth > gcBiasToGrowGCLimit
		 ifTrue: 
			[self fullGC.
			gcBiasToGrowThreshold := youngStart - memory].

					! !
!ObjectMemory methodsFor: 'allocation' stamp: 'ar 2/25/2001 17:45'!
bytesLeft: includingSwap
	^(self sizeOfFree: freeBlock) "already commited"
		+ (self sqMemoryExtraBytesLeft: includingSwap).! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 18:44'!
bytesPerWord
	"Answer the size of an object memory word in bytes."

	<inline: true>
	^self
		cCode: 'BYTES_PER_WORD'
		inSmalltalk: [self subclassResponsibility "InterpreterSimulator"]
! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
characterTable
	^self splObj: CharacterTable! !
!ObjectMemory methodsFor: 'memory access' stamp: 'dtl 4/22/2007 18:33'!
checkAddress: byteAddress 
	"Keep this method around for debugging the C code."
	(self oop: byteAddress isLessThan: self startOfMemory)
		ifTrue: [self error: 'bad address: negative'].
	(self oop: byteAddress isGreaterThanOrEqualTo: memoryLimit)
		ifTrue: [self error: 'bad address: past end of heap']! !
!ObjectMemory methodsFor: 'memory access'!
checkedByteAt: byteAddress
	"Assumes zero-based array indexing."

	self checkAddress: byteAddress.
	^ self byteAt: byteAddress! !
!ObjectMemory methodsFor: 'memory access'!
checkedByteAt: byteAddress put: byte
	"Assumes zero-based array indexing."

	self checkAddress: byteAddress.
	self byteAt: byteAddress put: byte.! !
!ObjectMemory methodsFor: 'memory access'!
checkedLongAt: byteAddress
	"Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass."

	self checkAddress: byteAddress.
	self checkAddress: byteAddress + 3.
	^ self longAt: byteAddress! !
!ObjectMemory methodsFor: 'memory access'!
checkedLongAt: byteAddress put: a32BitInteger
	"Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass."

	self checkAddress: byteAddress.
	self checkAddress: byteAddress + 3.
	self longAt: byteAddress put: a32BitInteger.! !
!ObjectMemory methodsFor: 'oop/chunk conversion' stamp: 'JMM 12/4/2002 19:55'!
chunkFromOop: oop
	"Compute the chunk of this oop by subtracting its extra header bytes."

	^ oop - (self extraHeaderBytes: oop)! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'eem 11/25/2008 17:10'!
classAlien
	^self splObj: ClassAlien! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
classArray
	^self splObj: ClassArray! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
classBitmap
	^self splObj: ClassBitmap! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
classByteArray
	^self splObj: ClassByteArray! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classCharacter
	^self splObj: ClassCharacter! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/21/1999 00:50'!
classExternalAddress
	^self splObj: ClassExternalAddress! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/17/1999 18:23'!
classExternalData
	^self splObj: ClassExternalData! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/17/1999 18:23'!
classExternalFunction
	^self splObj: ClassExternalFunction! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/17/1999 19:45'!
classExternalLibrary
	^self splObj: ClassExternalLibrary! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/21/1999 15:23'!
classExternalStructure
	^self splObj: ClassExternalStructure! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classFloat
	^self splObj: ClassFloat! !
!ObjectMemory methodsFor: 'header access' stamp: 'dtl 5/18/2010 21:48'!
classHeader: oop

	^ self longAt: oop - self baseHeaderSize! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/21/1999 23:22'!
classLargeNegativeInteger
	^self splObj: ClassLargeNegativeInteger! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classLargePositiveInteger
	^self splObj: ClassLargePositiveInteger! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classPoint
	^self splObj: ClassPoint! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:11'!
classSemaphore
	^self splObj: ClassSemaphore! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:11'!
classSmallInteger
	^self splObj: ClassInteger! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:12'!
classString
	^self splObj: ClassString! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'eem 11/25/2008 17:10'!
classUnsafeAlien
	^self splObj: ClassUnsafeAlien! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'dtl 5/19/2010 12:52'!
clearRootsTable
	"Clear the root bits of the current roots, then empty the roots 
	table. "
	"Caution: This should only be done when the young object 
	space is empty."
	"reset the roots table (after this, all objects are old so there 
	are no roots)"
	| oop |
	1 to: rootTableCount do: [:i | 
			"clear root bits of current root table entries"
			oop := rootTable at: i.
			self longAt: oop put: ((self longAt: oop) bitAnd: self allButRootBit).
			rootTable at: i put: 0].
	rootTableCount := 0! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:13'!
clone: oop
	"Return a shallow copy of the given object. May cause GC"
	"Assume: Oop is a real object, not a small integer."

	| extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash |
	<inline: false>
	<var: #lastFrom type: 'usqInt'>
	<var: #fromIndex type: 'usqInt'>
	extraHdrBytes := self extraHeaderBytes: oop.
	bytes := self sizeBitsOf: oop.
	bytes := bytes + extraHdrBytes.

	"allocate space for the copy, remapping oop in case of a GC"
	self pushRemappableOop: oop.
	"check it is safe to allocate this much memory. Return 0 if not"
	(self sufficientSpaceToAllocate: 2500 + bytes) ifFalse:[^0].
	newChunk := self allocateChunk: bytes.
	remappedOop := self popRemappableOop.

	"copy old to new including all header words"
	toIndex := newChunk - self bytesPerWord.  "loop below uses pre-increment"
	fromIndex := (remappedOop - extraHdrBytes) - self bytesPerWord.
	lastFrom := fromIndex + bytes.
	[fromIndex < lastFrom] whileTrue: [
		self longAt: (toIndex := toIndex + self bytesPerWord) put: (self longAt: (fromIndex := fromIndex + self bytesPerWord))].
	newOop := newChunk + extraHdrBytes.  "convert from chunk to oop"

	"fix base header: compute new hash and clear Mark and Root bits"
	hash := self newObjectHash.
	header := (self longAt: newOop) bitAnd: 16r1FFFF.
	"use old ccIndex, format, size, and header-type fields"
	header := header bitOr: ((hash << 17) bitAnd: 16r1FFE0000).
	self longAt: newOop put: header.
	^newOop
! !
!ObjectMemory methodsFor: 'become' stamp: 'dtl 5/18/2010 21:48'!
containOnlyOops: array1 and: array2 
	"Return true if neither array contains a small integer. You 
	can't become: integers!!"
	| fieldOffset |
	fieldOffset := self lastPointerOf: array1.
	"same size as array2"
	[fieldOffset >= self baseHeaderSize]
		whileTrue: [(self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [^ false].
			(self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [^ false].
			fieldOffset := fieldOffset - self bytesPerWord].
	^ true! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:12'!
displayObject
	^self splObj: TheDisplay! !
!ObjectMemory methodsFor: 'oop/chunk conversion' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/29/2010 00:17'!
extraHeaderBytes: oopOrChunk
	"Return the number of extra bytes used by the given object's header."
	"Warning: This method should not be used during marking, when the header type bits of an object may be incorrect."

	"JMM should be an array lookup!!" 
	<inline: true>
	<export: true>
	^ headerTypeBytes at: (self headerType: oopOrChunk).! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:12'!
falseObject
	^falseObj! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/18/2010 21:48'!
fetchByte: byteIndex ofObject: oop

	^ self byteAt: oop + self baseHeaderSize + byteIndex! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:02'!
fetchClassOf: oop 
	| ccIndex |
	<inline: true>
	(self isIntegerObject: oop) ifTrue: [^ self splObj: ClassInteger].

	ccIndex := (self baseHeader: oop) >> 12 bitAnd: 31.
	ccIndex = 0
		ifTrue: [^ (self classHeader: oop)
				bitAnd: self allButTypeMask]
		ifFalse: ["look up compact class"
			^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)]! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:02'!
fetchClassOfNonInt: oop 
	| ccIndex |
	<inline: true>
	ccIndex := (self baseHeader: oop) >> 12 bitAnd: 31.
	ccIndex = 0
		ifTrue: [^ (self classHeader: oop)
				bitAnd: self allButTypeMask]
		ifFalse: ["look up compact class"
			^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)]! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/18/2010 21:48'!
fetchLong32: fieldIndex ofObject: oop
	" index by 32-bit units, and return a 32-bit value. Intended to replace fetchWord:ofObject:"

	^ self long32At: oop + self baseHeaderSize + (fieldIndex << 2)! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/18/2010 21:48'!
fetchLong32LengthOf: objectPointer
	"Gives size appropriate for, eg, fetchLong32"

	| sz |
	sz := self sizeBitsOf: objectPointer.
	^ (sz - self baseHeaderSize) >> 2! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/19/2010 11:07'!
fetchPointer: fieldIndex ofObject: oop
	"index by word size, and return a pointer as long as the word size"

	^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/19/2010 11:07'!
fetchWordLengthOf: objectPointer
	"NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc."

	| sz |
	sz := self sizeBitsOf: objectPointer.
	^ (sz - self baseHeaderSize) >> self shiftForWord! !
!ObjectMemory methodsFor: 'finalization' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/24/2010 22:32'!
finalizeReference: oop 
	"During sweep phase we have encountered a weak reference. 
	Check if  its object has gone away (or is about to) and if so, signal a 
	semaphore. "
	"Do *not* inline this in sweepPhase - it is quite an unlikely 
	case to run into a weak reference"
	| weakOop oopGone chunk firstField lastField nonWeakCnt  |
	<inline: false>
	<var: #oop type: 'usqInt'>
	<var: #weakOop type: 'usqInt'>
	nonWeakCnt := self nonWeakFieldsOf: oop.
	firstField := self baseHeaderSize + (nonWeakCnt << self shiftForWord).
	lastField := self lastPointerOf: oop.
	firstField to: lastField by: self bytesPerWord do: [:i | 
			weakOop := self longAt: oop + i.
			"ar 1/18/2005: Added oop < youngStart test to make sure we're not testing
			objects in non-GCable region. This could lead to a forward reference in
			old space with the oop pointed to not being marked and thus treated as free."
			(weakOop == nilObj or: [(self isIntegerObject: weakOop) or:[weakOop < youngStart]])

				ifFalse: ["Check if the object is being collected. 
					If the weak reference points  
					* backward: check if the weakOops chunk is free
					* forward: check if the weakOoop has been marked by GC"
					weakOop < oop
						ifTrue: [chunk := self chunkFromOop: weakOop.
							oopGone := ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree]
						ifFalse: [oopGone := ((self baseHeader: weakOop) bitAnd: self markBit) = 0].
					oopGone ifTrue: ["Store nil in the pointer and signal the  interpreter "
							self longAt: oop + i put: nilObj.
							nonWeakCnt >= 2 ifTrue: [ self weakFinalizerCheck: oop ].
							self signalFinalization: oop]]]! !
!ObjectMemory methodsFor: 'object enumeration' stamp: 'dtl 4/22/2007 21:19'!
firstAccessibleObject
	"Return the first accessible object in the heap."
	| obj |
	obj := self firstObject.
	[self oop: obj isLessThan: endOfMemory]
		whileTrue: [(self isFreeObject: obj) ifFalse: [^ obj].
			obj := self objectAfter: obj].
	self error: 'heap is empty'! !
!ObjectMemory methodsFor: 'object enumeration'!
firstObject
	"Return the first object or free chunk in the heap."

	^ self oopFromChunk: self startOfMemory! !
!ObjectMemory methodsFor: 'header access' stamp: 'di 10/6/2004 10:26'!
formatOf: oop
"       0      no fields
        1      fixed fields only (all containing pointers)
        2      indexable fields only (all containing pointers)
        3      both fixed and indexable fields (all containing pointers)
        4      both fixed and indexable weak fields (all containing pointers).

        5      unused
        6      indexable word fields only (no pointers)
        7      indexable long (64-bit) fields (only in 64-bit images)
 
    8-11      indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size)
   12-15     compiled methods:
                   # of literal oops specified in method header,
                   followed by indexable bytes (same interpretation of low 2 bits as above)
"

	^ ((self baseHeader: oop) >> 8) bitAnd: 16rF! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'tpr 3/24/2004 22:02'!
fullCompaction
	"Move all accessible objects down to leave one big free chunk 
	at the end of memory."
	"Assume: Incremental GC has just been done to maximimize 
	forwarding table space."
	"need not move objects below the first free chunk"
	| sz |
	compStart := self lowestFreeAfter: self startOfMemory.
	compStart = freeBlock
		ifTrue: ["memory is already compact; only free chunk is at the end "
			^ self initializeMemoryFirstFree: freeBlock].
	(sz := self fwdTableSize: 8) < totalObjectCount
		ifTrue: ["Try to grow OM to make a single pass full GC"
			self growObjectMemory: totalObjectCount - sz + 10000 * 8].
	"work up through memory until all free space is at the end"
	[compStart < freeBlock]
		whileTrue: ["free chunk returned by incCompBody becomes start of next compaction"
			compStart := self incCompBody]! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'JMM (auto pragmas dtl 2010-09-26) 3/28/2010 16:51'!
fullGC
	"Do a mark/sweep garbage collection of the entire object memory. Free inaccessible objects but do not move them."

	| startTime |
	<inline: false>
	<var: #startTime type: 'sqLong'>
	DoAssertionChecks ifTrue: [self reverseDisplayFrom: 0 to: 7].
	self preGCAction: true.
	startTime := self ioMicroSecondClock.
	statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
	self clearRootsTable.
	youngStart := self startOfMemory.  "process all of memory"
	self markPhase.
	"Sweep phase returns the number of survivors.
	Use the up-to-date version instead the one from startup."
	totalObjectCount := self sweepPhase.
	self fullCompaction.
	allocationCount := 0.
	statFullGCs := statFullGCs + 1.
	statGCTime := self ioMicroSecondClock.
	statFullGCMSecs := statFullGCMSecs + (statGCTime - startTime).
	self capturePendingFinalizationSignals.

	youngStart := freeBlock.  "reset the young object boundary"
	self postGCAction.
	DoAssertionChecks ifTrue: [self reverseDisplayFrom: 0 to: 7].
! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 14:09'!
fwdBlockGet: blkSize
	"Return the address of a two- or four-word forwarding block or nil if no more entries are available."

	fwdTableNext := fwdTableNext + blkSize.
	fwdTableNext <= fwdTableLast
		ifTrue: [ ^ fwdTableNext ]
		ifFalse: [ ^ nil ].  "no more forwarding blocks available"! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl 4/22/2007 20:36'!
fwdBlockValidate: addr 
	"Raise an error if the given address is not a valid forward table entry."
	((self oop: addr isGreaterThan: endOfMemory)
			and: [(self oop: addr isLessThanOrEqualTo: fwdTableNext)
					and: [(addr bitAnd: 3) = 0]])
		ifFalse: [self error: 'invalid fwd table entry']! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 10:28'!
fwdTableInit: blkSize
	"Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available."

	| |
	<inline: false>
	"set endOfMemory to just after a minimum-sized free block"
	self setSizeOfFree: freeBlock to: self baseHeaderSize.
	endOfMemory := freeBlock + self baseHeaderSize.

	"make a fake free chunk at endOfMemory for use as a sentinal in memory scans"
	self setSizeOfFree: endOfMemory to: self baseHeaderSize.

	"use all memory free between freeBlock and memoryLimit for forwarding table"
	"Note: Forward blocks must be quadword aligned."
	fwdTableNext := (endOfMemory + self baseHeaderSize + 7) bitAnd: self wordMask - 7.
	self flag: #Dan.  "Above line does not do what it says (quadword is 16 or 32 bytes)"

	fwdTableLast := memoryLimit - blkSize.  "last forwarding table entry"

	"return the number of forwarding blocks available"
	^ (fwdTableLast - fwdTableNext) // blkSize  "round down"! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 10:28'!
fwdTableSize: blkSize
	"Estimate the number of forwarding blocks available for compaction"
	| eom fwdFirst fwdLast |
	<inline: false>

	eom := freeBlock + self baseHeaderSize.
	"use all memory free between freeBlock and memoryLimit for forwarding table"

	"Note: Forward blocks must be quadword aligned."
	fwdFirst := (eom + self baseHeaderSize + 7) bitAnd: self wordMask - 7.
	self flag: #Dan.  "Above line does not do what it says (quadword is 16 or 32 bytes)"

	fwdLast := memoryLimit - blkSize.  "last forwarding table entry"

	"return the number of forwarding blocks available"
	^ (fwdLast - fwdFirst) // blkSize  "round down"! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl (auto pragmas dtl 2010-09-26) 10/18/2009 12:50'!
growObjectMemory: delta 
	"Attempt to grow the object memory by the given delta 
	amount "
	| limit |
	<var: #delta type: 'usqInt'>
	<var: #limit type: 'usqInt'>
	(self isExcessiveAllocationRequest: delta shift: 0) ifFalse: [
		statGrowMemory := statGrowMemory + 1.
		limit := self sqGrowMemory: memoryLimit By: delta.
		limit = memoryLimit
			ifFalse: [memoryLimit := limit - 24.
				"remove a tad for safety"
				self initializeMemoryFirstFree: freeBlock]]! !
!ObjectMemory methodsFor: 'header access'!
hashBitsOf: oop

	^ ((self baseHeader: oop) >> 17) bitAnd: 16rFFF! !
!ObjectMemory methodsFor: 'header access'!
headerType: oop

	^ (self longAt: oop) bitAnd: TypeMask! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:13'!
incCompBody
	"Move objects to consolidate free space into one big chunk. Return the newly created free chunk."

	| bytesFreed |
	<inline: false>
	"reserve memory for forwarding table"
	self fwdTableInit: self bytesPerWord * 2.  "Two-word blocks"

	"assign new oop locations, reverse their headers, and initialize forwarding blocks"
	bytesFreed := self incCompMakeFwd.

	"update pointers to point at new oops"
	self mapPointersInObjectsFrom: youngStart to: endOfMemory.

	"move the objects and restore their original headers; return the new free chunk"
	^ self incCompMove: bytesFreed! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:13'!
incCompMakeFwd
	"Create and initialize forwarding blocks for all non-free objects  
	following compStart. If the supply of forwarding blocks is exhausted,  
	set compEnd to the first chunk above the area to be 
	compacted; otherwise, set it to endOfMemory. Return the number of 
	bytes to be freed."
	| bytesFreed oop fwdBlock newOop |
	<inline: false>
	bytesFreed := 0.
	oop := self oopFromChunk: compStart.
	[self oop: oop isLessThan: endOfMemory]
		whileTrue: [
				statMkFwdCount := statMkFwdCount + 1.
				(self isFreeObject: oop)
				ifTrue: [bytesFreed := bytesFreed + (self sizeOfFree: oop)]
				ifFalse: ["create a forwarding block for oop"
					fwdBlock := self fwdBlockGet: self bytesPerWord * 2.
					"Two-word block"
					fwdBlock = nil
						ifTrue: ["stop; we have used all available forwarding blocks"
							compEnd := self chunkFromOop: oop.
							^ bytesFreed].
					newOop := oop - bytesFreed.
					self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false].
			oop := self objectAfterWhileForwarding: oop].
	compEnd := endOfMemory.
	^ bytesFreed! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:32'!
incCompMove: bytesFreed 
	"Move all non-free objects between compStart and compEnd to their new  
	locations, restoring their headers in the process. Create a new free  
	block at the end of memory. Return the newly created free chunk. "
	"Note: The free block used by the allocator always must be the last free  
	block in memory. It may take several compaction passes to make all  
	free space bubble up to the end of memory."
	| oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz target |
	<inline: false>
	<var: #firstWord type: 'usqInt'>
	<var: #lastWord type: 'usqInt'>
	<var: #w type: 'usqInt'>
	newOop := nil.
	oop := self oopFromChunk: compStart.
	[self oop: oop isLessThan: compEnd]
		whileTrue: [statCompMoveCount := statCompMoveCount + 1.
			next := self objectAfterWhileForwarding: oop.
			(self isFreeObject: oop)
				ifFalse: ["a moving object; unwind its forwarding block"
					fwdBlock := ((self longAt: oop) bitAnd: self allButMarkBitAndTypeMask) << 1.
					DoAssertionChecks
						ifTrue: [self fwdBlockValidate: fwdBlock].
					newOop := self longAt: fwdBlock.
					header := self longAt: fwdBlock + self bytesPerWord.
					self longAt: oop put: header. "restore the original header"
					bytesToMove := oop - newOop. "move the oop (including any extra header words) "
					sz := self sizeBitsOf: oop.
					firstWord := oop - (self extraHeaderBytes: oop).
					lastWord := oop + sz - self baseHeaderSize.
					target := firstWord - bytesToMove.
					firstWord to: lastWord by: self bytesPerWord
						do: [:w | 
							self longAt: target put: (self longAt: w).
							target := target + self bytesPerWord]].
			oop := next].
	newOop = nil
		ifTrue: ["no objects moved"
			oop := self oopFromChunk: compStart.
			((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)])
				ifTrue: [newFreeChunk := oop]
				ifFalse: [newFreeChunk := freeBlock]]
		ifFalse: ["initialize the newly freed memory chunk"
			"newOop is the last object moved; free chunk starts 
			right after it"
			newFreeChunk := newOop + (self sizeBitsOf: newOop).
			self setSizeOfFree: newFreeChunk to: bytesFreed].
	DoAssertionChecks
		ifTrue: [(self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd)
				ifFalse: [self error: 'problem creating free chunk after compaction']].
	(self objectAfter: newFreeChunk) = endOfMemory
		ifTrue: [self initializeMemoryFirstFree: newFreeChunk]
		ifFalse: ["newFreeChunk is not at end of memory; re-install freeBlock "
			self initializeMemoryFirstFree: freeBlock].
	^ newFreeChunk! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'tpr 3/24/2004 22:03'!
incrementalCompaction
	"Move objects down to make one big free chunk. Compact the 
	last N objects (where N = number of forwarding table 
	entries) of the young object area."
	"Assume: compStart was set during the sweep phase"
	compStart = freeBlock
		ifTrue: ["Note: If compStart = freeBlock then either the young 
			space is already compact  or there are enough forwarding table entries to do a 
			one-pass incr. compaction."
			self initializeMemoryFirstFree: freeBlock]
		ifFalse: [self incCompBody]! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'JMM (auto pragmas dtl 2010-09-26) 3/28/2010 16:51'!
incrementalGC
	"Do a mark/sweep garbage collection of just the young object 
	area of object memory (i.e., objects above youngStart), using 
	the root table to identify objects containing pointers to 
	young objects from the old object area."
	| survivorCount startTime weDidGrow |
	<inline: false>
	<var: #startTime type: 'sqLong'>
	rootTableCount >= RootTableSize
		ifTrue: ["root table overflow; cannot do an incremental GC (this should be very rare)"
			statRootTableOverflows := statRootTableOverflows + 1.
			^ self fullGC].
	DoAssertionChecks
		ifTrue: [self reverseDisplayFrom: 8 to: 15.
			self validateRoots; validate].

	self preGCAction: false.
	"incremental GC and compaction"

	startTime := self ioMicroSecondClock.
	weakRootCount := 0.
	statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
	self markPhase.
	1 to: weakRootCount do:[:i| self finalizeReference: (weakRoots at: i)].
	survivorCount := self sweepPhase.
	self incrementalCompaction.
	statAllocationCount := allocationCount.
	allocationCount := 0.
	statIncrGCs := statIncrGCs + 1.
	statGCTime := self ioMicroSecondClock.
	statIGCDeltaTime := statGCTime - startTime.
	statIncrGCMSecs := statIncrGCMSecs + statIGCDeltaTime.
	self capturePendingFinalizationSignals.

	self forceInterruptCheck. "Force an an interrupt check ASAP.We could choose to be clever here and only do this under certain time conditions. Keep it simple for now"
	
	statRootTableCount  := rootTableCount.
	statSurvivorCount := survivorCount.
	weDidGrow := false.
	(((survivorCount > tenuringThreshold)
			or: [rootTableCount >= RootTableRedZone])
			or: [forceTenureFlag == true])
		ifTrue: ["move up the young space boundary if 
			* there are too many survivors: 
			this limits the number of objects that must be 
			processed on future incremental GC's 
			* we're about to overflow the roots table 
			this limits the number of full GCs that may be caused 
			by root table overflows in the near future"
			forceTenureFlag := false.
			statTenures := statTenures + 1.
			self clearRootsTable.
			(freeBlock < growHeadroom and: 
				[gcBiasToGrow > 0]) 
				ifTrue: [self biasToGrow.
						weDidGrow := true].
			youngStart := freeBlock].
	self postGCAction.
	DoAssertionChecks
		ifTrue: [self validateRoots; validate.
			self reverseDisplayFrom: 8 to: 15].
	weDidGrow ifTrue: [self biasToGrowCheckGCLimit]! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 12:31'!
initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag 
	"Initialize the given forwarding block to map oop to newOop, 
	and replace oop's header with a pointer to the fowarding 
	block. "
	"Details: The mark bit is used to indicate that an oop is 
	forwarded. When an oop is forwarded, its header (minus the 
	mark bit) contains the address of its forwarding block. (The 
	forwarding block address is actually shifted right by one bit 
	so that its top-most bit does not conflict with the header's 
	mark bit; since fowarding blocks are stored on word 
	boundaries, the low two bits of the address are always zero.) 
	The first word of the forwarding block is the new oop; the 
	second word is the oop's orginal header. In the case of a 
	forward become, a four-word block is used, with the third 
	field being a backpointer to the old oop (for header fixup), 
	and the fourth word is unused. The type bits of the 
	forwarding header are the same as those of the original 
	header. "
	| originalHeader originalHeaderType |
	<inline: true>
	originalHeader := self longAt: oop.
	DoAssertionChecks
		ifTrue: [fwdBlock = nil ifTrue: [self error: 'ran out of forwarding blocks in become'].
			(originalHeader bitAnd: self markBit) ~= 0
				ifTrue: [self error: 'object already has a forwarding table entry']].
	originalHeaderType := originalHeader bitAnd: TypeMask.
	self longAt: fwdBlock put: newOop.
	self longAt: fwdBlock + self bytesPerWord put: originalHeader.
	backFlag ifTrue: [self longAt: fwdBlock + (self bytesPerWord * 2) put: oop].
	self longAt: oop put: (fwdBlock >> 1 bitOr: (self markBit bitOr: originalHeaderType))! !
!ObjectMemory methodsFor: 'object enumeration' stamp: 'tpr 3/24/2004 21:54'!
initialInstanceOf: classPointer 
	"Support for instance enumeration. Return the first instance 
	of the given class, or nilObj if it has no instances."
	| thisObj thisClass |
	thisObj := self firstAccessibleObject.
	[thisObj = nil]
		whileFalse: [thisClass := self fetchClassOf: thisObj.
			thisClass = classPointer ifTrue: [^ thisObj].
			thisObj := self accessibleObjectAfter: thisObj].
	^ nilObj! !
!ObjectMemory methodsFor: 'initialization' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 10:28'!
initializeMemoryFirstFree: firstFree 
	"Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans. "
	"Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks). 
	di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means an absolute worst case of 8 passes to compact memory. In most cases it will be adequate to do compaction in a single pass. "
	| fwdBlockBytes |
	<var: #firstFree type: 'usqInt'>
	<var: #fwdBlockBytes type: 'usqInt'>
	"reserve space for forwarding blocks"
	fwdBlockBytes := totalObjectCount bitAnd: self wordMask - self bytesPerWord + 1.
	(self oop: memoryLimit - fwdBlockBytes isGreaterThanOrEqualTo: firstFree + self baseHeaderSize)
		ifFalse: ["reserve enough space for a minimal free block of BaseHeaderSize bytes"
			fwdBlockBytes := memoryLimit - (firstFree + self baseHeaderSize)].

	"set endOfMemory and initialize freeBlock"
	endOfMemory := memoryLimit - fwdBlockBytes.
	freeBlock := firstFree.
	self setSizeOfFree: freeBlock to: endOfMemory - firstFree. "bytes available for oops"

	"make a fake free chunk at endOfMemory for use as a sentinel in memory scans"
	self setSizeOfFree: endOfMemory to: self baseHeaderSize.
	DoAssertionChecks
		ifTrue: [(freeBlock < endOfMemory and: [endOfMemory < memoryLimit])
				ifFalse: [self error: 'error in free space computation'].
			(self oopFromChunk: endOfMemory) = endOfMemory
				ifFalse: [self error: 'header format must have changed'].
			(self objectAfter: freeBlock) = endOfMemory
				ifFalse: [self error: 'free block not properly initialized']]! !
!ObjectMemory methodsFor: 'initialization' stamp: 'ar (auto pragmas dtl 2010-09-26) 6/8/2006 12:34'!
initializeObjectMemory: bytesToShift
	"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
	"Assume: image reader initializes the following variables:
		memory
		endOfMemory
		memoryLimit
		specialObjectsOop
		lastHash
	"
	"di 11/18/2000 fix slow full GC"
	<inline: false>

	"set the start of the young object space"
	youngStart := endOfMemory.

	"image may be at a different address; adjust oops for new location"
	totalObjectCount := self adjustAllOopsBy: bytesToShift.

	self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeBlock"

	specialObjectsOop := specialObjectsOop + bytesToShift.

	"heavily used special objects"
	nilObj	:= self splObj: NilObject.
	falseObj	:= self splObj: FalseObject.
	trueObj	:= self splObj: TrueObject.

	rootTableCount := 0.
	freeContexts := NilContext.
	freeLargeContexts := NilContext.
	allocationCount := 0.
	lowSpaceThreshold := 0.
	signalLowSpace := false.
	compStart := 0.
	compEnd := 0.
	fwdTableNext := 0.
	fwdTableLast := 0.
	remapBufferCount := 0.
	allocationsBetweenGCs := 4000.  "do incremental GC after this many allocations"
	tenuringThreshold := 2000.  "tenure all suriving objects if count is over this threshold"
	growHeadroom := 4*1024*1024. "four megabyte of headroom when growing"
	shrinkThreshold := 8*1024*1024. "eight megabyte of free space before shrinking"

	"garbage collection statistics"
	statFullGCs := 0.
	statFullGCMSecs := 0.
	statIncrGCs := 0.
	statIncrGCMSecs := 0.
	statTenures := 0.
	statRootTableOverflows := 0.
	statGrowMemory := 0.
	statShrinkMemory := 0.
	forceTenureFlag := 0.
	gcBiasToGrow := 0.
	gcBiasToGrowGCLimit := 0.
	extraRootCount := 0.
! !
!ObjectMemory methodsFor: 'object enumeration' stamp: 'tpr 3/24/2004 21:54'!
instanceAfter: objectPointer 
	"Support for instance enumeration. Return the next instance 
	of the class of the given object, or nilObj if the enumeration 
	is complete."
	| classPointer thisObj thisClass |
	classPointer := self fetchClassOf: objectPointer.
	thisObj := self accessibleObjectAfter: objectPointer.
	[thisObj = nil]
		whileFalse: [thisClass := self fetchClassOf: thisObj.
			thisClass = classPointer ifTrue: [^ thisObj].
			thisObj := self accessibleObjectAfter: thisObj].
	^ nilObj! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 12:14'!
instantiateClass: classPointer indexableSize: size 
	"NOTE: This method supports the backward-compatible split instSize field of the 
	class format word. The sizeHiBits will go away and other shifts change by 2 
	when the split fields get merged in an (incompatible) image change."

	| hash header1 header2 cClass byteSize format binc header3 hdrSize fillWord newObj sizeHiBits bm1 classFormat |
	<inline: false>
	DoAssertionChecks ifTrue: [size < 0
				ifTrue: [self error: 'cannot have a negative indexable field count']].
	hash := self newObjectHash.
	classFormat := self formatOfClass: classPointer.
	"Low 2 bits are 0"
	header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash << HashBitsOffset bitAnd: HashBits).
	header2 := classPointer.
	header3 := 0.
	sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
	cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
	byteSize := (classFormat bitAnd: self sizeMask + self size4Bit) + sizeHiBits.
		"size in bytes -- low 2 bits are 0"
	"Note this byteSize comes from the format word of the class which is pre-shifted
		to 4 bytes per field.  Need another shift for 8 bytes per word..."
	byteSize := byteSize << (self shiftForWord - 2).
	format := classFormat >> 8 bitAnd: 15.
	self flag: #sizeLowBits.
	format < 8
		ifTrue:
			[format = 6
				ifTrue: ["long32 bitmaps"
					bm1 := self bytesPerWord - 1.
					byteSize := byteSize + (size * 4) + bm1 bitAnd: self longSizeMask. "round up"
					binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
					"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
					header1 := header1 bitOr: (binc bitAnd: 4)]
				ifFalse: [byteSize := byteSize + (size * self bytesPerWord) "Arrays and 64-bit bitmaps"]
			]
		ifFalse:
			["Strings and Methods"
			bm1 := self bytesPerWord - 1.
			byteSize := byteSize + size + bm1 bitAnd: self longSizeMask. "round up"
			binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
			"low bits of byte size go in format field"
			header1 := header1 bitOr: (binc bitAnd: 3) << 8.
			"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
			header1 := header1 bitOr: (binc bitAnd: 4)].
	byteSize > 255
		ifTrue: ["requires size header word"
			header3 := byteSize.
			header1 := header1]
		ifFalse: [header1 := header1 bitOr: byteSize].
	header3 > 0
		ifTrue: ["requires full header"
			hdrSize := 3]
		ifFalse: [cClass = 0
				ifTrue: [hdrSize := 2]
				ifFalse: [hdrSize := 1]].
	format <= 4
		ifTrue: ["if pointers, fill with nil oop"
			fillWord := nilObj]
		ifFalse: [fillWord := 0].
	newObj := self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true with: fillWord.
	^ newObj! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/19/2010 11:41'!
instantiateContext: classPointer sizeInBytes: sizeInBytes 
	"This version of instantiateClass assumes that the total object 
	size is under 256 bytes, the limit for objects with only one or 
	two header words. Note that the size is specified in bytes 
	and should include four bytes for the base header word."
	| hash header1 header2 hdrSize |
	hash := self newObjectHash.
	header1 := (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer).
	header2 := classPointer.
	(header1 bitAnd: CompactClassMask) > 0 "are contexts compact?"
		ifTrue: [hdrSize := 1]
		ifFalse: [hdrSize := 2].
	sizeInBytes <= self sizeMask
		ifTrue: ["OR size into header1.  Must not do this if size > SizeMask"
				header1 := header1 + (sizeInBytes - (header1 bitAnd: self sizeMask))]
		ifFalse: [hdrSize := 3.
				"Zero the size field of header1 if large"
				header1 := header1 - (header1 bitAnd: self sizeMask)].
self flag: #Dan.  "Check details of context sizes"
	^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: self largeContextSize doFill: false with: 0! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/19/2010 12:14'!
instantiateSmallClass: classPointer sizeInBytes: sizeInBytes
	"This version of instantiateClass assumes that the total object 
	size is under 256 bytes, the limit for objects with only one or 
	two header words. Note that the size is specified in bytes 
	and should include 4 or 8 bytes for the base header word. 
	NOTE this code will only work for sizes that are an integral number of words
		(like not a 32-bit LargeInteger in a 64-bit system). 
	May cause a GC.
	Note that the created small object IS NOT FILLED and must be completed before returning it to Squeak. Since this call is used in routines that do jsut that we are safe. Break this rule and die."

	| hash header1 header2 hdrSize |
	(sizeInBytes bitAnd: (self bytesPerWord - 1)) = 0 ifFalse:
		[self error: 'size must be integral number of words'].
	hash := self newObjectHash.
	header1 := (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer).
	header2 := classPointer.
	(header1 bitAnd: CompactClassMask) > 0 "is this a compact class"
		ifTrue: [hdrSize := 1]
		ifFalse: [hdrSize := 2].
	header1 := header1 + (sizeInBytes - (header1 bitAnd: self sizeMask + self size4Bit)).
	^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: false with: 0! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 8/4/2004 15:32'!
integerObjectOf: value

	^(value << 1) + 1! !
!ObjectMemory methodsFor: 'interpreter access'!
integerValueOf: objectPointer
	"Translator produces 'objectPointer >> 1'"

	((objectPointer bitAnd: 16r80000000) ~= 0)
		ifTrue: ["negative"
				^ ((objectPointer bitAnd: 16r7FFFFFFF) >> 1)
					- 16r3FFFFFFF - 1  "Faster than -16r40000000 (a LgInt)"]
		ifFalse: ["positive"
				^ objectPointer >> 1]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 12/5/2003 20:01'!
isArray: oop
	"Answer true if this is an indexable object with pointer elements, e.g., an array"
	^(self isNonIntegerObject: oop) and:[self isArrayNonInt: oop]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 12/5/2003 20:02'!
isArrayNonInt: oop
	"Answer true if this is an indexable object with pointer elements, e.g., an array"
	^ (self formatOf: oop) = 2! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:09'!
isBytes: oop
	"Answer true if the argument contains indexable bytes. See comment in formatOf:"
	"Note: Includes CompiledMethods."
	^(self isNonIntegerObject: oop) and:[self isBytesNonInt: oop]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:05'!
isBytesNonInt: oop
	"Answer true if the argument contains indexable bytes. See comment in formatOf:"
	"Note: Includes CompiledMethods."

	^ (self formatOf: oop)  >= 8! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'eem 9/26/2010 11:03'!
isCompiledMethod: oop
    "Answer whether the argument object is of compiled method format"
    ^(self formatOf: oop) >= 12! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl 10/31/2010 16:29'!
isExcessiveAllocationRequest: size shift: bits

	"Answer true if size is greater than (((2 raisedTo: 31) - 1) >> bits). Used
	to limit size of allocation requests to 31 bit integer maximum to prevent
	arithmetic overflow in subsequent calculations. Always answers false
	in interpreter simulation.
	
	In the case of a 64-bit object memory running on a 64-bit host platform,
	allow larger allocation requests.

	Assumes that sizeof(int) is 4 for all platforms."

	| int32 int64 shiftCount |
	<inline: true>
	<var: #int32 type: 'int'> "32 bit signed integer"

	self isDefined: 'SQ_IMAGE64'
		inSmalltalk: [^false]
		comment: 'a 64-bit object memory word size'
		ifTrue: [self isDefined: 'SQ_HOST64'
				inSmalltalk: []
				comment: 'running on a 64-bit host platform'
				ifTrue: ["use 64 bit check if both image and host are 64 bits"
					int64 := size.
					shiftCount := 0.
					int64 < 0 ifTrue: [^ true].
					[shiftCount < bits]
						whileTrue: [int64 := int64 << 1.
							int64 < 0 ifTrue: [^ true].
							shiftCount := shiftCount +1].
					^false]
				ifFalse: ["if sqInt is 64 bit, size parameter may overflow int32"
					size > 16rFFFFFFFF ifTrue: [^false]]]
		ifFalse: ["common case of 32 bit image on either 32 or 64 bit host"
				int32 := size.
				shiftCount := 0.
				int32 < 0 ifTrue: [^ true].
				[shiftCount < bits]
					whileTrue: [int32 := int32 << 1.
						int32 < 0 ifTrue: [^ true].
						shiftCount := shiftCount +1].
				^false]
! !
!ObjectMemory methodsFor: 'header access'!
isFreeObject: oop

	^ (self headerType: oop) = HeaderTypeFree! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'dtl 4/22/2007 20:06'!
isInMemory: address 
	"Return true if the given address is in ST object memory"
	^ (self oop: address isGreaterThanOrEqualTo: self startOfMemory)
		and: [self oop: address isLessThan: endOfMemory]! !
!ObjectMemory methodsFor: 'interpreter access'!
isIntegerObject: objectPointer

	^ (objectPointer bitAnd: 1) > 0! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 11/13/2006 12:55'!
isIntegerValue: intValue
	"Return true if the given value can be represented as a Smalltalk integer value."
	"Use a shift and XOR to set the sign bit if and only if the top two bits of the given
	value are the same, then test the sign bit. Note that the top two bits are equal for
	exactly those integers in the range that can be represented in 31-bits or 63-bits.

	Operands are coerced to machine integer size so the test will work with 64 bit
	images on 32 bit hosts. When running on a 32 bit host, the cast to int has little
	or no performance impact for either 32 bit or 64 bit images.

	On a 64 bit host, the shift and XOR test is replaced by an explicit range check,
	which provides the best performance for both 32 bit and 64 bit images.

	If the range of small integers is enlarged for 64 bit images, this method must
	be updated accordingly."

	^ self isDefined: 'SQ_HOST32'
		inSmalltalk: [true]
		comment: 'cast to int for 64 bit image on 32 bit host'
		ifTrue: ((self cCoerce: intValue to: 'int')
					bitXor: ((self cCoerce: intValue to: 'int') << 1)) >= 0
		ifFalse: (intValue >= 16r-40000000 and: [intValue <= 16r3FFFFFFF])! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'ar 11/16/2003 01:07'!
isNonIntegerObject: objectPointer

	^ (objectPointer bitAnd: 1) = 0! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl 5/19/2010 12:31'!
isObjectForwarded: oop 
	"Return true if the given object has a forwarding table entry 
	during a compaction or become operation."
	^ (oop bitAnd: 1) = 0 and: ["(isIntegerObject: oop) not" ((self longAt: oop) bitAnd: self markBit) ~= 0]! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'eem 9/26/2010 11:03'!
isOopCompiledMethod: oop
    "Answer whether the oop is an object of compiled method format"
	<api>
    ^(self isNonIntegerObject: oop) and: [(self formatOf: oop) >= 12]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:08'!
isPointers: oop
	"Answer true if the argument has only fields that can hold oops. See comment in formatOf:"

	^(self isNonIntegerObject: oop) and:[self isPointersNonInt: oop]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:05'!
isPointersNonInt: oop
	"Answer true if the argument has only fields that can hold oops. See comment in formatOf:"

	^ (self formatOf: oop) <= 4! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:09'!
isWeak: oop
	"Answer true if the argument has only weak fields that can hold oops. See comment in formatOf:"
	^(self isNonIntegerObject: oop) and:[self isWeakNonInt: oop]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:05'!
isWeakNonInt: oop
	"Answer true if the argument has only weak fields that can hold oops. See comment in formatOf:"
	^ (self formatOf: oop) = 4! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:09'!
isWords: oop
	"Answer true if the argument contains only indexable words (no oops). See comment in formatOf:"

	^(self isNonIntegerObject: oop) and:[self isWordsNonInt: oop]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:05'!
isWordsNonInt: oop
	"Answer true if the argument contains only indexable words (no oops). See comment in formatOf:"

	^ (self formatOf: oop) = 6! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:09'!
isWordsOrBytes: oop
	"Answer true if the contains only indexable words or bytes (no oops). See comment in formatOf:"
	"Note: Excludes CompiledMethods."
	^(self isNonIntegerObject: oop) and:[self isWordsOrBytesNonInt: oop]! !
!ObjectMemory methodsFor: 'header access' stamp: 'ar 11/16/2003 01:06'!
isWordsOrBytesNonInt: oop
	"Answer true if the contains only indexable words or bytes (no oops). See comment in formatOf:"
	"Note: Excludes CompiledMethods."

	| fmt |
	fmt := self formatOf: oop.
	^ fmt = 6 or: [(fmt >= 8) and: [fmt <= 11]]! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:20'!
largeContextSize
	"Large contexts have 56 indexable fields.  Max with single header word.
	However note that in 64 bits, for now, large contexts have 3-word headers"

	<inline: true>
	^self
		cCode: 'LARGE_CONTEXT_SIZE'
		inSmalltalk: [ContextFixedSizePlusHeader + 56 * self bytesPerWord]
! !
!ObjectMemory methodsFor: 'object enumeration' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:50'!
lastPointerOf: oop 
	"Return the byte offset of the last pointer field of the given object.  
	Works with CompiledMethods, as well as ordinary objects. 
	Can be used even when the type bits are not correct."
	| fmt sz methodHeader header contextSize |
	<inline: true>
	header := self baseHeader: oop.
	fmt := header >> 8 bitAnd: 15.
	fmt <= 4 ifTrue: [(fmt = 3 and: [self isContextHeader: header])
					ifTrue: ["contexts end at the stack pointer"
						contextSize := self fetchStackPointerOf: oop.
						^ CtxtTempFrameStart + contextSize * self bytesPerWord].
				sz := self sizeBitsOfSafe: oop.
				^ sz - self baseHeaderSize  "all pointers"].
	fmt < 12 ifTrue: [^ 0]. "no pointers"

	"CompiledMethod: contains both pointers and bytes:"
	methodHeader := self longAt: oop + self baseHeaderSize.
	^ (methodHeader >> 10 bitAnd: 255) * self bytesPerWord + self baseHeaderSize! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:32'!
lastPointerWhileForwarding: oop 
	"The given object may have its header word in a forwarding block. Find  
	the offset of the last pointer in the object in spite of this obstacle. "
	| header fwdBlock fmt size methodHeader contextSize |
	<inline: true>
	header := self longAt: oop.
	(header bitAnd: self markBit) ~= 0
		ifTrue: ["oop is forwarded; get its real header from its forwarding table entry"
			fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1.
			DoAssertionChecks
				ifTrue: [self fwdBlockValidate: fwdBlock].
			header := self longAt: fwdBlock + self bytesPerWord].
	fmt := header >> 8 bitAnd: 15.
	fmt <= 4
		ifTrue: [(fmt = 3 and: [self isContextHeader: header])
				ifTrue: ["contexts end at the stack pointer"
					contextSize := self fetchStackPointerOf: oop.
					^ CtxtTempFrameStart + contextSize * self bytesPerWord].
			"do sizeBitsOf: using the header we obtained"
			(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
				ifTrue: [size := (self sizeHeader: oop) bitAnd: self allButTypeMask]
				ifFalse: [size := header bitAnd: self sizeMask].
			^ size - self baseHeaderSize].
	fmt < 12 ifTrue: [^ 0]. "no pointers"
	methodHeader := self longAt: oop + self baseHeaderSize.
	^ (methodHeader >> 10 bitAnd: 255) * self bytesPerWord + self baseHeaderSize! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:57'!
longSizeMask
	"One of the base header word bit fields. For 64-bit word size, lose
	the 4 bit in temp 64-bit chunk format."

	<inline: true>
	^self
		cCode: 'LONG_SIZE_MASK'
		inSmalltalk: [self wordMask - 16rFF + self sizeMask]
! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:02'!
lowestFreeAfter: chunk 
	"Return the first free block after the given chunk in memory."
	| oop oopHeader oopHeaderType oopSize |
	<inline: false>
	oop := self oopFromChunk: chunk.
	[self oop: oop isLessThan: endOfMemory]
		whileTrue: [oopHeader := self baseHeader: oop.
			oopHeaderType := oopHeader bitAnd: TypeMask.
			oopHeaderType = HeaderTypeFree
				ifTrue: [^ oop]
				ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
						ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: self allButTypeMask]
						ifFalse: [oopSize := oopHeader bitAnd: self sizeMask]].
			oop := self oopFromChunk: oop + oopSize].
	self error: 'expected to find at least one free object'! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'ar (auto pragmas 12/08) 6/8/2006 11:55'!
mapPointersInObjectsFrom: memStart to: memEnd
	"Use the forwarding table to update the pointers of all non-free objects in the given range of memory. Also remap pointers in root objects which may contains pointers into the given memory range, and don't forget to flush the method cache based on the range"
	| oop |
	<inline: false>
	self compilerMapHookFrom: memStart to: memEnd.
	"update interpreter variables"
	self mapInterpreterOops.
	1 to: extraRootCount do:[:i |
		oop := (extraRoots at: i) at: 0.
		(self isIntegerObject: oop) ifFalse:[(extraRoots at: i) at: 0 put: (self remap: oop)]].
	self flushMethodCacheFrom: memStart to: memEnd.
	self updatePointersInRootObjectsFrom: memStart to: memEnd.
	self updatePointersInRangeFrom: memStart to: memEnd.
! !
!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'dtl 5/19/2010 13:03'!
markAndTrace: oop
	"Mark all objects reachable from the given one.
	Trace from the given object even if it is old.
	Do not trace if it is already marked.
	Mark it only if it is a young object."
	"Tracer state variables:
		child		object being examined
		field		next field of child to examine
		parentField	field where child was stored in its referencing object"

	| header lastFieldOffset action statMarkCountLocal |
	header := self longAt: oop.
	(header bitAnd: self markBit) = 0 ifFalse: [^ 0  "already marked"].

	"record tracing status in object's header"
	header := (header bitAnd: self allButTypeMask) bitOr: HeaderTypeGC.
	(self oop: oop isGreaterThanOrEqualTo: youngStart)
		ifTrue: [ header := header bitOr: self markBit ].  "mark only if young"
	self longAt: oop put: header.

	"initialize the tracer state machine"
	parentField := GCTopMarker.
	child := oop.
	(self isWeakNonInt: oop) ifTrue: [
		"Set lastFieldOffset before the weak fields in the receiver"
		lastFieldOffset := (self nonWeakFieldsOf: oop) << self shiftForWord.
		"And remember as weak root"
		weakRootCount := weakRootCount + 1.
		weakRoots at: weakRootCount put: oop.
	] ifFalse: [
		"Do it the usual way"
		lastFieldOffset := self lastPointerOf: oop.
	].
	field := oop + lastFieldOffset.
	action := StartField.
	youngStartLocal := youngStart.
	statMarkCountLocal := statMarkCount.
	"run the tracer state machine until all objects reachable from oop are marked"
	[action = Done] whileFalse: [
		statMarkCountLocal := statMarkCountLocal + 1.
		action = StartField ifTrue: [ action := self startField ].
		action = StartObj ifTrue: [ action := self startObj ].
		action = Upward ifTrue: [ action := self upward ].
	].
	statMarkCount := statMarkCountLocal.! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:58'!
markBit
	"Top bit"

	<inline: true>
	^self
		cCode: 'MARK_BIT'
		inSmalltalk: [1 bitShift: self bytesPerWord*8 - 1]
! !
!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'ar (auto pragmas 12/08) 6/9/2006 14:56'!
markPhase
	"Mark phase of the mark and sweep garbage collector. Set 
	the mark bits of all reachable objects. Free chunks are 
	untouched by this process."
	"Assume: All non-free objects are initially unmarked. Root 
	objects were unmarked when they were made roots. (Make 
	sure this stays true!!!!)."
	| oop |
	<inline: false>
	"clear the recycled context lists"
	freeContexts := NilContext.
	freeLargeContexts := NilContext.
	"trace the interpreter's objects, including the active stack 
	and special objects array"
	self markAndTraceInterpreterOops.
	statSpecialMarkCount := statMarkCount.
	"trace the roots"
	1 to: rootTableCount do: [:i | 
			oop := rootTable at: i.
			self markAndTrace: oop].
	1 to: extraRootCount do:[:i|
			oop := (extraRoots at: i) at: 0.
			(self isIntegerObject: oop) ifFalse:[self markAndTrace: oop]].
! !
!ObjectMemory methodsFor: 'header access'!
newObjectHash
	"Answer a new 16-bit pseudo-random number for use as an identity hash."

	lastHash := 13849 + (27181 * lastHash) bitAnd: 65535.
	^ lastHash
! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'tpr 3/24/2004 12:57'!
nilObject
	"For access from BitBlt module"
	^ nilObj! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 12:38'!
noteAsRoot: oop headerLoc: headerLoc 
	"Record that the given oop in the old object area points to an 
	object in the young area. 
	HeaderLoc is usually = oop, but may be an addr in a 
	forwarding block."
	| header |
	<inline: true>
	header := self longAt: headerLoc.
	(header bitAnd: self rootBit) = 0
		ifTrue: ["record oop as root only if not already recorded"
			rootTableCount < RootTableRedZone
				ifTrue: ["record root if there is enough room in the roots 
					table "
					rootTableCount := rootTableCount + 1.
					rootTable at: rootTableCount put: oop.
					self longAt: headerLoc put: (header bitOr: self rootBit)]
				ifFalse: ["we're getting in the red zone"
					rootTableCount < RootTableSize
						ifTrue: ["but there's still space to record it"
							rootTableCount := rootTableCount + 1.
							rootTable at: rootTableCount put: oop.
							self longAt: headerLoc put: (header bitOr: self rootBit).
							"but force an IGC on the next allocation"
							allocationCount := allocationsBetweenGCs + 1]]]! !
!ObjectMemory methodsFor: 'object enumeration' stamp: 'dtl (auto pragmas dtl 2010-09-26) 4/22/2007 20:09'!
objectAfter: oop 
	"Return the object or free chunk immediately following the 
	given object or free chunk in memory. Return endOfMemory 
	when enumeration is complete."
	| sz |
	<inline: true>
	DoAssertionChecks
		ifTrue: [(self oop: oop isGreaterThanOrEqualTo:endOfMemory)
					ifTrue: [self error: 'no objects after the end of memory']].
	(self isFreeObject: oop)
		ifTrue: [sz := self sizeOfFree: oop]
		ifFalse: [sz := self sizeBitsOf: oop].
	^ self oopFromChunk: oop + sz! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:32'!
objectAfterWhileForwarding: oop
	"Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table."

	| header fwdBlock realHeader sz |
	<inline: true>
	header := self longAt: oop.
	(header bitAnd: self markBit) = 0 ifTrue: [ ^ self objectAfter: oop ].  "oop not forwarded"

	"Assume: mark bit cannot be set on a free chunk, so if we get here,
	 oop is not free and it has a forwarding table entry"

	fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1.
	DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
	realHeader := self longAt: fwdBlock + self bytesPerWord.
	"following code is like sizeBitsOf:"
	(realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ]
		ifFalse: [ sz := realHeader bitAnd: self sizeMask ].

	^ self oopFromChunk: (oop + sz)! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'tpr 6/7/2005 10:13'!
obsoleteDontUseThisFetchWord: fieldIndex ofObject: oop
	"This message is deprecated but supported for a while via a tweak to sqVirtualMachine.[ch] Use fetchLong32, fetchLong64 or fetchPointer instead for new code"

	^self fetchLong32: fieldIndex ofObject: oop! !
!ObjectMemory methodsFor: 'oop comparison' stamp: 'dtl 4/22/2007 16:01'!
oop: anOop isGreaterThan: otherOop
	"Compare two oop values, treating them as object memory locations.
	Use #cCoerce:to: to ensure comparison of unsigned magnitudes. This
	method will be inlined during C translation."

	^ (self cCoerce: anOop to: #usqInt)
		> (self cCoerce: otherOop to: #usqInt)! !
!ObjectMemory methodsFor: 'oop comparison' stamp: 'dtl 4/22/2007 18:15'!
oop: anOop isGreaterThanOrEqualTo: otherOop
	"Compare two oop values, treating them as object memory locations.
	Use #cCoerce:to: to ensure comparison of unsigned magnitudes. This
	method will be inlined during C translation."

	^ (self cCoerce: anOop to: #usqInt)
		>= (self cCoerce: otherOop to: #usqInt)! !
!ObjectMemory methodsFor: 'oop comparison' stamp: 'dtl 4/22/2007 16:01'!
oop: anOop isLessThan: otherOop
	"Compare two oop values, treating them as object memory locations.
	Use #cCoerce:to: to ensure comparison of unsigned magnitudes. This
	method will be inlined during C translation."

	^ (self cCoerce: anOop to: #usqInt)
		< (self cCoerce: otherOop to: #usqInt)! !
!ObjectMemory methodsFor: 'oop comparison' stamp: 'dtl 4/22/2007 18:15'!
oop: anOop isLessThanOrEqualTo: otherOop
	"Compare two oop values, treating them as object memory locations.
	Use #cCoerce:to: to ensure comparison of unsigned magnitudes. This
	method will be inlined during C translation."

	^ (self cCoerce: anOop to: #usqInt)
		<= (self cCoerce: otherOop to: #usqInt)! !
!ObjectMemory methodsFor: 'oop/chunk conversion' stamp: 'JMM 12/4/2002 19:56'!
oopFromChunk: chunk
	"Compute the oop of this chunk by adding its extra header bytes."

	^ chunk + (self extraHeaderBytes: chunk)! !
!ObjectMemory methodsFor: 'interpreter access'!
popRemappableOop
	"Pop and return the possibly remapped object from the remap buffer."

	| oop |
	oop := remapBuffer at: remapBufferCount.
	remapBufferCount := remapBufferCount - 1.
	^ oop! !
!ObjectMemory methodsFor: 'garbage collection' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 20:11'!
possibleRootStoreInto: oop value: valueObj 
	"oop is an old object. If valueObj is young, mark the object as a root."

	<inline: false>
	((self oop: valueObj isGreaterThanOrEqualTo: youngStart)
			and: [(self isIntegerObject: valueObj) not])
		ifTrue: ["Yes, valueObj is a young object"
				self noteAsRoot: oop headerLoc: oop]! !
!ObjectMemory methodsFor: 'become' stamp: 'dtl 5/18/2010 21:50'!
prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag 
	"Ensure that there are enough forwarding blocks to 
	accomodate this become, then prepare forwarding blocks for 
	the pointer swap. Return true if successful."
	"Details: Doing a GC might generate enough space for 
	forwarding blocks if we're short. However, this is an 
	uncommon enough case that it is better handled by primitive 
	fail code at the Smalltalk level."

	"Important note on multiple references to same object  - since the preparation of
	fwdBlocks is NOT idempotent we get VM crashes if the same object is referenced more
	than once in such a way as to require multiple fwdBlocks.
	oop1 forwardBecome: oop1 is ok since only a single fwdBlock is needed.
	oop1 become: oop1 would fail because the second fwdBlock woudl not have the actual object
	header but rather the mutated ref to the first fwdBlock.
	Further problems can arise with an array1 or array2 that refer multiply to the same 
	object. This would notbe expected input for programmer writen code but might arise from
	automatic usage such as in ImageSegment loading.
	To avoid the simple and rather common case of oop1 become*: oop1, we skip such pairs
	and simply avoid making fwdBlocks - it is redundant anyway"
	| entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize |
	entriesNeeded := (self lastPointerOf: array1) // self bytesPerWord. "need enough entries for all oops"
	"Note: Forward blocks must be quadword aligned - see fwdTableInit:."
	twoWayFlag
		ifTrue: ["Double the number of blocks for two-way become"
			entriesNeeded := entriesNeeded * 2.
			fwdBlkSize := self bytesPerWord * 2]
		ifFalse: ["One-way become needs backPointers in fwd blocks."
			fwdBlkSize := self bytesPerWord * 4].
	entriesAvailable := self fwdTableInit: fwdBlkSize.
	entriesAvailable < entriesNeeded
		ifTrue: [self initializeMemoryFirstFree: freeBlock.
			"re-initialize the free block"
			^ false].
	fieldOffset := self lastPointerOf: array1.
	[fieldOffset >= self baseHeaderSize]
		whileTrue: [oop1 := self longAt: array1 + fieldOffset.
			oop2 := self longAt: array2 + fieldOffset.
			"if oop1 == oop2, no need to do any work for this pair.
			May still be other entries in the arrays though so keep looking"
			oop1 = oop2
				ifFalse: [fwdBlock := self fwdBlockGet: fwdBlkSize.
					self
						initForwardBlock: fwdBlock
						mapping: oop1
						to: oop2
						withBackPtr: twoWayFlag not.
					twoWayFlag
						ifTrue: ["Second block maps oop2 back to oop1 for two-way become"
							fwdBlock := self fwdBlockGet: fwdBlkSize.
							self
								initForwardBlock: fwdBlock
								mapping: oop2
								to: oop1
								withBackPtr: twoWayFlag not]].
			fieldOffset := fieldOffset - self bytesPerWord].
	^ true! !
!ObjectMemory methodsFor: 'interpreter access'!
pushRemappableOop: oop
	"Record the given object in a the remap buffer. Objects in this buffer are remapped when a compaction occurs. This facility is used by the interpreter to ensure that objects in temporary variables are properly remapped."

	remapBuffer at: (remapBufferCount := remapBufferCount + 1) put: oop.! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 11:42'!
recycleContextIfPossible: cntxOop 
	"If possible, save the given context on a list of free contexts to 
	be recycled."
	"Note: The context is not marked free, so it can be reused 
	with minimal fuss. The recycled context lists are cleared at 
	every garbage collect."
	| header |
	<inline: true>
	"only recycle young contexts (which should be most of them)"
	(self oop: cntxOop isGreaterThanOrEqualTo: youngStart)
		ifTrue: [header := self baseHeader: cntxOop.
			(self isMethodContextHeader: header)
				ifTrue: ["It's a young context, alright."
					(header bitAnd: self sizeMask) = self smallContextSize
						ifTrue: ["Recycle small contexts"
							self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeContexts.
							freeContexts := cntxOop].
					(header bitAnd: self sizeMask) = self largeContextSize
						ifTrue: ["Recycle large contexts"
							self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeLargeContexts.
							freeLargeContexts := cntxOop]]]! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:32'!
remap: oop 
	"Map the given oop to its new value during a compaction or 
	become: operation. If it has no forwarding table entry, 
	return the oop itself."
	| fwdBlock |
	<inline: false>
	(self isObjectForwarded: oop)
		ifTrue: ["get the new value for oop from its forwarding block"
			fwdBlock := ((self longAt: oop) bitAnd: self allButMarkBitAndTypeMask) << 1.
			DoAssertionChecks
				ifTrue: [self fwdBlockValidate: fwdBlock].
			^ self longAt: fwdBlock].
	^ oop! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl 5/19/2010 13:32'!
remapClassOf: oop 
	"Update the class of the given object, if necessary, using its forwarding table entry."
	"Note: Compact classes need not be remapped since the compact class field is just an index into the compact class 
	table. The header type bits show if this object has a compact class; we needn't look up the oop's real header."
	| classHeader classOop fwdBlock newClassOop newClassHeader |
	(self headerType: oop) = HeaderTypeShort ifTrue: [^ nil]. "compact classes needn't be mapped"

	classHeader := self longAt: oop - self bytesPerWord.
	classOop := classHeader bitAnd: self allButTypeMask.
	(self isObjectForwarded: classOop)
		ifTrue: [fwdBlock := ((self longAt: classOop) bitAnd: self allButMarkBitAndTypeMask) << 1.
			DoAssertionChecks
				ifTrue: [self fwdBlockValidate: fwdBlock].
			newClassOop := self longAt: fwdBlock.
			newClassHeader := newClassOop bitOr: (classHeader bitAnd: TypeMask).
			self longAt: oop - self bytesPerWord put: newClassHeader.
			"The following ensures that become: into an old object's class makes it a root. 
			It does nothing during either incremental or full compaction because 
			oop will never be < youngStart."
			((self oop: oop isLessThan: youngStart)
					and: [self oop: newClassOop isGreaterThanOrEqualTo: youngStart])
				ifTrue: [self beRootWhileForwarding: oop]]! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:32'!
remapFieldsAndClassOf: oop 
	"Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if 
	necessary. "
	"Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry."
	| fieldOffset fieldOop fwdBlock newOop |
	<inline: true>
	fieldOffset := self lastPointerWhileForwarding: oop.
	[fieldOffset >= self baseHeaderSize]
		whileTrue: [fieldOop := self longAt: oop + fieldOffset.
			(self isObjectForwarded: fieldOop)
				ifTrue: ["update this oop from its forwarding block"
					fwdBlock := ((self longAt: fieldOop) bitAnd: self allButMarkBitAndTypeMask) << 1.
					DoAssertionChecks
						ifTrue: [self fwdBlockValidate: fwdBlock].
					newOop := self longAt: fwdBlock.
					self longAt: oop + fieldOffset put: newOop.
					"The following ensures that become: into old object makes it a root. 
					It does nothing during either incremental or full compaction because 
					oop will never be < youngStart."
					((self oop: oop isLessThan: youngStart)
							and: [self oop: newOop isGreaterThanOrEqualTo: youngStart])
						ifTrue: [self beRootWhileForwarding: oop]].
			fieldOffset := fieldOffset - self bytesPerWord].
	self remapClassOf: oop! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar (auto pragmas dtl 2010-09-26) 6/8/2006 13:06'!
removeGCRoot: varLoc
	"Remove the given variable location to the extra roots table"
	| root |
	<export: true>
	<var: #varLoc declareC: 'sqInt *varLoc'>
	<var: #root declareC: 'sqInt *root'>
	1 to: extraRootCount do:[:i|
		root := extraRoots at: i.
		root == varLoc ifTrue:["swap varLoc with last entry"
			extraRoots at: i put: (extraRoots at: extraRootCount).
			extraRootCount := extraRootCount-1.
			^true]].
	^false "not found"! !
!ObjectMemory methodsFor: 'become' stamp: 'dtl 5/19/2010 13:33'!
restoreHeaderOf: oop 
	"Restore the original header of the given oop from its 
	forwarding block."
	| fwdHeader fwdBlock |
	fwdHeader := self longAt: oop.
	fwdBlock := (fwdHeader bitAnd: self allButMarkBitAndTypeMask) << 1.
	DoAssertionChecks
		ifTrue: [(fwdHeader bitAnd: self markBit) = 0
				ifTrue: [self error: 'attempting to restore the header of an object that has no forwarding block'].
			self fwdBlockValidate: fwdBlock].
	self longAt: oop put: (self longAt: fwdBlock + self bytesPerWord)! !
!ObjectMemory methodsFor: 'become' stamp: 'dtl 5/19/2010 13:11'!
restoreHeadersAfterBecoming: list1 with: list2 
	"Restore the headers of all oops in both lists. Exchange their hash bits so
	becoming objects in identity sets and dictionaries doesn't change their
	hash value."
	"See also prepareForwardingTableForBecoming:with:woWay: for notes
	regarding the case
	of oop1 = oop2"
	| fieldOffset oop1 oop2 hdr1 hdr2 |
	fieldOffset := self lastPointerOf: list1.
	[fieldOffset >= self baseHeaderSize]
		whileTrue: [oop1 := self longAt: list1 + fieldOffset.
			oop2 := self longAt: list2 + fieldOffset.
			oop1 = oop2
				ifFalse: [self restoreHeaderOf: oop1.
					self restoreHeaderOf: oop2.
					"Exchange hash bits of the two objects."
					hdr1 := self longAt: oop1.
					hdr2 := self longAt: oop2.
					self
						longAt: oop1
						put: ((hdr1 bitAnd: self allButHashBits) bitOr: (hdr2 bitAnd: HashBits)).
					self
						longAt: oop2
						put: ((hdr2 bitAnd: self allButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
			fieldOffset := fieldOffset - self bytesPerWord]! !
!ObjectMemory methodsFor: 'become' stamp: 'dtl 5/19/2010 13:11'!
restoreHeadersAfterForwardBecome: copyHashFlag 
	"Forward become leaves us with no original oops in the 
	mutated object list, 
	so we must enumerate the (four-word) forwarding blocks 
	where we have stored backpointers."
	"This loop start is copied from fwdTableInit:"
	| oop1 fwdBlock oop2 hdr1 hdr2 |
	fwdBlock := endOfMemory + self baseHeaderSize + 7 bitAnd: self wordMask - 7.
	self flag: #Dan.  "See flag comment in fwdTableInit: (dtl)"
	fwdBlock := fwdBlock + (self bytesPerWord * 4).
	"fwdBlockGet: did a pre-increment"
	[self oop: fwdBlock isLessThanOrEqualTo: fwdTableNext
	"fwdTableNext points to the last active block"]
		whileTrue: [oop1 := self longAt: fwdBlock + (self bytesPerWord * 2).
			"Backpointer to mutated object."
			oop2 := self longAt: fwdBlock.
			self restoreHeaderOf: oop1.
			copyHashFlag
				ifTrue: ["Change the hash of the new oop (oop2) to be that of the old (oop1) 
					so mutated objects in hash structures will be 
					happy after the change."
					hdr1 := self longAt: oop1.
					hdr2 := self longAt: oop2.
					self longAt: oop2 put: ((hdr2 bitAnd: self allButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
			fwdBlock := fwdBlock + (self bytesPerWord * 4)]! !
!ObjectMemory methodsFor: 'header access' stamp: 'dtl 5/19/2010 11:42'!
rightType: headerWord
	"Compute the correct header type for an object based on the size and compact class fields of the given base header word, rather than its type bits. This is used during marking, when the header type bits are used to record the state of tracing."

	(headerWord bitAnd: self sizeMask) = 0  "zero size field in header word"
		ifTrue: [ ^HeaderTypeSizeAndClass ]
		ifFalse: [ (headerWord bitAnd: CompactClassMask) = 0
				ifTrue: [ ^HeaderTypeClass ]
				ifFalse: [ ^HeaderTypeShort ]].! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 18:51'!
rootBit
	"Next-to-Top bit"

	<inline: true>
	^self
		cCode: 'ROOT_BIT'
		inSmalltalk: [1 bitShift: self bytesPerWord * 8 - 2]
! !
!ObjectMemory methodsFor: 'header access' stamp: 'dtl 5/19/2010 13:03'!
setSizeOfFree: chunk to: byteSize
	"Set the header of the given chunk to make it be a free chunk of the given size."

	self longAt: chunk put: ((byteSize bitAnd: self allButTypeMask) bitOr: HeaderTypeFree).! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:40'!
shiftForWord

	<inline: true>
	^self
		cCode: 'SHIFT_FOR_WORD'
		inSmalltalk: [(self bytesPerWord log: 2) rounded]
! !
!ObjectMemory methodsFor: 'allocation' stamp: 'JMM 10/22/2004 17:30'!
shrinkObjectMemory: delta 
	"Attempt to shrink the object memory by the given delta 
	amount "
	| limit |
	statShrinkMemory := statShrinkMemory + 1. 
	limit := self sqShrinkMemory: memoryLimit By: delta.
	limit = memoryLimit
		ifFalse: [memoryLimit := limit - 24.
			"remove a tad for safety"
			self initializeMemoryFirstFree: freeBlock]! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:36'!
size4Bit
	"One of the base header word bit fields. The 4 bit is excluded from sizeMask for
	64-bit object memory, but need it for ST size.
	Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes.
	This is used in instantiateClass:indexableSize: "

	<inline: true>
	^self
		cCode: 'SIZE_4_BIT'
		inSmalltalk: [self bytesPerWord = 4
			ifTrue: [0]
			ifFalse: [4]]
! !
!ObjectMemory methodsFor: 'header access' stamp: 'dtl 5/19/2010 11:57'!
sizeBitsOf: oop
	"Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words."
	"Note: byte indexable objects need to have low bits subtracted from this size."

	| header |
	header := self baseHeader: oop.
	(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ ^ (self sizeHeader: oop) bitAnd: self longSizeMask ]
		ifFalse: [ ^ header bitAnd: self sizeMask ].! !
!ObjectMemory methodsFor: 'header access' stamp: 'dtl 5/19/2010 13:03'!
sizeBitsOfSafe: oop
	"Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct."

	| header type |
	header := self baseHeader: oop.
	type := self rightType: header.
	type = HeaderTypeSizeAndClass
		ifTrue: [ ^ (self sizeHeader: oop) bitAnd: self allButTypeMask ]
		ifFalse: [ ^ header bitAnd: self sizeMask ].! !
!ObjectMemory methodsFor: 'header access' stamp: 'dtl 5/18/2010 21:15'!
sizeHeader: oop

	^ self longAt: oop - (self bytesPerWord * 2)! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:31'!
sizeMask
	"One of the base header word bit fields. For 64-bit word size, lose the 4 bit
	in temp 64-bit chunk format. See size4Bit, which restores the 4 bit ST size.
	Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes.
	This is used in instantiateClass:indexableSize: "

	<inline: true>
	^self
		cCode: 'SIZE_MASK'
		inSmalltalk: [self bytesPerWord = 4
			ifTrue: [16rFC]
			ifFalse: [16rF8  "Lose the 4 bit in temp 64-bit chunk format"]]
! !
!ObjectMemory methodsFor: 'header access' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:03'!
sizeOfFree: oop
	"Return the size of the given chunk in bytes. Argument MUST be a free chunk."
	<returnTypeC: 'usqInt'>
	^ (self longAt: oop) bitAnd: self allButTypeMask! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 16:22'!
smallContextSize
	"16 indexable fields, calculated as ContextFixedSizePlusHeader + 16 * BytesPerWord"

	<inline: true>
	^self
		cCode: 'SMALL_CONTEXT_SIZE'
		inSmalltalk: [ContextFixedSizePlusHeader + 16 * self bytesPerWord]
! !
!ObjectMemory methodsFor: 'interpreter access'!
splObj: index
	"Return one of the objects in the SpecialObjectsArray"
	^ self fetchPointer: index ofObject: specialObjectsOop! !
!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:03'!
startField
	"Examine and possibly trace the next field of the object being 
	traced. See comment in markAndTrace for explanation of 
	tracer state variables."
	| typeBits childType |
	<inline: true>
	child := self longAt: field.
	typeBits := child bitAnd: TypeMask.
	(typeBits bitAnd: 1) = 1
		ifTrue: ["field contains a SmallInteger; skip it"
			field := field - self bytesPerWord.
			^ StartField].
	typeBits = 0 ifTrue: ["normal oop, go down"
			self longAt: field put: parentField.
			parentField := field.
			^ StartObj].
	typeBits = 2 ifTrue: ["reached the header; do we need to process the class word? "
			(child bitAnd: CompactClassMask) ~= 0
				ifTrue: ["object's class is compact; we're done"
					"restore the header type bits"
					child := child bitAnd: self allButTypeMask.
					childType := self rightType: child.
					self longAt: field put: (child bitOr: childType).
					^ Upward]
				ifFalse: ["object has a full class word; process that class"
					child := self longAt: field - self bytesPerWord. "class word"
					child := child bitAnd: self allButTypeMask. "clear type bits"
					self longAt: field - self bytesPerWord put: parentField.
					parentField := field - self bytesPerWord bitOr: 1.
					"point at class word; mark as working on the class. "
					^ StartObj]]! !
!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:03'!
startObj
	"Start tracing the object 'child' and answer the next action. 
	The object may be anywhere in the middle of being swept 
	itself. See comment in markAndTrace for explanation of 
	tracer state variables."
	| oop header lastFieldOffset |
	<inline: true>
	oop := child.
	(self oop: oop isLessThan: youngStartLocal)
		ifTrue: ["old object; skip it"
			field := oop.
			^ Upward].
	header := self longAt: oop.
	(header bitAnd: self markBit) = 0
		ifTrue: ["unmarked; mark and trace"
			"Do not trace the object's indexed fields if it's a weak class "
			(self isWeakNonInt: oop)
				ifTrue: ["Set lastFieldOffset before the weak fields in the receiver "
					lastFieldOffset := (self nonWeakFieldsOf: oop) << self shiftForWord]
				ifFalse: ["Do it the usual way"
					lastFieldOffset := self lastPointerOf: oop].
			header := header bitAnd: self allButTypeMask.
			header := (header bitOr: self markBit) bitOr: HeaderTypeGC.
			self longAt: oop put: header.
			field := oop + lastFieldOffset.
			^ StartField "trace its fields and class"]
		ifFalse: ["already marked; skip it"
			field := oop.
			^ Upward]! !
!ObjectMemory methodsFor: 'object enumeration' stamp: 'ikp 3/26/2005 14:04'!
startOfMemory
	"Return the start of object memory."

	^memory! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/18/2010 21:50'!
storeByte: byteIndex ofObject: oop withValue: valueByte

	^ self byteAt: oop + self baseHeaderSize + byteIndex
		put: valueByte! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/18/2010 21:50'!
storeLong32: fieldIndex ofObject: oop withValue: valueWord

	^ self long32At: oop + self baseHeaderSize + (fieldIndex << 2)
		put: valueWord! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/19/2010 11:08'!
storePointer: fieldIndex ofObject: oop withValue: valuePointer
	"Note must check here for stores of young objects into old ones."

	(self oop: oop isLessThan: youngStart) ifTrue: [
		self possibleRootStoreInto: oop value: valuePointer.
	].

	^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)
		put: valuePointer! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'dtl 5/19/2010 11:08'!
storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
	"Like storePointer:ofObject:withValue:, but the caller guarantees that the object being stored into is a young object or is already marked as a root."

	^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)
			put: valuePointer
! !
!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 3/26/2005 14:29'!
storeWord: fieldIndex ofObject: oop withValue: valueWord
	"This message is deprecated.  Use storeLong32, storeLong64 or storePointer"

	self abort! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl (auto pragmas dtl 2010-09-26) 10/11/2009 13:57'!
sufficientSpaceAfterGC: minFree 
	"Return true if there is enough free space after doing a garbage collection. If not, signal that space is low."
	| growSize minFreePlus |
	<inline: false>
	<var: #minFree type: 'usqInt'>
	<var: #growSize type: 'usqInt'>
	<var: #minFreePlus type: 'usqInt'>

	self incrementalGC. "try to recover some space"

	(self oop: (self sizeOfFree: freeBlock) isLessThan: minFree)
		ifTrue: [signalLowSpace ifTrue: [^false]. "give up; problem is already noted"
			self fullGC. "try harder"
			"for stability, require more free space after doing an expensive full GC"
			minFreePlus := minFree + 15000.
			minFreePlus < minFree
				ifTrue: [^ false "arithmetic overflow"].
			(self oop: (self sizeOfFree: freeBlock) isGreaterThanOrEqualTo: minFreePlus)
				ifTrue: [^ true].

			"still not enough; attempt to grow object memory"
			growSize := minFree - (self sizeOfFree: freeBlock) + growHeadroom.
			self growObjectMemory: growSize.

			(self oop: (self sizeOfFree: freeBlock) isGreaterThanOrEqualTo: minFreePlus)
				ifTrue: [^true].

			"still not enough"
			^false].
	^true! !
!ObjectMemory methodsFor: 'allocation' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/18/2010 21:50'!
sufficientSpaceToAllocate: bytes
	"Return true if there is enough space to allocate the given number of bytes,
	perhaps after doing a garbage collection. Sender is responsible for ensuring
	that requested size does result in arithmetic overflow, see note below."

	| minFree |
	<inline: true>
	<var: #bytes type: 'usqInt'>
	<var: #minFree type: 'usqInt'>

	"Note: Arithmetic overflow may occur in calculation of minFree (indicated by
	minFree < bytes after calculation of minFree). The check is performed by sender
	to avoid redundant test here."
	minFree := lowSpaceThreshold + bytes + self baseHeaderSize.

	"check for low-space"
	(self oop: (self sizeOfFree: freeBlock) isGreaterThanOrEqualTo: minFree)
		ifTrue: [^true]
		ifFalse: [^self sufficientSpaceAfterGC: minFree].! !
!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'dtl (auto pragmas dtl 2010-09-26) 6/21/2010 21:55'!
sweepPhase
	"Sweep memory from youngStart through the end of memory. Free all 
	inaccessible objects and coalesce adjacent free chunks. Clear the mark 
	bits of accessible objects. Compute the starting point for the first pass of 
	incremental compaction (compStart). Return the number of surviving 
	objects. "
	"Details: Each time a non-free object is encountered, decrement the 
	number of available forward table entries. If all entries are spoken for 
	(i.e., entriesAvailable reaches zero), set compStart to the last free 
	chunk before that object or, if there is no free chunk before the given 
	object, the first free chunk after it. Thus, at the end of the sweep 
	phase, compStart through compEnd spans the highest collection of 
	non-free objects that can be accomodated by the forwarding table. This 
	information is used by the first pass of incremental compaction to 
	ensure that space is initially freed at the end of memory. Note that 
	there should always be at least one free chunk--the one at the end of 
	the heap."
	| entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize endOfMemoryLocal |
	<inline: false>
	<var: #oop type: 'usqInt'>
	<var: #endOfMemoryLocal type: 'usqInt'>
	entriesAvailable := self fwdTableInit: self bytesPerWord * 2.
	survivors := 0.
	freeChunk := -1. "an invalid object pointer, note that 0 may refer to a meaningful slot"
	firstFree := -1.
	"will be updated later"
	endOfMemoryLocal := endOfMemory.
	oop := self oopFromChunk: youngStart.
	[oop < endOfMemoryLocal]
		whileTrue: ["get oop's header, header type, size, and header size"
			statSweepCount := statSweepCount + 1.
			oopHeader := self baseHeader: oop.
			oopHeaderType := oopHeader bitAnd: TypeMask.
			hdrBytes := headerTypeBytes at: oopHeaderType.
			(oopHeaderType bitAnd: 1) = 1
				ifTrue: [oopSize := oopHeader bitAnd: self sizeMask]
				ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
						ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: self longSizeMask]
						ifFalse: ["free chunk" oopSize := oopHeader bitAnd: self longSizeMask]].
			(oopHeader bitAnd: self markBit) = 0
				ifTrue: ["object is not marked; free it"
					"<-- Finalization support: We need to mark each oop chunk as free -->"
					self longAt: oop - hdrBytes put: HeaderTypeFree.
					freeChunk ~= -1
						ifTrue: ["enlarge current free chunk to include this oop"
							freeChunkSize := freeChunkSize + oopSize + hdrBytes]
						ifFalse: ["start a new free chunk"
							freeChunk := oop - hdrBytes.
							"chunk may start 4 or 8 bytes before oop"
							freeChunkSize := oopSize + (oop - freeChunk).
							"adjust size for possible extra header bytes"
							firstFree = -1 ifTrue: [firstFree := freeChunk]]]
				ifFalse: ["object is marked; clear its mark bit and possibly adjust 
					the compaction start"
					self longAt: oop put: (oopHeader bitAnd: self allButMarkBit).
					"<-- Finalization support: Check if we're running about a weak class -->"
					(self isWeakNonInt: oop) ifTrue: [self finalizeReference: oop].
					entriesAvailable > 0
						ifTrue: [entriesAvailable := entriesAvailable - 1]
						ifFalse: ["start compaction at the last free chunk before this object"
							firstFree := freeChunk].
					freeChunk ~= -1
						ifTrue: ["record the size of the last free chunk"
							self longAt: freeChunk put: ((freeChunkSize bitAnd: self longSizeMask) bitOr: HeaderTypeFree).
							freeChunk := -1].
					survivors := survivors + 1].
			oop := self oopFromChunk: oop + oopSize].
	freeChunk ~= -1
		ifTrue: ["record size of final free chunk"
			self longAt: freeChunk put: ((freeChunkSize bitAnd: self longSizeMask) bitOr: HeaderTypeFree)].
	oop = endOfMemory
		ifFalse: [self error: 'sweep failed to find exact end of memory'].
	firstFree = -1
		ifTrue: [self error: 'expected to find at least one free object']
		ifFalse: [compStart := firstFree].

	^ survivors! !
!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:16'!
trueObject
	^trueObj! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 21:30'!
updatePointersInRangeFrom: memStart to: memEnd 
	"update pointers in the given memory range"
	| oop |
	<inline: false>
	oop := self oopFromChunk: memStart.
	[self oop: oop isLessThan: memEnd]
		whileTrue: [(self isFreeObject: oop)
				ifFalse: [self remapFieldsAndClassOf: oop].
			oop := self objectAfterWhileForwarding: oop]! !
!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'dtl (auto pragmas 12/08) 4/22/2007 20:31'!
updatePointersInRootObjectsFrom: memStart to: memEnd 
	"update pointers in root objects"
	| oop |
	<inline: false>
	1 to: rootTableCount do: [:i | 
			oop := rootTable at: i.
			((self oop: oop isLessThan: memStart)
					or: [self oop: oop isGreaterThanOrEqualTo: memEnd])
				ifTrue: ["Note: must not remap the fields of any object twice!!"
					"remap this oop only if not in the memory range 
					covered below"
					self remapFieldsAndClassOf: oop]]! !
!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 13:03'!
upward
	"Return from marking an object below. Incoming: 
	field = oop we just worked on, needs to be put away 
	parentField = where to put it in our object 
	NOTE: Type field of object below has already been restored!!!!!! "
	| type header |
	<inline: true>
	(parentField bitAnd: 1) = 1
		ifTrue: [parentField = GCTopMarker
				ifTrue: ["top of the chain"
					header := (self longAt: field) bitAnd: self allButTypeMask.
					type := self rightType: header.
					self longAt: field put: (header bitOr: type). "install type on class oop"
					^ Done]
				ifFalse: ["was working on the extended class word"
					child := field. "oop of class"
					field := parentField - 1. "class word, ** clear the low bit **"
					parentField := self longAt: field.
					header := self longAt: field + self bytesPerWord. "base header word"
					type := self rightType: header.
					self longAt: field put: (child bitOr: type). "install type on class oop"
					field := field + self bytesPerWord. "point at header"
					"restore type bits"
					header := header bitAnd: self allButTypeMask.
					self longAt: field put: (header bitOr: type).
					^ Upward]]
		ifFalse: ["normal"
			child := field. "who we worked on below"
			field := parentField. "where to put it"
			parentField := self longAt: field.
			self longAt: field put: child.
			field := field - self bytesPerWord. "point at header"
			^ StartField]! !
!ObjectMemory methodsFor: 'memory access' stamp: 'tpr 3/17/2005 18:40'!
validate
"null method just to stop compilation of interp.c from barfing"! !
!ObjectMemory methodsFor: 'memory access' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 12:38'!
validateRoots 
	"Verify that every old object that points to a new object 
		has its root bit set, and
		appears in the rootTable.
	This method should not be called if the rootTable is full, because roots
	are no longer recorded, and incremental collections are not attempted.
	If DoAssertionChecks is true, this routine will halt on an unmarked root.
	Otherwise, this routine will merely return true in that case."
	| oop fieldAddr fieldOop header badRoot |
	<var: #oop type: 'usqInt'>
	<var: #fieldAddr type: 'usqInt'>
	<var: #fieldOop type: 'usqInt'>
	badRoot := false.
	oop := self firstObject.

	[oop < youngStart] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[fieldAddr := oop + (self lastPointerOf: oop).
			[fieldAddr > oop] whileTrue:
				[fieldOop := self longAt: fieldAddr.
				(fieldOop >= youngStart and: [(self isIntegerObject: fieldOop) not]) ifTrue:
					["fieldOop is a pointer to a young object"
					header := self longAt: oop.
					(header bitAnd: self rootBit) = 0
					ifTrue:
						["Forbidden: points to young obj but root bit not set."
						DoAssertionChecks ifTrue: [self error: 'root bit not set'].
						badRoot := true]
					ifFalse:
						["Root bit is set"
						"Extreme test -- validate that oop was entered in rootTable too..."
						"Disabled for now...
						found := false.
						1 to: rootTableCount do:
							[:i | oop = (rootTable at: i) ifTrue: [found := true]].
						found ifFalse:
							[DoAssertionChecks ifTrue: [self error: 'root table not set'].
							badRoot := true].
						..."
						]].
				fieldAddr := fieldAddr - self bytesPerWord]].
		oop := self objectAfter: oop].
	^ badRoot! !
!ObjectMemory methodsFor: 'finalization' stamp: 'Igor.Stasenko (auto pragmas dtl 2010-09-26) 3/8/2010 20:26'!
weakFinalizerCheck: oop
	"Our oop has at least 2 non-weak fixed slots (this is assured before entering this method, in
	#finalizeReference:.
	We are assuming that if its first non-weak field is an instance of WeakFinalizer class,
	then we should add this oop to that list, by storing it to list's first field and
	also, updating the oop's 2nd fixed slot to point to the value which we overridden:
	
	list := oop instVarAt: 1.
	list class == WeakFinalizer ifTrue: [
		first := list instVarAt: 1.
		oop instVarAt: 2 put: first.
		list instVarAt: 1 put: oop ]	"

	| listOop listItemOop |
	<inline: true>
	
	listOop := self fetchPointer: 0 ofObject: oop.
	(self fetchClassOf: listOop) == (self splObj: ClassWeakFinalizer) ifTrue: [
		listItemOop := self fetchPointer: 0 ofObject: listOop.
		self storePointer: 1 ofObject: oop withValue: listItemOop. 
		self storePointer: 0 ofObject: listOop withValue: oop.
	].
! !
!ObjectMemory methodsFor: 'constants' stamp: 'dtl (auto pragmas dtl 2010-09-26) 5/19/2010 17:00'!
wordMask
	"Answer a bit mask for an object word, either 32 or 64 bits."

	<inline: true>
	^self
		cCode: 'WORD_MASK'
		inSmalltalk: [(1 bitShift: self bytesPerWord * 8) - 1]
! !

ObjectMemory subclass: #SlangTestSupportInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Tests'!
!SlangTestSupportInterpreter commentStamp: 'dtl 9/19/2010 21:36' prior: 0!
SlangTestSupport implements translatable methods for use in SlangTest unit tests.

	"VMMaker clearCacheEntriesFor: SlangTestSupportInterpreter.
	SlangTestSupportInterpreter asCString"!
!SlangTestSupportInterpreter methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:29'!
declareExportFalseByMethod
	"SlangTestSupport asCString: #declareExportFalseByMethod"

	self export: false
! !
!SlangTestSupportInterpreter methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:29'!
declareExportFalseByPragma
	"SlangTestSupport asCString: #declareExportFalseByPragma"

	<export: false>
! !
!SlangTestSupportInterpreter methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:21'!
declareExportTrueByMethod
	"SlangTestSupport asCString: #declareExportTrueByMethod"

	self export: true
! !
!SlangTestSupportInterpreter methodsFor: 'export declaration' stamp: 'dtl 9/19/2010 12:21'!
declareExportTrueByPragma
	"SlangTestSupport asCString: #declareExportTrueByPragma"

	<export: true>
! !
!SlangTestSupportInterpreter methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:29'!
declareStaticFalseByMethod
	"SlangTestSupport asCString: #declareStaticFalseByMethod"

	self static: false
! !
!SlangTestSupportInterpreter methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:30'!
declareStaticFalseByPragma
	"SlangTestSupport asCString: #declareStaticFalseByPragma"

	<static: false>
! !
!SlangTestSupportInterpreter methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:29'!
declareStaticTrueByMethod
	"SlangTestSupport asCString: #declareStaticTrueByMethod"

	self static: true
! !
!SlangTestSupportInterpreter methodsFor: 'static declaration' stamp: 'dtl 9/19/2010 12:30'!
declareStaticTrueByPragma
	"SlangTestSupport asCString: #declareStaticTrueByPragma"

	<static: true>
! !
!SlangTestSupportInterpreter methodsFor: 'inlining' stamp: 'dtl 9/19/2010 11:50'!
inlineByMethod
	"SlangTestSupport asCString: #inlineByMethod"
	"SlangTestSupport asInlinedCString: #inlineByMethod"

	| bar foo |
	foo := self methodThatShouldBeInlinedByMethod.
	bar := self methodThatShouldNotBeInlinedByMethod! !
!SlangTestSupportInterpreter methodsFor: 'inlining' stamp: 'dtl 9/19/2010 11:50'!
inlineByPragma
	"SlangTestSupport asCString: #inlineByPragma"
	"SlangTestSupport asInlinedCString: #inlineByPragma"

	| bar foo |
	foo := self methodThatShouldBeInlinedByPragma.
	bar := self methodThatShouldNotBeInlinedByPragma! !
!SlangTestSupportInterpreter methodsFor: 'inlining' stamp: 'dtl 9/18/2010 17:59'!
methodThatShouldBeInlinedByMethod

	self inline: true.
	^ #foo! !
!SlangTestSupportInterpreter methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldBeInlinedByPragma

	<inline: true>
	^ #foo! !
!SlangTestSupportInterpreter methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldNotBeInlinedByMethod

	self inline: false.
	^ #bar! !
!SlangTestSupportInterpreter methodsFor: 'inlining' stamp: 'dtl 9/18/2010 18:01'!
methodThatShouldNotBeInlinedByPragma

	<inline: false>
	^ #bar! !
!SlangTestSupportInterpreter methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:50'!
returnTypeByMethod
	"SlangTestSupport asCString: #returnTypeByMethod"

	self returnTypeC: 'char *'.
! !
!SlangTestSupportInterpreter methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:51'!
returnTypeByPragma
	"SlangTestSupport asCString: #returnTypeByPragma"

	<returnTypeC: 'char *'>
! !
!SlangTestSupportInterpreter methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 11:51'!
varDefByMethod
	"SlangTestSupport asCString: #varDefByMethod"

	| foo bar |
	self var: #foo type: 'char *'.
	self var: #bar declareC: 'unsigned int * bar'
! !
!SlangTestSupportInterpreter methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 22:26'!
varDefByMethodAndPragma
	"SlangTestSupportInterpreter asCString: #varDefByMethodAndPragma"

	| foo bar baz fum |
	<var: #baz type: 'float'>
	<var: #fum declareC: 'double fum'>
	self var: #foo type: 'char *'.
	self var: #bar declareC: 'unsigned int * bar'
! !
!SlangTestSupportInterpreter methodsFor: 'type declaration' stamp: 'dtl 9/19/2010 12:05'!
varDefByPragma
	"SlangTestSupport asCString: #varDefByPragma"

	| foo bar |
	<var: #foo type: 'char *'>
	<var: #bar declareC: 'unsigned int * bar'>
! !

Object subclass: #Pragmatizer
	instanceVariableNames: 'package selectors classes stampCutString stampInsertString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!Pragmatizer commentStamp: 'dtl 9/25/2010 18:26' prior: 0!
Pragmatizer is a utility for converting message send directives (such as 'self inline: true') to their corresponding pragma implementations (<inline: true>) in method source.

The #depragmatize method provides a means for reverting to message send directives. This may be useful in the event of needing to load VMMaker into an image that does not support pragmas.

This is based on an original script provided by Eliot Miranda.!
!Pragmatizer class methodsFor: 'examples' stamp: 'dtl 9/25/2010 15:15'!
convertVMMakerAndPluginsToPragmas
	"Create (unused) packages named 'VMMaker-Interpreter', 'VMMaker-Plugins',
	and 'VMMaker-SmartSyntaxPlugins'. Open a transcript, then evaluate this method.
	Some errors will be found during the conversion. Fix the problem methods
	manually in the notifier dialog, and proceed. The issues are related to declarations
	that are not the first lines of source in the method, so just move the declarations
	to the top of the method to resolve."
	
	"Pragmatizer convertVMMakerAndPluginsToPragmas"

	| selectorsToConvert packages converter |
	selectorsToConvert := #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: ).
	packages := { 'VMMaker-Interpreter' . 'VMMaker-Plugins' . 'VMMaker-SmartSyntaxPlugins' }.
	packages do: [:package |
		converter := Pragmatizer on: package selectors: selectorsToConvert.
		converter pragmatize]! !
!Pragmatizer class methodsFor: 'instance creation' stamp: 'dtl 9/23/2010 19:31'!
on: packageName selectors: selectorList
	"Pragmatizer on: 'VMMaker-Interpreter' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: )"
	"Pragmatizer on: 'VMMaker-Plugins' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: )"
	"Pragmatizer on: 'VMMaker-SmartSyntaxPlugins' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: )"

	^ self new package: packageName selectors: selectorList! !
!Pragmatizer class methodsFor: 'examples' stamp: 'dtl 9/26/2010 11:03'!
revertVMMakerAndPluginsToMessageSendDeclarations
	"To revert back to the message send declarations. "
	
	"Pragmatizer revertVMMakerAndPluginsToMessageSendDeclarations"

	| selectorsToConvert packages converter substringToRemoveFromMethodStamp |

	"Optional - Edit the following to match substring to be removed from the method
	stamps to return them to their original form prior to conversion to pragmas:
	Note leading space in the string."
	substringToRemoveFromMethodStamp := ' (auto pragmas dtl 2010-09-26)'.

	selectorsToConvert := #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: ).
	packages := { 'VMMaker-Interpreter' . 'VMMaker-Plugins' . 'VMMaker-SmartSyntaxPlugins' }.
	packages do: [:package |
		converter := Pragmatizer on: package selectors: selectorsToConvert.
		converter stampCutString: substringToRemoveFromMethodStamp.
		converter stampInsertString: ''.
		converter depragmatize]! !
!Pragmatizer methodsFor: 'accessing' stamp: 'dtl 9/27/2010 13:41'!
classes: listOfClasses
	"If set, only the classes in this list will be modified. The classes are assumed to be
	classes in the package. This is intended to allow specifying one or more plugins
	in VMMaker-Plugins to be converted individually."

	classes := listOfClasses! !
!Pragmatizer methodsFor: 'convert pragmas to sends' stamp: 'dtl 9/27/2010 11:37'!
depragmatize
	"Convert methods from pragmas to old style message send directives, retaining
	original author initials and time stamps. Answer the methods that were modified."

	| instanceMethods |
	"Only instance side methods are translated, so ignore class side methods in the package"
	instanceMethods := package methods
				reject: [:e | e classIsMeta
						or: [self isExcludedClass: e]].
	^ instanceMethods
		reject: [:mr | self depragmatize: mr]! !
!Pragmatizer methodsFor: 'convert pragmas to sends' stamp: 'dtl 9/25/2010 12:51'!
depragmatize: methodReference
	"Depragmatize the method. Answer true if the method was not modified, and false
	if conversion was performed."

	| method newSource newStamp pragmas stamp |
	pragmas := OrderedCollection new.
	method := methodReference compiledMethod.
	method properties keysAndValuesDo: [:sel :p |
		(selectors includes: sel)
			ifTrue: [pragmas add: p]].
	pragmas isEmpty ifTrue: [^ true].
	newSource := pragmas
		inject: method getSourceFromFile asString
		into: [:src : pragma |
				src copyReplaceAll: pragma asString
					with: 'self ', pragma asString allButFirst allButLast, '.'].
		stamp := method timeStamp.
		newStamp := self newConvertToMessageSendStamp: stamp.
	Transcript
		print: method methodClass;
		nextPutAll: '>>';
		print: method selector;
		nextPut: Character space;
		nextPutAll: newStamp;
		cr; flush.
	method methodClass
		compile: newSource
		classified: methodReference category
		withStamp: newStamp
		notifying: nil.
	^false
! !
!Pragmatizer methodsFor: 'testing' stamp: 'dtl 9/27/2010 13:44'!
isExcludedClass: aMethodReference

	classes notNil
		and: [classes
				detect: [:cls | cls name = aMethodReference classSymbol]
				ifNone: [^ true]].
	^ false! !
!Pragmatizer methodsFor: 'method stamp' stamp: 'dtl 9/25/2010 13:06'!
newConvertToMessageSendStamp: oldStamp
	"Insert a comment in a method stamp to indicate that conversion from pragmas to old
	style message sends was done. If stampCutString has been set, remove this substring
	from the oldStamp prior to adding a new substring. If stampInsertString was set, use
	this as the substring to insert. Otherwise add a substring with current date and author
	initials." 

	| newStamp |
	stampCutString
		ifNil: [newStamp := oldStamp]
		ifNotNil: [newStamp := oldStamp copyReplaceAll: stampCutString with: ''].
	stampInsertString
		ifNil: [newStamp := newStamp
						copyReplaceFrom: (oldStamp indexOf: Character space) + 1
						to: (oldStamp indexOf: Character space)
						with: '(remove pragmas ', Utilities authorInitials, ' ', Date today yyyymmdd, ') ']
		ifNotNil: [newStamp := newStamp
						copyReplaceFrom: (oldStamp indexOf: Character space) + 1
						to: (oldStamp indexOf: Character space)
						with: stampInsertString].
	^ newStamp
! !
!Pragmatizer methodsFor: 'method stamp' stamp: 'dtl 9/25/2010 13:06'!
newConvertToPragmaStamp: oldStamp
	"Insert a comment in a method stamp to indicate that conversion to pragmas was done.
	If stampCutString has been set, remove this substring from the oldStamp prior to adding
	a new substring. If stampInsertString was set, use this as the substring to insert. Otherwise
	add a substring with current date and author initials." 

	| newStamp |
	stampCutString
		ifNil: [newStamp := oldStamp]
		ifNotNil: [newStamp := oldStamp copyReplaceAll: stampCutString with: ''].
	stampInsertString
		ifNil: [newStamp := newStamp
						copyReplaceFrom: (oldStamp indexOf: Character space) + 1
						to: (oldStamp indexOf: Character space)
						with: '(auto pragmas ', Utilities authorInitials, ' ', Date today yyyymmdd, ') ']
		ifNotNil: [newStamp := newStamp
						copyReplaceFrom: (oldStamp indexOf: Character space) + 1
						to: (oldStamp indexOf: Character space)
						with: stampInsertString].
	^ newStamp
! !
!Pragmatizer methodsFor: 'convert sends to pragmas' stamp: 'dtl 9/25/2010 18:05'!
newPragmatizedSourceFrom: source nodes: pragmaNodes nodeRanges: ranges

	^ String streamContents: [:str|
		str nextPutAll: (source copyFrom: 1 to: ranges first - 6).
		pragmaNodes
			do: [:node| | pragma args |
				str nextPut: $<.
				str nextPutAll: (node asString allButFirst: 6) allButLast.
				str nextPut: $>]
			separatedBy: [str crtab: 1].
		str nextPutAll: (source copyFrom: ((ranges last + 1 <= source size
										   and: [(source at: ranges last + 1) = $.])
											ifTrue: [ranges last + 2]
											ifFalse: [ranges last + 1])
							to: source size)]
! !
!Pragmatizer methodsFor: 'initialize-release' stamp: 'dtl 9/20/2010 18:57'!
package: packageName selectors: selectorList

	package := PackageOrganizer default
		packageNamed: packageName
		ifAbsent: [self error: 'package ', packageName, ' not found'].
	selectors := selectorList! !
!Pragmatizer methodsFor: 'convert sends to pragmas' stamp: 'dtl 9/27/2010 11:36'!
pragmatize
	"Convert methods to use pragmas, retaining original author initials and time stamps.
	Answer the methods that were modified."

	| instanceMethods |
	"Only instance side methods are translated, so ignore class side methods in the package"
	instanceMethods := package methods
				reject: [:e | e classIsMeta
						or: [self isExcludedClass: e]].
	^ instanceMethods
		reject: [:mr | self pragmatize: mr]! !
!Pragmatizer methodsFor: 'convert sends to pragmas' stamp: 'dtl 9/25/2010 17:26'!
pragmatize: methodReference
	"Pragmatize the method. Answer true if the method was not modified, and false
	if conversion was performed."

	| method methodNode pragmaNodes sourceRanges ranges source newSource stamp newStamp |
	method := methodReference compiledMethod.
	methodNode := method methodNode.
	pragmaNodes := SortedCollection
						sortBlock: [:a :b | (sourceRanges at: a) first <= (sourceRanges at: b) first].
	(sourceRanges := methodNode rawSourceRanges)
		keysAndValuesDo: [:node :range | (node isMessageNode
					and: [selectors includes: node selector key])
				ifTrue: [pragmaNodes add: node]].
	^ pragmaNodes isEmpty
		ifFalse: [ranges := (sourceRanges at: pragmaNodes first) first
								to: (sourceRanges at: pragmaNodes last) last.

				source := method getSourceFromFile asString.
				"methodBodyStart := method methodClass parserClass new
										parseMethodComment: source setPattern: [:ignored|];
										startOfNextToken.
				tempsStart := source indexOf: $| startingAt: methodBodyStart.
				hasTemps := tempsStart > 0 and: [tempsStart < ranges first]."
				(source copyFrom: ranges first - 5 to: ranges first - 1) ~= 'self ' ifTrue: [self halt].
				(ranges last < source size
					and: [(source indexOf: $. startingAt: ranges last) > (ranges last + 1)]) ifTrue: [self halt].
				newSource := self newPragmatizedSourceFrom: source
							nodes: pragmaNodes
							nodeRanges: ranges.
				stamp := method timeStamp.
				newStamp := self newConvertToPragmaStamp: stamp.
				Transcript
					print: method methodClass;
					nextPutAll: '>>';
					print: method selector;
					nextPut: Character space;
					nextPutAll: newStamp;
					cr; flush.
				method methodClass
					compile: newSource
					classified: methodReference category
					withStamp: newStamp
					notifying: nil.
				false]
! !
!Pragmatizer methodsFor: 'accessing' stamp: 'dtl 9/25/2010 11:19'!
stampCutString: stringToRemoveFromMethodStamp
	"If set, this substring will be removed from method stamps during conversion. This is
	intended to enable conversion to and from pragmas without repeated extension of the
	method stamp."

	stampCutString := stringToRemoveFromMethodStamp! !
!Pragmatizer methodsFor: 'accessing' stamp: 'dtl 9/25/2010 12:49'!
stampInsertString: commentToInsert
	"If set, the commentToInsert will be used for method stamp modification
	rather than the default conversion value. This is intended to permit a
	Pragmatizer to reproduce a previous conversion, e.g. the previously converted
	methods in the Cog VM."

	stampInsertString := commentToInsert
! !

Object subclass: #TMethod
	instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels possibleSideEffectsCache complete export static sharedLabel sharedCase comment definingClass globalStructureBuildMethodHasFoo canAsmLabel mustAsmLabel properties cascadeVariableNumber'
	classVariableNames: 'CaseStatements'
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TMethod commentStamp: 'dtl 9/15/2008 09:06' prior: 0!
A TMethod is a translation method, representing a MethodNode that is to be translated to C source. It has a parseTree of translation nodes that mirrors the parse tree of the corresponding Smalltalk method.!

TMethod subclass: #SmartSyntaxPluginTMethod
	instanceVariableNames: 'isPrimitive suppressingFailureGuards selectorOverride fullArgs parmSpecs rcvrSpec'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-SmartSyntaxPlugins'!
!SmartSyntaxPluginTMethod commentStamp: '<historical>' prior: 0!
Variation of TMethod node of the Smalltalk C Code Generator, used in conjunction with TestCodeGenerator and TestInterpreterPlugin to generate named primitives with type coercion specifications.!
!SmartSyntaxPluginTMethod class methodsFor: 'as yet unclassified' stamp: 'acg 9/19/1999 11:47'!
fromContext: aContext primitive: aString parameters: aClassList receiver: aClass

	^super new 
		fromContext: aContext 
		primitive: aString 
		parameters: aClassList 
		receiver: aClass
! !
!SmartSyntaxPluginTMethod methodsFor: 'accessing' stamp: 'acg 9/19/1999 11:19'!
args: anInteger

	^args := anInteger! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 06:31'!
assign: variable expression: expression

	^TAssignmentNode new
		setVariable: variable
		expression: expression! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'acg 9/19/1999 20:53'!
checkSuccessExpr
	"Return the parse tree for an expression that aborts the primitive if the successFlag is not true."

	| expr |
	expr := 'interpreterProxy failed ifTrue: [^nil]'.
	^ self statementsFor: expr varName: ''
! !
!SmartSyntaxPluginTMethod methodsFor: 'generating C code' stamp: 'ikp 3/31/2005 14:23'!
emitCHeaderOn: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	aStream cr.
	self emitCFunctionPrototype: aStream generator: aCodeGen.
	aStream nextPutAll: ' {'; cr.
	locals do: [ :var |
		aStream 
			tab; 
			nextPutAll: (declarations 
				at: var 
				ifAbsent: [ 'sqInt ', var]);
			nextPut: $;; 
			cr].
	locals isEmpty ifFalse: [ aStream cr ].! !
!SmartSyntaxPluginTMethod methodsFor: 'specifying primitives' stamp: 'dtl 2/3/2007 11:40'!
extractPrimitiveDirectives
	"Set selectorOverride, and save args in fullArgs.  Scan top-level statements for a directive of the form:

		self	
			primitive: 	<string>
or
		self
			primitive:	<string>
			parameters: <list of class names>
or
		self
			primitive:	<string>
			parameters: <list of class names>
			receiver: <class name>

or an assignment of that expression to a local, and manipulate the state and parse tree accordingly."

	parseTree setStatements: (Array streamContents:
		[:sStream |
			parseTree statements do:
				[:stmt |
				 (self primitiveDirectiveWasHandled: stmt on: sStream)
					ifFalse: [sStream nextPut: stmt]]]).
	isPrimitive 
		ifTrue:
			[export := true.
			 parseTree 
				setStatements: self namedPrimitiveProlog, 
								parseTree statements.
			 self fixUpReturns.
			 self replaceSizeMessages.
			 ^true]
		ifFalse: [self removeFinalSelfReturn].
	^false! !
!SmartSyntaxPluginTMethod methodsFor: 'transforming' stamp: 'acg 12/18/1999 10:39'!
extractSuppressFailureGuardDirective
	"Scan the top-level statements for a pragma directive of the form:

		self suppressFailureGuards: <boolean>

	 and remove the directive from the method body. Answer the argument of the directive or false if there is no #supressFailureGuards: directive."

	| result newStatements |
	result := false.
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #suppressFailureGuards:]) ifTrue: [
			result := stmt args first name = 'true'.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	^ result! !
!SmartSyntaxPluginTMethod methodsFor: 'transforming' stamp: 'TPR 3/1/2000 20:21'!
fixUpReturnOneStmt: stmt on: sStream

	stmt isReturn ifFalse: [^sStream nextPut: stmt].
	(stmt expression isSend and: ['primitiveFail' = stmt expression selector]) ifTrue: 
		["failure return"
		 sStream nextPut: stmt expression.
		 sStream nextPut: self nullReturnExpr.
		 ^nil].
	(stmt expression isVariable and: ['nil' = stmt expression name]) ifTrue: 
		["^ nil -- this is never right unless automatically generated"
		 sStream nextPut: stmt.
		 ^nil].
	(stmt expression isVariable and: ['self' = stmt expression name]) ifTrue: 
		["^ self"
		 self generateFailureGuardOn: sStream.
		 fullArgs isEmpty ifFalse:[ sStream nextPut: (self popExpr: fullArgs size)].
		 sStream nextPut: self nullReturnExpr.
		 ^nil].
	(stmt expression isVariable | stmt expression isConstant | suppressingFailureGuards) ifTrue:
		["^ variable or ^ constant or ^ expr without guardchecking"
		 self generateFailureGuardOn: sStream.
		 sStream nextPut: (self pop: fullArgs size + 1 thenReturnExpr: stmt expression).
		 sStream nextPut: self nullReturnExpr.
		 ^nil].
	"^ expr with guardchecking"
	sStream nextPut: (self assign: (self oopVariable: '_return_value') expression: stmt expression).
	self generateFailureGuardOn: sStream.
	sStream nextPut: (self pop: fullArgs size + 1 thenReturnExpr: (self oopVariable: '_return_value')).
	sStream nextPut: self nullReturnExpr
! !
!SmartSyntaxPluginTMethod methodsFor: 'transforming' stamp: 'acg 9/18/1999 01:49'!
fixUpReturns
	"Replace each return statement in this method with (a) the given postlog, (b) code to pop the receiver and the given number of arguments, and (c) code to push the integer result and return."

	parseTree nodesDo: [:node |
		node isStmtList ifTrue: [
			node setStatements: (Array streamContents:
				[:sStream |
				 node statements do: 
					[:stmt | self fixUpReturnOneStmt: stmt on: sStream]])]]! !
!SmartSyntaxPluginTMethod methodsFor: 'initializing' stamp: 'acg 9/19/1999 11:46'!
fromContext: aContext primitive: aString parameters: aClassList receiver: aClass

	fullArgs := args := aContext tempNames
				copyFrom: 1
				to: aContext method numArgs.
	self 
		primitive: aString
		parameters: aClassList
		receiver: aClass! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'acg 12/18/1999 10:47'!
generateFailureGuardOn: sStream
	suppressingFailureGuards ifTrue: [^nil].
	sStream nextPutAll: self checkSuccessExpr
! !
!SmartSyntaxPluginTMethod methodsFor: 'specifying primitives' stamp: 'ar 4/4/2006 21:10'!
handlePrimitiveDirective: aStmt on: sStream

	isPrimitive := true.
	fullArgs := args.
	locals addAll: args.
	args := OrderedCollection new.
	fullArgs with: parmSpecs do:
		[:argName :spec |
			declarations
				at: argName
				put: (spec ccgDeclareCForVar: argName)].
	aStmt isAssignment ifTrue:
		[declarations
			at: aStmt variable name
			put: (rcvrSpec ccgDeclareCForVar: aStmt variable name).
		 sStream nextPutAll: (self
			statementsFor:
				(rcvrSpec
					ccg:		SmartSyntaxPluginCodeGenerator new
					prolog:  [:expr | aStmt variable name, ' := ', expr]
					expr: 	aStmt variable name
					index: 	(fullArgs size))
			varName: '')].

	"only add the failure guard if there are args or it is an assignment"
	(fullArgs isEmpty not or:[aStmt isAssignment]) ifTrue:[self generateFailureGuardOn: sStream].
	^true.
! !
!SmartSyntaxPluginTMethod methodsFor: 'specifying primitives' stamp: 'TPR 2/10/2000 17:43'!
isPrimitiveDirectiveSend: stmt
	
	stmt isSend ifTrue:
		[stmt selector = #primitive: ifTrue:
			[^self primitive: 	stmt args first value
				   parameters:	(Array new: args size withAll: #Oop)
				   receiver:		#Oop].
		 stmt selector = #primitive:parameters: ifTrue:
			[^self primitive: 	stmt args first value
				   parameters: 	stmt args second value
				   receiver:		#Oop].
		 stmt selector = #primitive:parameters:receiver: ifTrue:
			[^self primitive:		stmt args first value
				   parameters:	stmt args second value
				   receiver:		stmt args third value].
		^false].
	^false.
! !
!SmartSyntaxPluginTMethod methodsFor: 'specifying primitives' stamp: 'ar 4/4/2006 21:10'!
namedPrimitiveProlog

	| cg |
	cg := SmartSyntaxPluginCodeGenerator new.
	^Array streamContents: [:sStream |
		1 to: fullArgs size do:
			[:i |
			 sStream nextPutAll: 
				(self 
					statementsFor: 
						((parmSpecs at: i) 
							ccg: 	cg
							prolog:  [:expr | (fullArgs at: i), ' := ', expr]
							expr: (fullArgs at: i)
							index: (fullArgs size - i))
					varName: '')]]! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 05:50'!
nullReturnExpr

	^ TReturnNode new
		setExpression: (TVariableNode new setName: 'null')! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'acg 9/20/1999 14:04'!
oldReplaceSizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive."

	| argExpr |
	parseTree nodesDo: [:n |
		(n isSend and: [n selector = #size]) ifTrue: [
			argExpr := TSendNode new
				setSelector: #+
				receiver: n receiver
				arguments: (Array with: (TConstantNode new setValue: 1)).
			n
				setSelector: #sizeOfSTArrayFromCPrimitive:
				receiver: (TVariableNode new setName: 'interpreterProxy')
				arguments: (Array with: argExpr)]].
! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'ikp 3/31/2005 14:23'!
oopVariable: aString

	(locals includes: aString) ifFalse:
		[locals add: aString.
		 declarations
			at: aString 
			put: 'sqInt ', aString].
	^TVariableNode new setName: aString! !
!SmartSyntaxPluginTMethod methodsFor: 'accessing' stamp: 'acg 9/19/1999 11:18'!
parmSpecs

	^parmSpecs! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 05:55'!
pop: anInteger thenReturnExpr: anExpression

	^TSendNode new
		setSelector: #pop:thenPush:
		receiver: (TVariableNode new setName: 'interpreterProxy')
		arguments: (Array 
			with: (TConstantNode new 
				setValue: anInteger)
			with: anExpression)! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 05:45'!
popExpr: anInteger

	^ TSendNode new
			 setSelector: #pop:
			 receiver: (TVariableNode new setName: 'interpreterProxy')
			 arguments: (Array 
				with: (TConstantNode new 
					setValue: anInteger))! !
!SmartSyntaxPluginTMethod methodsFor: 'specifying primitives' stamp: 'dtl 2/3/2007 11:29'!
primitive: aString parameters: anArray receiver: aClassSymbol

	self selectorOverride: aString asSymbol.
	anArray size == args size ifFalse: 
		[^self error: self selectorOverride, ': incorrect number of parameter specifications'].
	parmSpecs := anArray collect:
		[:each | Smalltalk at: each ifAbsent:
			[^self error: self selectorOverride, ': parameter spec must be a Behavior']].
	parmSpecs do: [:each | each isBehavior ifFalse:
		[^self error: self selectorOverride, ': parameter spec must be a Behavior']].
	rcvrSpec := Smalltalk at: aClassSymbol asSymbol ifAbsent:
		[^self error: self selectorOverride, ': receiver spec must be a Behavior'].
	rcvrSpec isBehavior ifFalse:
		[^self error: self selectorOverride, ': receiver spec must be a Behavior'].
	^true! !
!SmartSyntaxPluginTMethod methodsFor: 'specifying primitives' stamp: 'acg 9/17/1999 22:41'!
primitiveDirectiveWasHandled: stmt on: sStream

	(self isPrimitiveDirectiveSend: stmt) ifTrue:
		[^self handlePrimitiveDirective: stmt on: sStream].
	(stmt isAssignment and: 
		[self isPrimitiveDirectiveSend: stmt expression]) ifTrue:
			[^self handlePrimitiveDirective: stmt on: sStream].
	^false.
! !
!SmartSyntaxPluginTMethod methodsFor: 'private' stamp: 'TPR 3/2/2000 12:39'!
printTempsAndVar: varName on: aStream 
	"add the required temps and the varname to the stream"
	aStream nextPutAll: '| '.
	(#('rcvr' 'stackPointer' 'successFlag' 'interpreterProxy' ) reject: [:each | locals includes: each])
		do: [:each | aStream nextPutAll: each;
			 space].
	(locals reject: [:each | each first = $_])
		do: [:each | aStream nextPutAll: each;
			 space].
"don't add varName twice. Probably a deeper reason for this, but WTH. TPR"
	(locals includes: varName) ifFalse:[aStream nextPutAll: varName].
	aStream nextPutAll: '|';
	 cr! !
!SmartSyntaxPluginTMethod methodsFor: 'accessing' stamp: 'acg 9/19/1999 11:50'!
rcvrSpec

	^rcvrSpec! !
!SmartSyntaxPluginTMethod methodsFor: 'transforming' stamp: 'dtl 9/19/2010 22:56'!
recordDeclarations
	"Record C type declarations of the forms

		self returnTypeC: 'float'.
		self var: #foo declareC: 'float foo'
		self var: #foo as: Class
		self var: #foo type: 'float'.

	 and remove the declarations from the method body."

	| newStatements |
	properties pragmas notEmpty ifTrue:
		[properties pragmas do:
			[:pragma|
			pragma keyword = #var:declareC: ifTrue:
				[self declarationAt: pragma arguments first asString put: pragma arguments last].
			pragma keyword = #var:type: ifTrue:
				[| varName varType |
				varName := pragma arguments first asString.
				varType := pragma arguments last.
				varType last = $* ifFalse: [varType := varType, ' '].
				self declarationAt: varName put: varType, varName].
			 pragma keyword = #var:as: ifTrue:
				[| theClass |
				 theClass := Smalltalk at: pragma arguments last name asSymbol ifAbsent: [nil].
				 (theClass isKindOf: Behavior) ifFalse:
					[^self error: 'declarator must be a Behavior'].
				 self declarationAt: pragma arguments first value asString 
					put: (theClass ccgDeclareCForVar: pragma arguments first asString)].
			pragma keyword = #returnTypeC: ifTrue:
				[returnType := pragma arguments last].
			pragma keyword = #doNotGenerate: ifTrue:
				[locals removeKey: pragma arguments last]]].
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do: 
		[:stmt | | isDeclaration |
		 isDeclaration := false.
		 stmt isSend ifTrue: 
			[stmt selector = #var:declareC: ifTrue:
				[isDeclaration := true.
				self declarationAt: stmt args first value asString put: stmt args last value].
			stmt selector = #var:type: ifTrue: [
				| varName varType |
				isDeclaration := true.
				varName := stmt args first value asString.
				varType := stmt args last value.
				varType last = $* ifFalse: [varType := varType, ' '].
				self declarationAt: varName put: varType, varName.
			].
			 stmt selector = #var:as: ifTrue:
				[| theClass |
				 isDeclaration := true.
				 theClass := Smalltalk  at: stmt args last name asSymbol ifAbsent: [nil].
				 (theClass isKindOf: Behavior) ifFalse:
					[^self error: 'declarator must be a Behavior'].
				 self declarationAt: stmt args first value asString 
					put: (theClass ccgDeclareCForVar: stmt args first value asString)].
			 stmt selector = #returnTypeC: ifTrue: 
				[isDeclaration := true.
				 returnType := stmt args last value]].
		 isDeclaration ifFalse: [newStatements add: stmt]].
	parseTree setStatements: newStatements asArray! !
!SmartSyntaxPluginTMethod methodsFor: 'transforming' stamp: 'acg 9/17/1999 18:18'!
removeFinalSelfReturn
	"The Smalltalk parser automatically adds the statement '^self' to the end of methods without explicit returns. This method removes such statements, since the generated code has no notion of 'self' anyway."

	| stmtList lastStmt |
	stmtList := parseTree statements asOrderedCollection.
	lastStmt := stmtList last.

	((lastStmt isReturn) and:
	 [(lastStmt expression isVariable) and:
	 ['self' = lastStmt expression name]]) ifTrue: [
		stmtList removeLast.
		parseTree setStatements: stmtList.
	].! !
!SmartSyntaxPluginTMethod methodsFor: 'transforming' stamp: 'TPR 3/2/2000 19:07'!
replaceArraySizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive. Specialised version for generating primitives outside a plugin"

	super replaceSizeMessages
! !
!SmartSyntaxPluginTMethod methodsFor: 'transforming' stamp: 'acg 9/20/1999 14:04'!
replaceSizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive."

	parseTree nodesDo: [:n |
		(n isSend and: [n selector = #size]) ifTrue: [
			n
				setSelector: #sizeOfSTArrayFromCPrimitive:
				receiver: (TVariableNode new setName: 'interpreterProxy')
				arguments: (Array with: n receiver)]].
! !
!SmartSyntaxPluginTMethod methodsFor: 'accessing' stamp: 'dtl 2/3/2007 11:23'!
selectorForCodeGeneration
	"A primitive directive my override the selector specification."

	^ self selectorOverride ifNil: [self selector]! !
!SmartSyntaxPluginTMethod methodsFor: 'accessing' stamp: 'dtl 2/3/2007 11:21'!
selectorOverride
	"A primitive directive allows the selector to be overridden in order to specify
	a preferred name for the generated primitive."

	^ selectorOverride! !
!SmartSyntaxPluginTMethod methodsFor: 'accessing' stamp: 'dtl 2/3/2007 11:21'!
selectorOverride: preferredSelectorName
	"A primitive directive allows the selector to be overridden in order to specify
	a preferred name for the generated primitive."

	selectorOverride := preferredSelectorName! !
!SmartSyntaxPluginTMethod methodsFor: 'initializing' stamp: 'eem 10/2/2009 11:32'!
setSelector: sel definingClass: class args: argList locals: localList block: aBlockNode primitive: aNumber properties: methodProperties comment: aComment
	"Initialize this method using the given information."

	selector := sel.
	definingClass := class.
	returnType := #sqInt. 	 "assume return type is sqInt for now"
	args := argList asOrderedCollection collect: [:arg | arg key].
	locals := localList asOrderedCollection collect: [:arg | arg key].
	declarations := Dictionary new.
	primitive := aNumber.
	properties := methodProperties.
	comment := aComment.
	parseTree := aBlockNode asTranslatorNodeIn: self.
	labels := OrderedCollection new.
	complete := false.  "set to true when all possible inlining has been done"
	export := self extractExportDirective.
	static := self extractStaticDirective.
	canAsmLabel := self extractLabelDirective.
	self extractSharedCase.
	isPrimitive := false.  "set to true only if you find a primtive direction."
	suppressingFailureGuards := self extractSuppressFailureGuardDirective.
	self recordDeclarations.
	self extractPrimitiveDirectives.
! !
!SmartSyntaxPluginTMethod methodsFor: 'specifying primitives' stamp: 'tpr 6/9/2003 16:38'!
simulatePrologInContext: aContext

	|cg instructions |
	cg := SmartSyntaxPluginCodeGenerator new.
	parmSpecs keysAndValuesDo: 
		[:index :each |
		 instructions := ((parmSpecs at: index)
			ccg: cg 
			prolog: (cg ccgTVarBlock: index) 
			expr: '<foo>' 
			index: args size - index).
		 Compiler new 
			evaluate: instructions
			in: aContext 
			to: aContext receiver
			notifying: nil
			ifFail: nil].
	instructions := (rcvrSpec
		ccg: cg 
		prolog: [:expr | '^', expr]
		expr: '<foo>' 
		index: args size).
	 ^Compiler new 
		evaluate: instructions
		in: aContext 
		to: aContext receiver
		notifying: nil
		ifFail: nil! !
!SmartSyntaxPluginTMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:07'!
vmNameString
	"return the string to use as the vm name in code generated for this method"
	^'interpreterProxy'! !
!TMethod class methodsFor: 'class initialization' stamp: 'ar 11/18/1999 20:06'!
initialize
	"TMethod initialize"	
	CaseStatements := IdentitySet new: 10.
	CaseStatements addAll: #(dispatchOn:in: dispatchOn:in:with: dispatchOn:in:with:with:).! !
!TMethod methodsFor: 'inlining support'!
addVarsDeclarationsAndLabelsOf: methodToBeInlined
	"Prepare to inline the body of the given method into the receiver by making the args and locals of the argument to the receiver be locals of the receiver. Record any type declarations for these variables. Record labels. Assumes that the variables have already be renamed to avoid name clashes."

	methodToBeInlined args, methodToBeInlined locals do: [ :v |
		(locals includes: v) ifFalse: [ locals addLast: v ].
	].
	methodToBeInlined declarations associationsDo: [ :assoc |
		declarations add: assoc.
	].
	methodToBeInlined labels do: [ :label |
		labels add: label.
	].! !
!TMethod methodsFor: 'utilities'!
allCalls
	"Answer a collection of selectors for the messages sent by this method."

	^parseTree allCalls! !
!TMethod methodsFor: 'inlining'!
argAssignmentsFor: meth args: argList in: aCodeGen
	"Return a collection of assignment nodes that assign the given argument expressions to the formal parameter variables of the given method."
	"Optimization: If the actual parameters are either constants or local variables in the target method (the receiver), substitute them directly into the body of meth. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals."

	| stmtList substitutionDict |
	stmtList := OrderedCollection new: 100.
	substitutionDict := Dictionary new: 100.
	meth args with: argList do: [ :argName :exprNode |
		(self isSubstitutableNode: exprNode intoMethod: meth in: aCodeGen) ifTrue: [
			substitutionDict at: argName put: exprNode.
			locals remove: argName.
		] ifFalse: [
			stmtList add: (TAssignmentNode new
				setVariable: (TVariableNode new setName: argName)
				expression: exprNode copyTree).
		].
	].
	meth parseTree: (meth parseTree bindVariablesIn: substitutionDict).
	^stmtList! !
!TMethod methodsFor: 'primitive compilation' stamp: 'ar 11/8/2010 18:38'!
argConversionExprFor: varName stackIndex: stackIndex 
	"Return the parse tree for an expression that fetches and converts the 
	primitive argument at the given stack offset."
	| exprList decl stmtList |
	exprList := OrderedCollection new.
	(declarations includesKey: varName) ifTrue:[
		decl := declarations at: varName.
		(decl includes: $*) ifTrue:["array"
			(decl includesSubString: 'char') ifTrue:[ | expr |
				expr := '(interpreterProxy isBytes: (interpreterProxy stackValue: (stackIndex))) ifFalse:[^interpreterProxy primitiveFail].'.
				expr := expr copyReplaceAll: 'interpreterProxy' with: self vmNameString.
				expr := expr copyReplaceAll: 'stackIndex' with: stackIndex printString.
				exprList add: expr.
			].
			exprList add: varName , ' := ', self vmNameString, ' arrayValueOf: (', self vmNameString, ' stackValue: (' , stackIndex printString , '))'.
			exprList add: varName , ' := ' , varName , ' - 1'.
		] ifFalse:["must be a double"
			(decl findString: 'double' startingAt: 1) = 0 ifTrue: [
				self error: 'unsupported type declaration in a primitive method'
			].
			exprList add: varName , ' := ', self vmNameString, ' stackFloatValue: ' , stackIndex printString.
		]
	] ifFalse: ["undeclared variables are taken to be integer"
		exprList add: varName , ' := ', self vmNameString, ' stackIntegerValue: ' , stackIndex printString
	].
	stmtList := OrderedCollection new.
	exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)].
	^ stmtList! !
!TMethod methodsFor: 'accessing'!
args
	"The arguments of this method."

	^args! !
!TMethod methodsFor: 'transformations' stamp: 'ar 7/6/2003 20:09'!
asInlineNode
	^TInlineNode new method: self! !
!TMethod methodsFor: 'transformations'!
bindClassVariablesIn: constantDictionary
	"Class variables are used as constants. This method replaces all references to class variables in the body of this method with the corresponding constant looked up in the class pool dictionary of the source class. The source class class variables should be initialized before this method is called."

	parseTree := parseTree bindVariablesIn: constantDictionary.! !
!TMethod methodsFor: 'transformations' stamp: 'ar 7/6/2003 20:35'!
bindVariableUsesIn: aDictionary
	parseTree := parseTree bindVariableUsesIn: aDictionary.! !
!TMethod methodsFor: 'transformations' stamp: 'ar 11/19/1999 14:40'!
buildCaseStmt: aSendNode
	"Build a case statement node for the given send of dispatchOn:in:."
	"Note: the first argument is the variable to be dispatched on. The second argument is a constant node holding an array of unary selectors, which will be turned into sends to self."

	((aSendNode args size >= 2) and:
	 [aSendNode args second isConstant and:
	 [aSendNode args second value class = Array]]) ifFalse: [
		self error: 'wrong node structure for a case statement'.
	].

	^TCaseStmtNode new
		setExpression: aSendNode args first
		selectors: aSendNode args second value
		arguments: (aSendNode args copyFrom: 3 to: aSendNode args size)! !
!TMethod methodsFor: 'inlining'!
checkForCompleteness: stmtLists in: aCodeGen
	"Set the complete flag if none of the given statement list nodes contains further candidates for inlining."

	complete := true.
	stmtLists do: [ :stmtList |
		stmtList statements do: [ :node |
			(self inlineableSend: node in: aCodeGen) ifTrue: [
				complete := false.  "more inlining to do"
				^self
			].
		].
	].
	parseTree nodesDo: [ :n |
		(self inlineableFunctionCall: n in: aCodeGen) ifTrue: [
			complete := false.  "more inlining to do"
			^self
		].
	].! !
!TMethod methodsFor: 'primitive compilation'!
checkSuccessExpr
	"Return the parse tree for an expression that aborts the primitive if the successFlag is not true."

	| expr |
	expr := 'successFlag ifFalse: [^ nil ]'.
	^ self statementsFor: expr varName: ''
! !
!TMethod methodsFor: 'accessing' stamp: 'hg 8/14/2000 15:57'!
comment: aComment

	comment := aComment ! !
!TMethod methodsFor: 'inlining support'!
computePossibleSideEffectsIn: aCodeGen
	"Answer true if this method may have side effects. It has side effects if it assigns to a global variable. It may have side effects if it calls a non-built-in method."

	parseTree nodesDo: [ :node |
		node isSend ifTrue: [
			node isBuiltinOperator ifFalse: [ ^true ].
		].
	].
	^ false! !
!TMethod methodsFor: 'utilities' stamp: 'ar 7/6/2003 21:40'!
copy
	"Make a deep copy of this TMethod."

	^ (self class basicNew)
		setSelector: selector
		returnType: returnType
		args: args copy
		locals: locals copy
		declarations: declarations copy
		primitive: primitive
		parseTree: parseTree copyTree
		labels: labels copy
		complete: complete;
		sharedLabel: sharedLabel;
		sharedCase: sharedCase;
		yourself
! !
!TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/15/98 16:48'!
covertToZeroBasedArrayReferences
	"Replace the index expressions in at: and at:put: messages with (<expr> - 1), since C uses zero-based array indexing."
	"Note: Up through release 1.31, generated primitives used the convention that array variables pointed to the first element. That meant that Smalltalk one-based index expressions had to have one subtracted to yield a zero-based index. Later, we decided to adjust the base address by -1 once in the primitive prolog rather on every array access. This resulted in a five percent performance increase for the bitmap compress/decompress primitives. This method is retained as documentation and in case we choose to revert the the previous scheme."

	| oldIndexExpr newIndexExpr |
	parseTree nodesDo: [ :n |
		(n isSend and: [(n selector = #at:) or: [ n selector = #at:put: ]]) ifTrue: [
			oldIndexExpr := n args first.
			oldIndexExpr isConstant ifTrue: [
				"index expression is a constant: decrement the constant now"
				newIndexExpr := TConstantNode new setValue: (n args first value - 1).
			] ifFalse: [
				"index expression is complex: build an expression to decrement result at runtime"
				newIndexExpr := TSendNode new
					setSelector: #-
					receiver: oldIndexExpr
					arguments: (Array with: (TConstantNode new setValue: 1)).
			].
			n args at: 1 put: newIndexExpr.
		].
	].
! !
!TMethod methodsFor: 'accessing' stamp: 'eem 3/3/2009 08:59'!
declarationAt: aVariableName
	^declarations at: aVariableName ifAbsent: [#sqInt, ' ', aVariableName]! !
!TMethod methodsFor: 'accessing' stamp: 'eem 3/3/2009 08:42'!
declarationAt: aVariableName  "<String>" put: aDeclaration "<String>" "^aDeclaration"
	^declarations at: aVariableName put: aDeclaration! !
!TMethod methodsFor: 'accessing'!
declarations
	"The type declaration dictionary of this method."

	^declarations! !
!TMethod methodsFor: 'accessing' stamp: 'ar 2/3/2001 17:29'!
definingClass
	^definingClass! !
!TMethod methodsFor: 'accessing' stamp: 'ar 2/3/2001 17:29'!
definingClass: aClass
	definingClass := aClass.! !
!TMethod methodsFor: 'C code generation' stamp: 'dtl 11/4/2010 07:04'!
emitCCodeOn: aStream generator: aCodeGen
	"Emit C code for this method onto the given stream. All calls to inlined methods should already have been expanded."

	aCodeGen currentMethod: self.
	self emitCCommentOn: aStream.	"place method comment before function"
	self emitCHeaderOn: aStream generator: aCodeGen.
	parseTree emitCCodeOn: aStream level: 1 generator: aCodeGen.
	aStream nextPutAll: '}'; cr.! !
!TMethod methodsFor: 'C code generation' stamp: 'hg 8/14/2000 16:09'!
emitCCommentOn: aStream
	"Emit the transferred Smalltalk comments as C comments."

	comment ifNotNil: [
		aStream cr;cr.
		1 to: comment size do: [:index | 
			aStream 
				nextPutAll: '/*'; tab;
				nextPutAll: (comment at: index);
				nextPutAll: ' */';
				cr]]! !
!TMethod methodsFor: 'C code generation' stamp: 'dtl 2/3/2007 11:02'!
emitCFunctionPrototype: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	| arg |
	export 
		ifTrue:[aStream nextPutAll:'EXPORT('; nextPutAll: returnType; nextPutAll:') ']
		ifFalse:[(aCodeGen isGeneratingPluginCode and:[self isStatic]) 
					ifTrue:[aStream nextPutAll:'static '].
				aStream nextPutAll: returnType; space].
	aStream nextPutAll: (aCodeGen cFunctionNameFor: self selectorForCodeGeneration), '('.
	args isEmpty ifTrue: [ aStream nextPutAll: 'void' ].
	1 to: args size do: [ :i |
		arg := args at: i.
		(declarations includesKey: arg) ifTrue: [
			aStream nextPutAll: (declarations at: arg).
		] ifFalse: [
			aStream nextPutAll: 'sqInt ', (args at: i).
		].
		i < args size ifTrue: [ aStream nextPutAll: ', ' ].
	].
	aStream nextPutAll: ')'.! !
!TMethod methodsFor: 'C code generation' stamp: 'ikp 6/9/2004 16:15'!
emitCHeaderOn: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	aStream cr. 
	self emitCFunctionPrototype: aStream generator: aCodeGen.
	aStream nextPutAll: ' {'; cr.
	self emitGlobalStructReferenceOn: aStream.
	locals do: [ :var |
		aStream nextPutAll: '    '.
		aStream nextPutAll: (declarations at: var ifAbsent: [ 'sqInt ', var]), ';'; cr.
	].
	locals isEmpty ifFalse: [ aStream cr ].! !
!TMethod methodsFor: 'C code generation'!
emitGlobalStructReferenceOn: aStream
	"Add a reference to the globals struct if needed"

	(self globalStructureBuildMethodHasFoo > 1)
		ifTrue: [aStream nextPutAll: 'register struct foo * foo = &fum;'; cr].
! !
!TMethod methodsFor: 'C code generation' stamp: 'ikp 6/9/2004 16:15'!
emitInlineOn: aStream level: level generator: aCodeGen
	"Emit C code for this method onto the given stream. All calls to inlined methods should already have been expanded."
	self removeUnusedTemps.
	sharedLabel ifNotNil:[
		aStream crtab: level-1; nextPutAll: sharedLabel; nextPutAll:':'.
		aStream crtab: level.
		aStream nextPutAll: '/* '; nextPutAll: selector; nextPutAll: ' */'.
		aStream crtab: level.
	].
	aStream nextPutAll:'{'; cr.
	locals do: [ :var |
		aStream tab: level+1.
		aStream nextPutAll: (declarations at: var ifAbsent: [ 'sqInt ', var]), ';'; cr.
	].
	parseTree emitCCodeOn: aStream level: level+1 generator: aCodeGen.
	aStream tab: level; nextPutAll: '}'; cr.! !
!TMethod methodsFor: 'C code generation' stamp: 'dtl 2/3/2007 11:03'!
emitProxyFunctionPrototype: aStream generator: aCodeGen
	"Emit an indirect C function header for this method onto the given stream."

	| arg |
	aStream nextPutAll: returnType; space.
	aStream nextPutAll: '(*', (aCodeGen cFunctionNameFor: self selectorForCodeGeneration), ')('.
	args isEmpty ifTrue: [ aStream nextPutAll: 'void' ].
	1 to: args size do: [ :i |
		arg := args at: i.
		(declarations includesKey: arg) ifTrue: [
			aStream nextPutAll: (declarations at: arg).
		] ifFalse: [
			aStream nextPutAll: 'sqInt ', (args at: i).
		].
		i < args size ifTrue: [ aStream nextPutAll: ', ' ].
	].
	aStream nextPutAll: ')'.! !
!TMethod methodsFor: 'inlining support'!
endsWithReturn
	"Answer true if the last statement of this method is a return."

	^ parseTree statements last isReturn! !
!TMethod methodsFor: 'inlining'!
exitVar: exitVar label: exitLabel
	"Replace each return statement in this method with an assignment to the exit variable followed by a goto to the given label. Return true if a goto was generated."
	"Optimization: If exitVar is nil, the return value of the inlined method is not being used, so don't add the assignment statement."

	| newStmts labelUsed |
	labelUsed := false.
	parseTree nodesDo: [ :node |
		node isStmtList ifTrue: [
			newStmts := OrderedCollection new: 100.
			node statements do: [ :stmt |
				(stmt isReturn) ifTrue: [
					exitVar = nil ifTrue: [
						stmt expression isLeaf ifFalse: [
							"evaluate return expression even though value isn't used"
							newStmts add: stmt expression.
						].
					] ifFalse: [
						"assign return expression to exit variable"
						newStmts add:
							(TAssignmentNode new
								setVariable: (TVariableNode new setName: exitVar)
								expression: stmt expression).
					].
					(stmt == parseTree statements last) ifFalse: [
						"generate a goto (this return is NOT the last statement in the method)"
						newStmts add: (TGoToNode new setLabel: exitLabel).
						labelUsed := true.
					].
				] ifFalse: [
					newStmts addLast: stmt.
				].
			].
			node setStatements: newStmts asArray.
		].
	].
	^labelUsed! !
!TMethod methodsFor: 'accessing' stamp: 'jm 11/24/1998 09:03'!
export

	^ export
! !
!TMethod methodsFor: 'transformations' stamp: 'eem 12/15/2008 09:52'!
extractDirective: theSelector valueBlock: aBlock default: defaultResult
	"Find a pragma of the form:

		<theSelector[args]>

	 Answer the result of evaluating aBock with a TSendNode corresponding
	 to the pragma node, or defaultResult if there is no matching pragma."

	| result found newStatements |
	(properties at: theSelector ifAbsent: []) ifNotNil:
		[:pragma|
		^aBlock value: (TSendNode new
							setSelector: pragma keyword
							receiver: (TVariableNode new setName: 'self')
							arguments: (pragma arguments collect: [:const| TConstantNode new setValue: const]))].
	"Pre-pragma backward compatibility:
	 Scan the top-level statements for a labelling directive of the form:

		self theSelector[args]

	 and remove the directive from the method body if found.
	 Answer the result of evaluating aBock with the send node,
	  or defaultResult if there is no labelling directive."	result := defaultResult.
	found := false.
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do:
		[ :stmt |
		(stmt isSend
		 and: [stmt selector = theSelector])
			ifTrue:
				[found := true.
				 result := aBlock value: stmt]
			ifFalse:
				[newStatements add: stmt]].
	^found
		ifTrue:
			[parseTree setStatements: newStatements asArray.
			 result]
		ifFalse: [defaultResult]! !
!TMethod methodsFor: 'transformations' stamp: 'dtl 9/19/2010 12:19'!
extractExportDirective
	"Scan the top-level statements for an inlining directive of the form:

		self export: <boolean>

	 and remove the directive from the method body. Return the argument of the directive or false if there is no export directive."

	| result newStatements methodDirectiveFound |
	result := false.
	methodDirectiveFound := false.
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #export:]) ifTrue: [
			methodDirectiveFound := true.
			result := stmt args first value = true.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	methodDirectiveFound ifTrue: [^ result].
	"no method declaration was used, so check for a pragma declaration"
	^self
		extractDirective: #export:
		valueBlock: [:sendNode| sendNode args first value ~= false]
		default: false
! !
!TMethod methodsFor: 'inlining support' stamp: 'dtl 9/19/2010 13:20'!
extractInlineDirective
	"Scan the top-level statements for an inlining directive of the form:

		self inline: <boolean>

	 and remove the directive from the method body. Return the argument of the directive or #dontCare if there is no inlining directive."

	| result newStatements methodDirectiveFound |
	sharedCase ifNotNil:[^false]. "don't auto-inline shared code; it gets handled specially"
	result := #dontCare.
	methodDirectiveFound := false.
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #inline:]) ifTrue: [
			methodDirectiveFound := true.
			result := stmt args first value = true.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	methodDirectiveFound ifTrue: [^ result].
	"no method declaration was used, so check for a pragma declaration"
	sharedCase ifNotNil: [^false]. "don't auto-inline shared code; it gets handled specially"
	^self
		extractDirective: #inline:
		valueBlock: [:sendNode| sendNode args first value = true]
		default: #dontCare! !
!TMethod methodsFor: 'transformations' stamp: 'eem 11/18/2008 12:44'!
extractLabelDirective
	"Scan the top-level statements for an inlining directive of the form:

		self asmLabel: <boolean>

	 and remove the directive from the method body. Answer the
	 argument of the directive or true if there is no export directive."

	^self
		extractDirective: #asmLabel:
		valueBlock: [:sendNode| sendNode args first value ~= false and: [mustAsmLabel := true. true]]
		default: true! !
!TMethod methodsFor: 'transformations' stamp: 'ar 7/7/2003 00:56'!
extractSharedCase
	"Scan the top-level statements for an shared case directive of the form:

		self sharedCodeNamed: <sharedLabel> inCase: <sharedCase>.

	and remove the directive from the method body."

	| newStatements |
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #sharedCodeNamed:inCase:]) ifTrue: [
			sharedLabel := stmt args first value.
			sharedCase := stmt args last value
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	sharedCase ifNotNil:[
		args isEmpty ifFalse:[self error: 'Cannot share code sections in methods with arguments'].
	].! !
!TMethod methodsFor: 'transformations' stamp: 'dtl 9/19/2010 13:00'!
extractStaticDirective
	"Scan the top-level statements for an inlining directive of the form:

		self static: <boolean>

	 and remove the directive from the method body. Return the argument of the directive or true if there is no static directive."

	| result newStatements methodDirectiveFound |
	result := true.
	methodDirectiveFound := false.
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #static:]) ifTrue: [
			methodDirectiveFound := true.
			result := stmt args first value ~= false.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	methodDirectiveFound ifTrue: [^ result].
	"no method declaration was used, so check for a pragma declaration"
	^self
		extractDirective: #static:
		valueBlock: [:sendNode| sendNode args first value ~= false]
		default: (export or: [(properties includesKey: #api) or: [properties includesKey: #api:]]) not
	! !
!TMethod methodsFor: 'primitive compilation' stamp: 'ar 4/4/2006 21:15'!
fetchRcvrExpr
	"Return the parse tree for an expression that fetches the receiver from the stack."

	| expr |
	expr := 'rcvr := ', self vmNameString, ' stackValue: (', args size printString, ')'.
	^ self statementsFor: expr varName: ''
! !
!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:19'!
fixUpReturns: argCount postlog: postlog
	"Replace each return statement in this method with (a) the given postlog, (b) code to pop the receiver and the given number of arguments, and (c) code to push the integer result and return."

	| newStmts |
	parseTree nodesDo: [:node |
		node isStmtList ifTrue: [
			newStmts := OrderedCollection new: 100.
			node statements do: [:stmt |
				stmt isReturn
					ifTrue: [
						(stmt expression isSend and:
						 ['primitiveFail' = stmt expression selector])
							ifTrue: [  "failure return"
								newStmts addLast: stmt expression.
								newStmts addLast: (TReturnNode new
									setExpression: (TVariableNode new setName: 'null'))]
							ifFalse: [  "normal return"
								newStmts addAll: postlog.
								newStmts addAll: (self popArgsExpr: argCount + 1).
								newStmts addLast: (TSendNode new
									setSelector: #pushInteger:
									receiver: (TVariableNode new setName: self vmNameString)
									arguments: (Array with: stmt expression)).
								newStmts addLast: (TReturnNode new
									setExpression: (TVariableNode new setName: 'null'))]]
					ifFalse: [
						newStmts addLast: stmt]].
			node setStatements: newStmts asArray]].
! !
!TMethod methodsFor: 'utilities'!
freeVariableReferences
	"Answer a collection of variables referenced this method, excluding locals, arguments, and pseudovariables."

	| refs |
	refs := Set new.
	parseTree nodesDo: [ :node |
		node isVariable ifTrue: [ refs add: node name asString ].
	].
	args do: [ :var | refs remove: var asString ifAbsent: [] ].
	locals do: [ :var | refs remove: var asString ifAbsent: [] ].
	#('self' 'nil' 'true' 'false') do: [ :var | refs remove: var ifAbsent: [] ].
	^ refs asSortedCollection! !
!TMethod methodsFor: 'accessing' stamp: 'jm 11/24/1998 09:03'!
globalStructureBuildMethodHasFoo
	^globalStructureBuildMethodHasFoo! !
!TMethod methodsFor: 'accessing'!
globalStructureBuildMethodHasFoo: number
	globalStructureBuildMethodHasFoo := number! !
!TMethod methodsFor: 'utilities'!
hasNoCCode
	"Answer true if the receiver does not use inlined C or C declarations, which are not currently renamed properly by the the inliner."

	declarations isEmpty ifFalse: [ ^ false ].

	parseTree nodesDo: [ :node |
		node isSend ifTrue: [
			node selector = #cCode: ifTrue: [ ^ false ].
		].
	].
	^ true! !
!TMethod methodsFor: 'testing'!
hasReturn
	"Answer true if this method contains a return statement."

	parseTree nodesDo: [ :n | n isReturn ifTrue: [ ^ true ]].
	^ false! !
!TMethod methodsFor: 'inlining' stamp: 'dtl 8/17/2008 18:46'!
inlineCaseStatementBranchesIn: aCodeGen localizingVars: varsList

	| stmt sel meth newStatements maxTemp usedVars exitLabel v |
	maxTemp := 0.
	parseTree nodesDo: [ :n |
		n isCaseStmt ifTrue: [
			n cases do: [ :stmtNode |
				stmt := stmtNode statements first.
				stmt isSend ifTrue: [
					sel := stmt selector.
					meth := aCodeGen methodNamed: sel.
					"Note, original version of this method tested for #hasNoCCode. Removed
					the test to permit inlining methods that may contain automatically
					generated C code for type conversions. -dtl"
					((meth ~= nil) and:
					 [meth args size = 0]) ifTrue: [
						meth := meth copy.
						meth hasReturn ifTrue: [
							exitLabel := self unusedLabelForInliningInto: self.
							meth exitVar: nil label: exitLabel.
							labels add: exitLabel.
						] ifFalse: [ exitLabel := nil ].

						meth renameLabelsForInliningInto: self.
						meth labels do: [ :label | labels add: label ].
						newStatements := stmtNode statements asOrderedCollection.
						newStatements removeFirst.

						exitLabel ~= nil ifTrue: [
							newStatements addFirst:
								(TLabeledCommentNode new
									setLabel: exitLabel comment: 'end case').
						].

						newStatements addFirst: meth asInlineNode.
						newStatements addFirst:
							(TLabeledCommentNode new setComment: meth selector).
						stmtNode setStatements: newStatements.
					].
				].
			].
		].
	].
	usedVars := (locals, args) asSet.
	1 to: maxTemp do: [ :i |
		v := ('t', i printString).
		(usedVars includes: v) ifTrue: [ self error: 'temp variable name conflicts with an existing local or arg' ].
		locals addLast: v.
	].

	"make local versions of the given globals"
	varsList do: [ :var |
		(usedVars includes: var) ifFalse: [ locals addFirst: var asString ].
	].
! !
!TMethod methodsFor: 'inlining'!
inlineCodeOrNilForStatement: aNode in: aCodeGen
	"If the given statement node can be inlined, answer the statements that replace it. Otherwise, answer nil."

	| stmts |
	aNode isReturn ifTrue: [
		(self inlineableSend: aNode expression in: aCodeGen) ifTrue: [
			stmts := self inlineSend: aNode expression
				directReturn: true exitVar: nil in: aCodeGen.
			^stmts
		].
	].
	aNode isAssignment ifTrue: [
		(self inlineableSend: aNode expression in: aCodeGen) ifTrue: [
			^self inlineSend: aNode expression
				directReturn: false exitVar: aNode variable name in: aCodeGen
		].
	].
	aNode isSend ifTrue: [
		(self inlineableSend: aNode in: aCodeGen) ifTrue: [
			^self inlineSend: aNode
				directReturn: false exitVar: nil in: aCodeGen
		].
	].
	^nil! !
!TMethod methodsFor: 'inlining' stamp: 'dtl 6/3/2010 00:31'!
inlineFunctionCall: aSendNode in: aCodeGen
	"Answer the body of the called function, substituting the actual parameters for the formal argument variables in the method body."
	"Assume caller has established that:
		1. the method arguments are all substitutable nodes, and
		2. the method to be inlined contains no additional embedded returns."

	| sel meth substitutionDict |
	sel := aSendNode selector.
	meth := (aCodeGen methodNamed: sel) copy.
	meth renameVarsForInliningInto: self in: aCodeGen.
	meth renameLabelsForInliningInto: self.
	self addVarsDeclarationsAndLabelsOf: meth.
	substitutionDict := Dictionary new: 100.
	meth args with: aSendNode args do: [ :argName :exprNode |
		substitutionDict at: argName put: exprNode.
		locals remove: argName.
		declarations removeKey: argName ifAbsent: []].
	meth parseTree bindVariablesIn: substitutionDict.
	^ meth statements first expression! !
!TMethod methodsFor: 'inlining' stamp: 'ikp 6/9/2004 16:15'!
inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen
	"Answer a collection of statments to replace the given send. directReturn indicates that the send is the expression of a return statement, so returns can be left in the body of the inlined method. If exitVar is nil, the value returned by the send is not used; thus, returns need not assign to the output variable."

	| sel meth exitLabel labelUsed inlineStmts |
	sel := aSendNode selector.
	meth := (aCodeGen methodNamed: sel) copy.
	meth renameVarsForInliningInto: self in: aCodeGen.
	meth renameLabelsForInliningInto: self.
	self addVarsDeclarationsAndLabelsOf: meth.
	meth hasReturn ifTrue: [
		directReturn ifTrue: [
			"propagate the return type, if necessary"
			returnType = meth returnType ifFalse: [ self halt ].  "caller's return type should be declared by user"
			returnType := meth returnType.
		] ifFalse: [
			exitLabel := self unusedLabelForInliningInto: self.
			labelUsed := meth exitVar: exitVar label: exitLabel.
			labelUsed
				ifTrue: [ labels add: exitLabel ]
				ifFalse: [ exitLabel := nil ].
		].
		"propagate type info if necessary"
		((exitVar ~= nil) and: [meth returnType ~= 'sqInt']) ifTrue: [
			declarations at: exitVar put: meth returnType, ' ', exitVar.
		].
	].
	inlineStmts := OrderedCollection new: 100.
	inlineStmts add: (TLabeledCommentNode new setComment: 'begin ', sel).
	inlineStmts addAll:
		(self argAssignmentsFor: meth args: aSendNode args in: aCodeGen).
	inlineStmts addAll: meth statements.  "method body"
	(directReturn and: [meth endsWithReturn not]) ifTrue: [
		inlineStmts add: (TReturnNode new setExpression: (TVariableNode new setName: 'nil')).
	].
	exitLabel ~= nil ifTrue: [
		inlineStmts add:
			(TLabeledCommentNode new
				setLabel: exitLabel comment: 'end ', meth selector).
	].
	^inlineStmts! !
!TMethod methodsFor: 'inlining'!
inlineableFunctionCall: aNode in: aCodeGen
	"Answer true if the given send node is a call to a 'functional' method--a method whose body is a single return statement of some expression and whose actual parameters can all be directly substituted."

	| m |
	aNode isSend ifFalse: [ ^false ].
	m := aCodeGen methodNamed: aNode selector.  "nil if builtin or external function"
	((m ~= nil) and: [m isFunctional and: [aCodeGen mayInline: m selector]]) ifTrue: [
		aNode args do: [ :a | (self isSubstitutableNode: a intoMethod: m in: aCodeGen) ifFalse: [ ^false ]].
		^true
	] ifFalse: [
		^false
	].! !
!TMethod methodsFor: 'inlining'!
inlineableSend: aNode in: aCodeGen
	"Answer true if the given send node is a call to a method that can be inlined."

	| m |
	aNode isSend ifFalse: [ ^false ].
	m := aCodeGen methodNamed: aNode selector.  "nil if builtin or external function"
	^(m ~= nil) and: [m isComplete and: [aCodeGen mayInline: m selector]]! !
!TMethod methodsFor: 'primitive compilation' stamp: 'ar 4/4/2006 21:15'!
instVarGetExprFor: varName offset: instIndex
	"Return the parse tree for an expression that fetches and converts the value of the instance variable at the given offset."

	| exprList decl stmtList |
	exprList := OrderedCollection new.
	(declarations includesKey: varName) ifTrue: [
		decl := declarations at: varName.
		(decl includes: $*) ifTrue: [  "array"
			exprList add:
				(varName, ' := ', self vmNameString, ' fetchArray: ', instIndex printString, ' ofObject: rcvr').
			exprList add: (varName, ' := ', varName, ' - 1').
		] ifFalse: [  "must be a double"
			((decl findString: 'double' startingAt: 1) = 0)
				ifTrue: [ self error: 'unsupported type declaration in a primitive method' ].
			exprList add:
				(varName, ' := ', self vmNameString, ' fetchFloat: ', instIndex printString, ' ofObject: rcvr').
		].
	] ifFalse: [  "undeclared variables are taken to be integer"
		exprList add:
			(varName, ' := ', self vmNameString, ' fetchInteger: ', instIndex printString, ' ofObject: rcvr').
	].
	stmtList := OrderedCollection new.
	exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)].
	^ stmtList
! !
!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:13'!
instVarPutExprFor: varName offset: instIndex
	"Return the parse tree for an expression that saves the value of the integer instance variable at the given offset."

	| expr |
	(declarations includesKey: varName) ifTrue: [
		self error: 'a primitive method can only modify integer instance variables'.
	].
	expr := '', self vmNameString, ' storeInteger: ', instIndex printString, ' ofObject: rcvr withValue: ', varName.
	^ self statementsFor: expr varName: varName
! !
!TMethod methodsFor: 'testing' stamp: 'ikp 9/26/97 14:50'!
isAssertion
	^(selector beginsWith: 'assert') or: [selector beginsWith: 'verify']! !
!TMethod methodsFor: 'accessing'!
isComplete
	"A method is 'complete' if it does not contain any more inline-able calls."

	^complete! !
!TMethod methodsFor: 'inlining'!
isFunctional
	"Answer true if the receiver is a functional method. That is, if it consists of a single return statement of an expression that contains no other returns."

	(parseTree statements size = 1 and:
	 [parseTree statements last isReturn]) ifFalse: [ ^false ].
	parseTree statements last expression nodesDo: [ :n | n isReturn ifTrue: [ ^false ]].
	^true! !
!TMethod methodsFor: 'accessing' stamp: 'ar 5/9/2000 12:13'!
isStatic
	^static ifNil:[false].! !
!TMethod methodsFor: 'inlining' stamp: 'ar 5/9/2000 12:13'!
isSubstitutableNode: aNode
	"Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals."

	aNode isConstant ifTrue: [ ^true ].
	^aNode isVariable and:
		[(locals includes: aNode name) or:
		[args includes: aNode name]]! !
!TMethod methodsFor: 'inlining'!
isSubstitutableNode: aNode intoMethod: targetMeth in: aCodeGen
	"Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted into methods with possible side effects (i.e., methods that may assign to global variables) because the inlined method might depend on having the value of the global variable captured when it is passed in as an argument."

	| var |
	aNode isConstant ifTrue: [ ^ true ].

	aNode isVariable ifTrue: [
		var := aNode name.
		((locals includes: var) or: [args includes: var]) ifTrue: [ ^ true ].
		(#(self true false nil) includes: var) ifTrue: [ ^ true ].
		(targetMeth maySubstituteGlobal: var in: aCodeGen) ifTrue: [ ^ true ].
	].

	"scan expression tree; must contain only constants, builtin ops, and inlineable vars"
	aNode nodesDo: [ :node |
		node isSend ifTrue: [
			node isBuiltinOperator ifFalse: [ ^false ].
		].
		node isVariable ifTrue: [
			var := node name.
			((locals includes: var) or:
			 [(args includes: var) or:
			 [(#(self true false nil) includes: var) or:
			 [targetMeth maySubstituteGlobal: var in: aCodeGen]]]) ifFalse: [ ^ false ].
		].
		(node isConstant or: [node isVariable or: [node isSend]]) ifFalse: [ ^false ].
	].

	^ true! !
!TMethod methodsFor: 'accessing' stamp: 'ar 5/9/2000 12:13'!
labels

	^labels! !
!TMethod methodsFor: 'accessing' stamp: 'ar 5/9/2000 12:13'!
locals
	"The local variables of this method."

	^locals! !
!TMethod methodsFor: 'inlining support'!
maySubstituteGlobal: globalVar in: aCodeGen
	"Answer true if this method does or may have side effects on the given global variable."

	possibleSideEffectsCache = nil ifTrue: [
		"see if this calls any other method and record the result"
		possibleSideEffectsCache := self computePossibleSideEffectsIn: aCodeGen.
	].
	possibleSideEffectsCache ifTrue: [ ^ false ].

	parseTree nodesDo: [ :node |
		node isAssignment ifTrue: [
			node variable name = globalVar ifTrue: [ ^ false ].
		].
	].

	"if we get here, receiver calls no other method
	 and does not itself assign to the given global variable"
	^ true! !
!TMethod methodsFor: 'initialization' stamp: 'eem 10/2/2009 12:01'!
newCascadeTempFor: aTParseNode
	| varNode |
	cascadeVariableNumber := cascadeVariableNumber
								ifNil: [0]
								ifNotNil: [cascadeVariableNumber + 1].
	varNode := TVariableNode new setName: 'cascade', cascadeVariableNumber printString.
	aTParseNode isLeaf ifFalse:
		[declarations
			at: varNode name
			put: [:cg| self determineTypeFor: aTParseNode in: cg]].
	^varNode! !
!TMethod methodsFor: 'utilities'!
nodeCount
	"Answer the number of nodes in this method's parseTree (a rough measure of its size)."

	| cnt |
	cnt := 0.
	parseTree nodesDo: [ :n | cnt := cnt + 1 ].
	^cnt! !
!TMethod methodsFor: 'accessing'!
parseTree
	"The parse tree of this method."

	^parseTree! !
!TMethod methodsFor: 'accessing'!
parseTree: aNode
	"Set the parse tree of this method."

	parseTree := aNode.! !
!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:13'!
popArgsExpr: argCount
	"Return the parse tree for an expression that pops the given number of arguments from the stack."

	| expr |
	expr := '', self vmNameString, ' pop: ', argCount printString.
	^ self statementsFor: expr varName: ''
! !
!TMethod methodsFor: 'transformations' stamp: 'ar 11/18/1999 20:09'!
prepareMethodIn: aCodeGen
	"Record sends of builtin operators and replace sends of the special selector dispatchOn:in: with case statement nodes."
	"Note: Only replaces top-level sends of dispatchOn:in:. Case statements must be top-level statements; they cannot appear in expressions."

	| stmts stmt |
	parseTree nodesDo: [ :node |
		node isSend ifTrue: [
			"record sends of builtin operators"
			(aCodeGen builtin: node selector) ifTrue: [ node isBuiltinOperator: true ].
		].
		node isStmtList ifTrue: [
			"replace dispatchOn:in: with case statement node"
			stmts := node statements.
			1 to: stmts size do: [ :i |
				stmt := stmts at: i.
				(stmt isSend and: [CaseStatements includes: stmt selector]) ifTrue: [
					stmts at: i put: (self buildCaseStmt: stmt).
				].
			].
		].
	].! !
!TMethod methodsFor: 'primitive compilation' stamp: 'ar 2/3/2001 17:33'!
preparePrimitiveName
	"Prepare the selector for this method in translation"
	| aClass |
	aClass := definingClass.
	primitive = 117 
		ifTrue:[selector := ((aClass includesSelector: selector)
					ifTrue: [aClass compiledMethodAt: selector]
					ifFalse: [aClass class compiledMethodAt: selector]) literals first at: 2.
				export := true]
		ifFalse:[selector := 'prim', aClass name, selector].

! !
!TMethod methodsFor: 'primitive compilation' stamp: 'ar 2/3/2001 17:36'!
preparePrimitivePrologue
	"Add a prolog and postlog to a primitive method. The prolog copies any instance variables referenced by this primitive method into local variables. The postlog copies values of assigned-to variables back into the instance. The names of the new locals are added to the local variables list.

The declarations dictionary defines the types of any non-integer variables (locals, arguments, or instance variables). In particular, it may specify the types:

	int *		-- an array of 32-bit values (e.g., a BitMap)
	short *		-- an array of 16-bit values (e.g., a SoundBuffer)
	char *		-- an array of unsigned bytes (e.g., a String)
	double		-- a double precision floating point number (e.g., 3.14159)

Undeclared variables are taken to be integers and will be converted from Smalltalk to C ints."

"Current restrictions:
	o method must not contain message sends
	o method must not allocate objects
	o method must not manipulate raw oops
	o method cannot access class variables
	o method can only return an integer"

	| prolog postlog instVarsUsed varsAssignedTo instVarList primArgCount varName endsWithReturn aClass |
selector == #setInterpreter: ifTrue:[self halt].
	aClass := definingClass.
	prolog := OrderedCollection new.
	postlog := OrderedCollection new.
	instVarsUsed := self freeVariableReferences asSet.
	varsAssignedTo := self variablesAssignedTo asSet.
	instVarList := aClass allInstVarNames.
	primArgCount := args size.

	"add receiver fetch and arg conversions to prolog"
	prolog addAll: self fetchRcvrExpr.
	1 to: args size do: [:argIndex |
		varName := args at: argIndex.
		prolog addAll:
			(self argConversionExprFor: varName stackIndex: args size - argIndex)].

	"add success check to postlog"
	postlog addAll: self checkSuccessExpr.

	"add instance variable fetches to prolog and instance variable stores to postlog"
	1 to: instVarList size do: [:varIndex |
		varName := instVarList at: varIndex.
		(instVarsUsed includes: varName) ifTrue: [
			locals add: varName.
			prolog addAll: (self instVarGetExprFor: varName offset: varIndex - 1).
			(varsAssignedTo includes: varName) ifTrue: [
				postlog addAll: (self instVarPutExprFor: varName offset: varIndex - 1)]]].
	prolog addAll: self checkSuccessExpr.

	locals addAllFirst: args.
	locals addFirst: 'rcvr'.
	args := args class new.
	locals asSet size = locals size
		ifFalse: [self error: 'local name conflicts with instance variable name'].
	endsWithReturn := self endsWithReturn.
	self fixUpReturns: primArgCount postlog: postlog.

	endsWithReturn
		ifTrue: [parseTree setStatements: prolog, parseTree statements]
		ifFalse: [
			postlog addAll: (self popArgsExpr: primArgCount).
			parseTree setStatements: prolog, parseTree statements, postlog].
! !
!TMethod methodsFor: 'accessing' stamp: 'jm 2/12/98 11:56'!
primitive
	"The primitive number of this method; zero if not a primitive."

	^ primitive
! !
!TMethod methodsFor: 'printing' stamp: 'TPR 3/2/2000 18:36'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' (', selector, ')'.! !
!TMethod methodsFor: 'private' stamp: 'TPR 2/29/2000 18:45'!
printTempsAndVar: varName on: aStream 
	"add the required temps and the varname to the stream"
	aStream nextPutAll: '| rcvr stackPointer successFlag ' , varName , ' |';
	 cr! !
!TMethod methodsFor: 'transformations' stamp: 'dtl 9/19/2010 17:26'!
recordDeclarations
	"Record C type declarations of the forms

		self returnTypeC: 'float'.
		self var: #foo declareC: 'float foo'
		self var: #foo type:'float'.

	 and remove the declarations from the method body."

	| newStatements |
	properties pragmas notEmpty ifTrue:
		[properties pragmas do:
			[:pragma|
			pragma keyword = #var:declareC: ifTrue:
				[self declarationAt: pragma arguments first asString put: pragma arguments last].
			pragma keyword = #var:type: ifTrue:
				[| varName varType |
				varName := pragma arguments first asString.
				varType := pragma arguments last.
				varType last = $* ifFalse: [varType := varType, ' '].
				self declarationAt: varName put: varType, varName].
			pragma keyword = #returnTypeC: ifTrue:
				[returnType := pragma arguments last].
			pragma keyword = #doNotGenerate: ifTrue:
				[locals remove: pragma arguments last]]].
	newStatements := OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		| isDeclaration |
		isDeclaration := false.
		stmt isSend ifTrue: [
			stmt selector = #var:declareC: ifTrue: [
				isDeclaration := true.
				self declarationAt: stmt args first value asString put: stmt args last value.
			].
			stmt selector = #var:type: ifTrue: [
				| varName varType |
				isDeclaration := true.
				varName := stmt args first value asString.
				varType := stmt args last value.
				varType last = $* ifFalse: [varType := varType, ' '].
				self declarationAt: varName put: varType, varName.
			].
			stmt selector = #returnTypeC: ifTrue: [
				isDeclaration := true.
				returnType := stmt args last value.
			].
		].
		isDeclaration ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.! !
!TMethod methodsFor: 'accessing'!
referencesGlobalStructIncrementBy: value
	globalStructureBuildMethodHasFoo := globalStructureBuildMethodHasFoo + value.! !
!TMethod methodsFor: 'accessing'!
referencesGlobalStructMakeZero
	globalStructureBuildMethodHasFoo := 0! !
!TMethod methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	parseTree removeAssertions! !
!TMethod methodsFor: 'transformations' stamp: 'jm 12/14/1998 08:35'!
removeFinalSelfReturn
	"The Smalltalk parser automatically adds the statement '^self' to the end of methods without explicit returns. This method removes such statements, since the generated code has no notion of 'self' anyway."

	| stmtList lastStmt |
	stmtList := parseTree statements asOrderedCollection.
	lastStmt := stmtList last.

	((lastStmt isReturn) and:
	 [(lastStmt expression isVariable) and:
	 ['self' = lastStmt expression name]]) ifTrue: [
		stmtList removeLast.
		parseTree setStatements: stmtList.
	].! !
!TMethod methodsFor: 'utilities' stamp: 'ar 7/8/2003 11:20'!
removeUnusedTemps
	"Remove all of the unused temps in this method. Answer a bag (why the hell a bag???) with the references."
	"After inlining some variable references are now obsolete, we could fix them there but the 
	code seems a bit complicated, the other choice to to rebuild the locals before extruding. This is done here"
	| refs |
	refs := Bag new.
	"find all the variable names referenced in this method"
	parseTree nodesDo: [ :node |
		node isVariable ifTrue: [ refs add: node name asString ].
		node isStmtList ifTrue: [refs addAll: node args]].
	"add all the non-arg declarations (might be variables usedonly in cCode sections)"
	refs addAll:((self declarations keys) reject: [:e | self args includes: e]).
	"reset the locals to be only those still referred to"
	locals := locals select: [:e | refs includes: e].
	^refs
! !
!TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:06'!
renameLabelsForInliningInto: destMethod
	"Rename any labels that would clash with those of the destination method."

	| destLabels usedLabels labelMap newLabelName |
	destLabels := destMethod labels asSet.
	usedLabels := destLabels copy.  "usedLabels keeps track of labels in use"
	usedLabels addAll: labels.
	labelMap := Dictionary new: 100.
	self labels do: [ :l |
		(destLabels includes: l) ifTrue: [
			newLabelName := self unusedNamePrefixedBy: 'l' avoiding: usedLabels.
			labelMap at: l put: newLabelName.
		].
	].
	self renameLabelsUsing: labelMap.! !
!TMethod methodsFor: 'inlining support'!
renameLabelsUsing: aDictionary
	"Rename all labels according to the old->new mappings of the given dictionary."

	labels := labels collect: [ :label |
		(aDictionary includesKey: label) ifTrue: [ aDictionary at: label ] ifFalse: [ label ].
	].

	parseTree nodesDo: [ :node |
		(node isGoTo and: [aDictionary includesKey: node label]) ifTrue: [
			node setLabel: (aDictionary at: node label).
		].
		(node isLabel and: [aDictionary includesKey: node label]) ifTrue: [
			node setLabel: (aDictionary at: node label).
		].
	].! !
!TMethod methodsFor: 'inlining support' stamp: 'dtl 8/3/2009 19:19'!
renameVariablesUsing: aDictionary
	"Rename all variables according to old->new mappings of the given dictionary."

	| newDecls newKey newValue |
	"map args and locals"
	args := args collect: [ :arg |
		(aDictionary includesKey: arg) ifTrue: [ aDictionary at: arg ] ifFalse: [ arg ].
	].
	locals := locals collect: [ :v |
		(aDictionary includesKey: v) ifTrue: [ aDictionary at: v ] ifFalse: [ v ].
	].

	"map declarations"
	newDecls := declarations species new.
	declarations associationsDo: [ :assoc |
		(aDictionary includesKey: assoc key)
			ifTrue: [ newKey := aDictionary at: assoc key.
					newValue := assoc value replaceLastOccurrence: assoc key with: newKey.
					newDecls at: newKey put: newValue]
			ifFalse: [ newDecls add: assoc ].
	].
	declarations := newDecls.

	"map variable names in parse tree"
	parseTree nodesDo: [ :node |
		(node isVariable and:
		 [aDictionary includesKey: node name]) ifTrue: [
			node setName: (aDictionary at: node name).
		].
		(node isStmtList and: [node args size > 0]) ifTrue: [
			node setArguments:
				(node args collect: [ :arg |
					(aDictionary includesKey: arg)
						ifTrue: [ aDictionary at: arg ]
						ifFalse: [ arg ].
				]).
		].
	].! !
!TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:07'!
renameVarsForCaseStmt
	"Rename the arguments and locals of this method with names like t1, t2, t3, etc. Return the number of variable names assigned. This is done to allow registers to be shared among the cases."

	| i varMap |
	i := 1.
	varMap := Dictionary new: 100.
	args, locals do: [ :v |
		varMap at: v put: ('t', i printString) asSymbol.
		i := i + 1.
	].
	self renameVariablesUsing: varMap.
	^ i - 1! !
!TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:07'!
renameVarsForInliningInto: destMethod in: aCodeGen
	"Rename any variables that would clash with those of the destination method."

	| destVars usedVars varMap newVarName |
	destVars := aCodeGen globalsAsSet copy.
	destVars addAll: destMethod locals.
	destVars addAll: destMethod args.
	usedVars := destVars copy.  "keeps track of names in use"
	usedVars addAll: args; addAll: locals.
	varMap := Dictionary new: 100.
	args, locals do: [ :v |
		(destVars includes: v) ifTrue: [
			newVarName := self unusedNamePrefixedBy: v avoiding: usedVars.
			varMap at: v put: newVarName.
		].
	].
	self renameVariablesUsing: varMap.! !
!TMethod methodsFor: 'transformations' stamp: 'ar 7/6/2003 21:31'!
replaceNodesIn: map
	parseTree := parseTree replaceNodesIn: map.! !
!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 19:08'!
replaceSizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive."

	| argExpr |
	parseTree nodesDo: [:n |
		(n isSend and: [n selector = #size]) ifTrue: [
			argExpr := TSendNode new
				setSelector: #+
				receiver: n receiver
				arguments: (Array with: (TConstantNode new setValue: 1)).
			n
				setSelector: #sizeOfSTArrayFromCPrimitive:
				receiver: (TVariableNode new setName: self vmNameString)
				arguments: (Array with: argExpr)]].
! !
!TMethod methodsFor: 'accessing'!
returnType
	"The type of the values returned by this method. This string will be used in the C declaration of this function."

	^returnType! !
!TMethod methodsFor: 'accessing'!
selector
	"The Smalltalk selector of this method."

	^selector! !
!TMethod methodsFor: 'accessing'!
selector: newSelector

	selector := newSelector.! !
!TMethod methodsFor: 'accessing' stamp: 'dtl 12/21/2008 14:55'!
selectorForCodeGeneration
	"Subclasses may allow a directive to override the selector specification."

	^ selector! !
!TMethod methodsFor: 'initialization' stamp: 'dtl 9/19/2010 14:58'!
setSelector: sel definingClass: class args: argList locals: localList block: aBlockNode primitive: aNumber properties: methodProperties comment: aComment
	"Initialize this method using the given information."

	selector := sel.
	definingClass := class.
	returnType := #sqInt. 	 "assume return type is long for now"
	args := argList asOrderedCollection collect: [:arg | arg key].
	locals := (localList asSortedCollection: [:a :b| a key < b key]) collect: [:arg | arg key].
	declarations := Dictionary new.
	"self addTypeForSelf." "<- Cog feature to be added later"
	primitive := aNumber.
	properties := methodProperties.
	comment := aComment.
	parseTree := aBlockNode asTranslatorNodeIn: self.
	labels := OrderedCollection new.
	complete := false.  "set to true when all possible inlining has been done"
	export := self extractExportDirective.
	static := self extractStaticDirective.
	canAsmLabel := self extractLabelDirective.
	self extractSharedCase.
	self removeFinalSelfReturn.	"must preceed recordDeclarations because this may set returnType"
	self recordDeclarations.
	globalStructureBuildMethodHasFoo := 0! !
!TMethod methodsFor: 'initialization' stamp: 'jm 2/12/98 11:55'!
setSelector: sel returnType: retType args: argList locals: localList declarations: decls primitive: primNumber parseTree: aNode labels: labelList complete: completeFlag
	"Initialize this method using the given information. Used for copying."

	selector := sel.
	returnType := retType.
	args := argList.
	locals := localList.
	declarations := decls.
	primitive := primNumber.
	parseTree := aNode.
	labels := labelList.
	complete := completeFlag.! !
!TMethod methodsFor: 'accessing' stamp: 'ar 7/6/2003 21:18'!
sharedCase
	^sharedCase! !
!TMethod methodsFor: 'accessing' stamp: 'ar 7/6/2003 21:41'!
sharedCase: aNumber
	sharedCase := aNumber.! !
!TMethod methodsFor: 'accessing' stamp: 'ar 7/6/2003 21:18'!
sharedLabel
	^sharedLabel! !
!TMethod methodsFor: 'accessing' stamp: 'ar 7/6/2003 21:40'!
sharedLabel: aString
	sharedLabel := aString! !
!TMethod methodsFor: 'accessing'!
statements

	parseTree isStmtList
		ifFalse: [ self error: 'expected method parse tree to be a TStmtListNode' ].
	((parseTree args = nil) or: [parseTree args isEmpty])
		ifFalse: [ self error: 'expected method parse tree to have no args' ].

	^parseTree statements! !
!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 2/29/2000 18:47'!
statementsFor: sourceText varName: varName
	"Return the parse tree for the given expression. The result is the statements list of the method parsed from the given source text."
	"Details: Various variables are declared as locals to avoid Undeclared warnings from the parser."

	| s |
	s := WriteStream on: ''.
	s nextPutAll: 'temp'; cr; cr; tab.
	self printTempsAndVar: varName on: s.
	s nextPutAll: sourceText.
	^ ((Compiler new parse: s contents in: Object notifying: nil)
			asTranslationMethodOfClass: self class) statements
! !
!TMethod methodsFor: 'inlining' stamp: 'nk 4/5/2005 20:37'!
statementsListsForInlining
	"Answer a collection of statement list nodes that are candidates for inlining. Currently, we cannot inline into the argument blocks of and: and or: messages."

	| stmtLists |
	stmtLists := OrderedCollection new: 10.
	parseTree nodesDo: [ :node | 
		node isStmtList ifTrue: [ stmtLists add: node ].
	].
	parseTree nodesDo: [ :node | 
		node isSend ifTrue: [
			((node selector = #and:) or: [node selector = #or:]) ifTrue: [
				"Note: the PP 2.3 compiler produces two arg nodes for these selectors"
				stmtLists remove: node args first ifAbsent: [].
				stmtLists remove: node args last ifAbsent: [].
			].
			((node selector = #ifTrue:) or: [node selector = #ifFalse:]) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
			].
			((node selector = #ifTrue:ifFalse:) or: [node selector = #ifFalse:ifTrue:]) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
			].
			((node selector = #whileFalse:) or: [node selector = #whileTrue:]) ifTrue: [
				"Allow inlining if it is a [...] whileTrue/whileFalse.
				This is identified by having more than one statement in the 
				receiver block in which case the C code wouldn't work anyways"
				node receiver statements size = 1
					ifTrue:[stmtLists remove: node receiver ifAbsent: []].
			].
			(node selector = #to:do:) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
				stmtLists remove: node args first ifAbsent: [].
			].
			(node selector = #to:by:do:) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
				stmtLists remove: node args first ifAbsent: [].
				stmtLists remove: node args second ifAbsent: [].
			].
		].
		node isCaseStmt ifTrue: [
			"don't inline cases"
			node cases do: [: case | stmtLists remove: case ifAbsent: [] ].
		].
	].
	^stmtLists! !
!TMethod methodsFor: 'inlining' stamp: 'jm 12/13/1998 10:07'!
tryToInlineMethodsIn: aCodeGen
	"Expand any (complete) inline methods called by this method. Set the complete bit when all inlining has been done. Return true if something was inlined."

	| stmtLists didSomething newStatements inlinedStmts sendsToInline |
	didSomething := false.

	sendsToInline := Dictionary new: 100.
	parseTree nodesDo: [ :n |
		(self inlineableFunctionCall: n in: aCodeGen) ifTrue: [
			sendsToInline at: n put: (self inlineFunctionCall: n in: aCodeGen).
		].
	].
	sendsToInline isEmpty ifFalse: [
		didSomething := true.
		parseTree := parseTree replaceNodesIn: sendsToInline.
	].

	didSomething ifTrue: [
		possibleSideEffectsCache := nil.
		^didSomething
	].

	stmtLists := self statementsListsForInlining.
	stmtLists do: [ :stmtList | 
		newStatements := OrderedCollection new: 100.
		stmtList statements do: [ :stmt |
			inlinedStmts := self inlineCodeOrNilForStatement: stmt in: aCodeGen.
			(inlinedStmts = nil) ifTrue: [
				newStatements addLast: stmt.
			] ifFalse: [
				didSomething := true.
				newStatements addAllLast: inlinedStmts.
			].
		].
		stmtList setStatements: newStatements asArray.
	].

	didSomething ifTrue: [
		possibleSideEffectsCache := nil.
		^didSomething
	].

	complete ifFalse: [
		self checkForCompleteness: stmtLists in: aCodeGen.
		complete ifTrue: [ didSomething := true ].  "marking a method complete is progress"
	].
	^didSomething! !
!TMethod methodsFor: 'inlining'!
unusedLabelForInliningInto: targetMethod

	| usedLabels |
	usedLabels := labels asSet.
	usedLabels addAll: targetMethod labels.
	^self unusedNamePrefixedBy: 'l' avoiding: usedLabels! !
!TMethod methodsFor: 'inlining support'!
unusedNamePrefixedBy: aString avoiding: usedNames
	"Choose a unique variable or label name with the given string as a prefix, avoiding the names in the given collection. The selected name is added to usedNames."

	| n newVarName |
	n := 1.
	newVarName := aString, n printString.
	[usedNames includes: newVarName] whileTrue: [
		n := n + 1.
		newVarName := aString, n printString.
	].
	usedNames add: newVarName.
	^ newVarName! !
!TMethod methodsFor: 'utilities'!
variablesAssignedTo
	"Answer a collection of variables assigned to by this method."

	| refs |
	refs := Set new.
	parseTree nodesDo: [ :node |
		node isAssignment ifTrue: [ refs add: node variable name ].
	].
	^ refs! !
!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:08'!
vmNameString
	"return the string to use as the vm name in code generated for this method"
	^'self'! !

Object subclass: #TParseNode
	instanceVariableNames: 'comment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TParseNode commentStamp: 'dtl 9/15/2008 09:05' prior: 0!
A TParseNode is node in the parse tree of a TMethod. Subclasses correspond to different types of nodes in a method parse tree. The tree of translation parse nodes mirrors the parse tree of a Smalltalk method, and is used for translating a Smalltalk method to C source.!

TParseNode subclass: #TAssignmentNode
	instanceVariableNames: 'variable expression'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TAssignmentNode methodsFor: 'transformations' stamp: 'mn 6/30/2000 13:19'!
bindVariableUsesIn: aDictionary
	"Do NOT bind the variable on the left-hand-side of an assignment statement."
	"was bindVariablesIn:"
	expression := expression bindVariableUsesIn: aDictionary.
! !
!TAssignmentNode methodsFor: 'transformations'!
bindVariablesIn: aDictionary

	variable := variable bindVariablesIn: aDictionary.
	expression := expression bindVariablesIn: aDictionary.! !
!TAssignmentNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setVariable: variable copyTree
		expression: expression copyTree! !
!TAssignmentNode methodsFor: 'C code generation' stamp: ' 2/7/08 14:57'!
emitCCodeAsExpressionOn: aStream level: level generator: aCodeGen
	aStream nextPut: $(.
	self emitCCodeOn: aStream level: level generator: aCodeGen.
	aStream nextPut: $)! !
!TAssignmentNode methodsFor: 'C code generation' stamp: 'eem 3/11/2009 13:16'!
emitCCodeOn: aStream level: level generator: aCodeGen
	expression isSwitch ifTrue:
		[^expression emitCCodeOn: aStream addToEndOfCases: self level: level generator: aCodeGen].
	variable emitCCodeOn: aStream level: level generator: aCodeGen.
	self isVariableUpdatingAssignment
		ifTrue:
			[aStream
				space;
				nextPutAll: expression selector;	"+ or -"
				nextPut: $=;
				space.
			expression args first emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen]
		ifFalse:
			[aStream space; nextPut: $=; space.
			 expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen]! !
!TAssignmentNode methodsFor: 'accessing'!
expression

	^expression! !
!TAssignmentNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	variable inlineMethodsUsing: aDictionary.
	expression inlineMethodsUsing: aDictionary.! !
!TAssignmentNode methodsFor: 'testing'!
isAssignment

	^true! !
!TAssignmentNode methodsFor: 'testing' stamp: 'eem 4/6/2009 17:38'!
isStructTarget: aCodeGen
	"Answer if the recever evaluates to a struct pointer
	 and hence can be dereferenced using ->"
	^variable isStructTarget: aCodeGen! !
!TAssignmentNode methodsFor: 'testing'!
isVariableUpdatingAssignment
	"Return true if this assignment statement is of one of the forms:
		var = var + ...
		var = var - ...
	Such assignments statements can exploit the C updating assignment operators. For example, 'x += 4' can be generated instead of 'x = x + 4'. This produces better code under some C compilers, most notably the CodeWarrior 68K compiler."

	| sel |
	(expression isSend and: [expression receiver isVariable]) ifFalse: [^ false].
	sel := expression selector.
	^ (expression receiver name = variable name) and: [(sel = #+) or: [sel = #-]]! !
!TAssignmentNode methodsFor: 'enumerating'!
nodesDo: aBlock

	variable nodesDo: aBlock.
	expression nodesDo: aBlock.
	aBlock value: self.! !
!TAssignmentNode methodsFor: 'printing' stamp: 'ar 4/4/2006 21:12'!
printOn: aStream level: level

	variable printOn: aStream level: level.
	aStream nextPutAll: ' := '.
	expression printOn: aStream level: level + 2.! !
!TAssignmentNode methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions

	expression removeAssertions! !
!TAssignmentNode methodsFor: 'transformations'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		variable := variable replaceNodesIn: aDictionary.
		expression := expression replaceNodesIn: aDictionary.
		self]! !
!TAssignmentNode methodsFor: 'accessing'!
setVariable: varNode expression: expressionNode

	variable := varNode.
	expression := expressionNode.! !
!TAssignmentNode methodsFor: 'accessing'!
variable

	^variable! !

TParseNode subclass: #TCaseStmtNode
	instanceVariableNames: 'expression firsts lasts cases'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'dtl 7/3/2008 09:37'!
assumesCurrentBytecodeMatchesCaseValue: statementList
	"Test for the special case of certain methods that rely on the value of
	the currentBytecode variable to be expanded to a constant. This is a
	performance optimization that permits the next bytecode to be fetched
	early while not affecting the prior value of currentBytecode, which
	will have been translated to a constant.
	
	See senders of #'requires currentBytecode to be expanded to a constant'
	for methods that rely on this behavior."

	| trickySelectors commentString firstLine |
	trickySelectors := {
			#pushLiteralConstantBytecode .
			#pushLiteralVariableBytecode .
			#pushReceiverVariableBytecode .
			#pushTemporaryVariableBytecode .
			#storeAndPopTemporaryVariableBytecode .
			#storeAndPopReceiverVariableBytecode
		}.
	firstLine := statementList statements first.
	firstLine isComment ifTrue: [
		commentString := firstLine asString.
		trickySelectors detect: [:e | commentString includesSubString: e]
			ifNone: [^ false].
		^ true].
	^ false! !
!TCaseStmtNode methodsFor: 'transformations' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	expression := expression bindVariableUsesIn: aDictionary.
	cases := cases collect: [ :c | c bindVariableUsesIn: aDictionary ].! !
!TCaseStmtNode methodsFor: 'transformations'!
bindVariablesIn: aDictionary

	expression := expression bindVariablesIn: aDictionary.
	cases := cases collect: [ :c | c bindVariablesIn: aDictionary ].! !
!TCaseStmtNode methodsFor: 'accessing'!
cases

	^cases! !
!TCaseStmtNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setExpression: expression copyTree
		firsts: firsts copy
		lasts: lasts copy
		cases: (cases collect: [ :case | case copyTree ])! !
!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'ar 7/6/2003 23:34'!
customizeCase: caseParseTree forVar: varName from: firstIndex to: lastIndex in: codeGen method: aTMethod
	"Return a collection of copies of the given parse tree, each of which has the value of the case index substituted for the given variable."

	| newCases dict newCase |
	newCases := OrderedCollection new.
	firstIndex to: lastIndex do: [ :caseIndex |
		dict := Dictionary new.
		dict at: varName put: (TConstantNode new setValue: caseIndex).
		newCase := caseParseTree copyTree bindVariableUsesIn: dict.
		self processSharedCodeBlocks: newCase forCase: caseIndex in: codeGen method: aTMethod.
		newCases addLast: newCase.
	].
	^ newCases! !
!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'dtl 7/3/2008 09:57'!
customizeShortCasesForDispatchVar: varName in: codeGen method: aTMethod
	"Make customized versions of a short bytecode methods, substituting a constant having the case index value for the given variable. This produces better code for short bytecodes such as instance variable pushes that encode the index of the instance variable in the bytecode."

	| newFirsts newLasts newCases l f case expanded |
	newFirsts := OrderedCollection new.
	newLasts := OrderedCollection new.
	newCases := OrderedCollection new.
	1 to: cases size do: [ :i |
		l := lasts at: i.
		f := firsts at: i.
		case := cases at: i.
		expanded := false.
		(l - f) > 1 ifTrue: [  "case code covers multiple cases"
			(case nodeCount < 60
				or: [self assumesCurrentBytecodeMatchesCaseValue: case]) ifTrue: [
					newFirsts addAll: (f to: l) asArray.
					newLasts addAll: (f to: l) asArray.
					newCases addAll: (self customizeCase: case forVar: varName from: f to: l in: codeGen method: aTMethod).
					expanded := true
			]
		].
		expanded ifFalse: [
			self processSharedCodeBlocks: case forCase: f in: codeGen method: aTMethod.
			newFirsts addLast: f.
			newLasts addLast: l.
			newCases addLast: case.
		]
	].
	firsts := newFirsts asArray.
	lasts := newLasts asArray.
	cases := newCases asArray.
! !
!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'dtl 11/9/2006 06:29'!
emitCCodeOn: aStream level: level generator: aCodeGen

	| indent |
	indent := (String new: level) collect: [ :ch | Character tab ].
	aStream nextPutAll: 'switch ('.
	expression asExpression emitCCodeOn: aStream level: level generator: aCodeGen.
	aStream nextPutAll: ') {'; cr.
	1 to: cases size do: [ :i |
		(firsts at: i) to: (lasts at: i) do: [ :caseIndex |
			aStream nextPutAll: indent, 'case ', caseIndex printString, ':'; cr.
		].
		(cases at: i) emitCCodeOn: aStream level: level + 1 generator: aCodeGen.
		aStream nextPutAll: indent; tab; nextPutAll: 'break;'.
		aStream cr.
	].
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !
!TCaseStmtNode methodsFor: 'accessing'!
expression

	^expression! !
!TCaseStmtNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	expression inlineMethodsUsing: aDictionary.
	cases do: [ :c | c inlineMethodsUsing: aDictionary ].! !
!TCaseStmtNode methodsFor: 'testing'!
isCaseStmt

	^true! !
!TCaseStmtNode methodsFor: 'enumerating'!
nodesDo: aBlock

	expression nodesDo: aBlock.
	cases do: [ :c | c nodesDo: aBlock ].
	aBlock value: self.! !
!TCaseStmtNode methodsFor: 'printing'!
printOn: aStream level: level

	aStream crtab: level.
	aStream nextPutAll: 'select '.
	expression printOn: aStream level: level.
	aStream nextPutAll: ' in'.
	1 to: cases size do: [ :i |
		(firsts at: i) to: (lasts at: i) do: [ :caseIndex |
			aStream crtab: level.
			aStream nextPutAll: 'case ', caseIndex printString, ':'.
		].
		aStream crtab: level + 1.
		(cases at: i) printOn: aStream level: level + 1.
	].
	aStream crtab: level.
	aStream nextPutAll: 'end select'.! !
!TCaseStmtNode methodsFor: 'transformations' stamp: 'ar 7/7/2003 00:18'!
processSharedCodeBlocks: caseTree forCase: caseIndex in: codeGen method: aTMethod
	"Process any shared code blocks in the case parse tree for the given case, either inlining them or making them a 'goto sharedLabel'."
	| map meth sharedNode exitLabel |
	exitLabel := nil.

	[sharedNode := nil.
	map := IdentityDictionary new.
	caseTree nodesDo:[:node|
		(node isSend 
			and:[(meth := codeGen methodNamed: node selector) notNil
			and:[meth sharedCase notNil]]) ifTrue:[
			meth sharedCase = caseIndex ifTrue:[
				sharedNode := meth.
				map at: node put: (TLabeledCommentNode new setComment: 'goto ', meth sharedLabel).
			] ifFalse:[
				map at: node put: (TGoToNode new setLabel: meth sharedLabel).
			].
		].
	].
	caseTree replaceNodesIn: map.
	"recursively expand"
	sharedNode == nil] whileFalse:[
		meth := sharedNode copy.
		(meth hasReturn) ifTrue: [
			exitLabel ifNil:[
				exitLabel := aTMethod unusedLabelForInliningInto: aTMethod.
				aTMethod labels add: exitLabel.
			].
			meth exitVar: nil label: exitLabel.
		].
		meth renameLabelsForInliningInto: aTMethod.
		aTMethod labels addAll: meth labels.
		caseTree setStatements: (caseTree statements copyWith: meth asInlineNode).
	].
	exitLabel ifNotNil:[
		caseTree setStatements: (caseTree statements copyWith:
			(TLabeledCommentNode new setLabel: exitLabel comment: 'end case')).

	].! !
!TCaseStmtNode methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	expression removeAssertions.
	cases do: [ :case | case removeAssertions ].! !
!TCaseStmtNode methodsFor: 'transformations'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		expression := expression replaceNodesIn: aDictionary.
		cases := cases collect: [ :c | c replaceNodesIn: aDictionary ].
		self]! !
!TCaseStmtNode methodsFor: 'as yet unclassified'!
setExpression: aNode firsts: firstsList lasts: lastsList cases: caseList

	expression := aNode.
	firsts := firstsList.
	lasts := lastsList.
	cases := caseList.! !
!TCaseStmtNode methodsFor: 'accessing' stamp: 'ar 11/18/1999 20:08'!
setExpression: aNode selectors: selectorList arguments: anArray
	"Initialize the node from the given set of selectors."
	"Note: Each case is a statement list with containing one statement, a send to self of a selector from the given selector list. Having statement list nodes makes inlining easier later."

	| selfNode stmt lastSel firstInRun sel |
	expression := aNode.
	selfNode := TVariableNode new setName: 'self'.
	firsts := OrderedCollection new: 400.
	lasts := OrderedCollection new: 400.
	cases := OrderedCollection new: 400.
	lastSel := selectorList first.
	firstInRun := 0.
	1 to: selectorList size do: [ :i |
		sel := selectorList at: i.
		sel ~= lastSel ifTrue: [
			firsts add: firstInRun.
			lasts add: i - 2.
			stmt := TSendNode new setSelector: lastSel receiver: selfNode arguments: anArray.
			cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)).
			lastSel := sel.
			firstInRun := i - 1.
		].
	].
	firsts add: firstInRun.
	lasts add: selectorList size - 1.
	stmt := TSendNode new setSelector: lastSel receiver: selfNode arguments: anArray.
	cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)).! !

TParseNode subclass: #TConstantNode
	instanceVariableNames: 'value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TConstantNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setValue: value! !
!TConstantNode methodsFor: 'C code generation'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit a C literal."

	aStream nextPutAll: (aCodeGen cLiteralFor: value).! !
!TConstantNode methodsFor: 'testing'!
isConstant

	^true! !
!TConstantNode methodsFor: 'testing'!
isLeaf

	^true! !
!TConstantNode methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:04'!
name
	^''! !
!TConstantNode methodsFor: 'accessing' stamp: 'acg 12/17/1999 07:19'!
nameOrValue

	^value! !
!TConstantNode methodsFor: 'printing'!
printOn: aStream level: level

	value storeOn: aStream.! !
!TConstantNode methodsFor: 'accessing'!
setValue: anObject

	value := anObject.! !
!TConstantNode methodsFor: 'accessing'!
value

	^value! !

TConstantNode subclass: #TDefineNode
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TDefineNode methodsFor: 'as yet unclassified' stamp: 'ar 7/8/2003 11:11'!
copyTree

	^self class new
		setName: name value: value! !
!TDefineNode methodsFor: 'C code generation' stamp: 'ar 7/8/2003 11:08'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit a C literal."

	aStream nextPutAll: name.! !
!TDefineNode methodsFor: 'as yet unclassified' stamp: 'ar 7/8/2003 11:04'!
name
	^name! !
!TDefineNode methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:05'!
name: aName
	name := aName! !
!TDefineNode methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:08'!
nameOrValue
	^name! !
!TDefineNode methodsFor: 'accessing' stamp: 'ar 7/8/2003 11:10'!
setName: aName value: aValue
	self name: aName.
	self setValue: aValue.! !

TParseNode subclass: #TGoToNode
	instanceVariableNames: 'label'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TGoToNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new setLabel: label! !
!TGoToNode methodsFor: 'C code generation'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit a C goto statement."

	aStream nextPutAll: 'goto '.
	aStream nextPutAll: label.! !
!TGoToNode methodsFor: 'testing'!
isGoTo

	^true! !
!TGoToNode methodsFor: 'accessing'!
label

	^label! !
!TGoToNode methodsFor: 'printing'!
printOn: aStream level: level

	aStream nextPutAll: 'goto '.
	aStream nextPutAll: label.! !
!TGoToNode methodsFor: 'accessing'!
setLabel: aString

	label := aString.! !

TParseNode subclass: #TInlineNode
	instanceVariableNames: 'method'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TInlineNode methodsFor: 'transformations' stamp: 'ar 7/6/2003 20:34'!
bindVariableUsesIn: aDictionary
	method := method bindVariableUsesIn: aDictionary.
! !
!TInlineNode methodsFor: 'accessing' stamp: 'ar 7/6/2003 20:15'!
copyTree

	^self class new
		method: method copy! !
!TInlineNode methodsFor: 'C code generation' stamp: 'ar 7/6/2003 20:19'!
emitCCodeOn: aStream level: level generator: aCodeGen
	method emitInlineOn: aStream level: level generator: aCodeGen.
! !
!TInlineNode methodsFor: 'accessing' stamp: 'ar 7/6/2003 20:08'!
method
	^method! !
!TInlineNode methodsFor: 'accessing' stamp: 'ar 7/6/2003 20:08'!
method: aTMethod
	method := aTMethod! !
!TInlineNode methodsFor: 'enumerating' stamp: 'ar 7/6/2003 20:36'!
nodesDo: aBlock
	method parseTree nodesDo: aBlock.
	aBlock value: self.! !
!TInlineNode methodsFor: 'printing' stamp: 'ar 7/6/2003 22:00'!
printOn: aStream level: anInteger
	method parseTree printOn: aStream level: anInteger! !
!TInlineNode methodsFor: 'transformations' stamp: 'ar 7/6/2003 21:30'!
replaceNodesIn: map
	^map at: self ifAbsent: [
		method replaceNodesIn: map.
		self]! !

TParseNode subclass: #TLabeledCommentNode
	instanceVariableNames: 'label'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TLabeledCommentNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setLabel: label
		comment: comment! !
!TLabeledCommentNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit a C comment with optional label."

	self printOptionalLabelOn: aStream.
	aStream nextPutAll: '/* '.
	aStream nextPutAll: comment.
	aStream nextPutAll: ' */'.! !
!TLabeledCommentNode methodsFor: 'testing'!
isComment
	"Answer true if the receiver is just a comment (i.e., it has no label)."

	^label = nil! !
!TLabeledCommentNode methodsFor: 'testing'!
isLabel

	^true! !
!TLabeledCommentNode methodsFor: 'testing'!
isLeaf

	^true! !
!TLabeledCommentNode methodsFor: 'accessing'!
label

	^label! !
!TLabeledCommentNode methodsFor: 'printing'!
printOn: aStream level: level

	self printOptionalLabelOn: aStream.
	aStream nextPut: $".
	aStream nextPutAll: comment.
	aStream nextPut: $".! !
!TLabeledCommentNode methodsFor: 'printing'!
printOptionalLabelOn: aStream

	label ~= nil ifTrue: [
		self unindentOneTab: aStream.
		aStream nextPutAll: label.
		aStream nextPut: $:.
		aStream tab.	
	].! !
!TLabeledCommentNode methodsFor: 'accessing'!
setComment: commentString

	label := nil.
	comment := commentString.! !
!TLabeledCommentNode methodsFor: 'accessing'!
setLabel: labelString

	label := labelString.! !
!TLabeledCommentNode methodsFor: 'accessing'!
setLabel: labelString comment: commentString

	label := labelString.
	comment := commentString.! !
!TLabeledCommentNode methodsFor: 'C code generation'!
unindentOneTab: aStream
	"Remove the last tab from the given stream if possible."

	(aStream isKindOf: ReadWriteStream) ifFalse: [ ^self ].
	aStream position > 0 ifTrue: [
		aStream position: aStream position - 1.
		"restore stream position if previous char was not a tab"
		aStream peek = Character tab ifFalse: [ aStream next ].
	].! !

TParseNode subclass: #TNotImplementedNode
	instanceVariableNames: 'parseNode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TNotImplementedNode commentStamp: 'dtl 10/12/2010 19:37' prior: 0!
A TNotImplementedNode is a translation node for a parse node that cannot be translated, or for which translation is not yet implemented.
!
!TNotImplementedNode methodsFor: 'accessing' stamp: 'dtl 10/12/2010 19:40'!
parseNode
	"Answer the value of parseNode"

	^ parseNode! !
!TNotImplementedNode methodsFor: 'accessing' stamp: 'dtl 10/12/2010 19:40'!
parseNode: anObject
	"Set the value of parseNode"

	parseNode := anObject! !
!TParseNode methodsFor: 'as yet unclassified'!
allCalls
	"Answer a collection of selectors for the messages sent in this parse tree."

	| calls |
	calls := Set new: 100.
	self nodesDo: [ :node |
		node isSend ifTrue: [ calls add: node selector ].
	].
	^calls! !
!TParseNode methodsFor: 'converting' stamp: 'dtl 10/28/2006 18:50'!
asExpression
	"Sender expects to use this node as a simple expression rather than as as statement"

	^self! !
!TParseNode methodsFor: 'transformations' stamp: 'jm 12/10/1998 18:13'!
bindVariableUsesIn: aDictionary
	"Bind uses of all variables in the given dictionary, but do not change variables that appear on the left-hand-side of an assignment statement."

	^ self
! !
!TParseNode methodsFor: 'transformations'!
bindVariablesIn: aDictionary

	^self! !
!TParseNode methodsFor: 'accessing' stamp: 'hg 8/14/2000 15:32'!
comment: aComment

	comment := aComment ! !
!TParseNode methodsFor: 'as yet unclassified' stamp: 'nk 4/5/2005 21:01'!
copyTree
	self subclassResponsibility.! !
!TParseNode methodsFor: 'C code generation' stamp: ' 2/7/08 14:57'!
emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen
	^self emitCCodeOn: aStream level: level generator: aCodeGen! !
!TParseNode methodsFor: 'C code generation' stamp: ' 2/7/08 14:57'!
emitCCodeAsExpressionOn: aStream level: level generator: aCodeGen
	^self emitCCodeOn: aStream level: level generator: aCodeGen! !
!TParseNode methodsFor: 'C code generation' stamp: 'nk 4/5/2005 21:02'!
emitCCodeOn: aStream level: lev generator: gen
	self subclassResponsibility.! !
!TParseNode methodsFor: 'C code generation' stamp: 'hg 8/14/2000 16:13'!
emitCCommentOn: aStream level: level
	"Emit the transferred Smalltalk comments as C comments."

	comment ifNotNil: [
		comment isString ifTrue: [^self].	"safety catch"
		aStream cr.
		1 to: comment size do: [:index | 
			aStream 
				tab: level;
				nextPutAll: '/* ';
				nextPutAll: (comment at: index);
				nextPutAll: ' */';
				cr].
		aStream cr]! !
!TParseNode methodsFor: 'testing'!
hasExplicitReturn

	self nodesDo: [ :node |
		node isReturn ifTrue: [ ^true ].
	].
	^false! !
!TParseNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	self! !
!TParseNode methodsFor: 'testing' stamp: 'ikp 9/26/97 14:50'!
isAssertion
	^false! !
!TParseNode methodsFor: 'testing' stamp: 'ikp 9/26/97 14:50'!
isAssignment

	^false! !
!TParseNode methodsFor: 'testing'!
isCaseStmt

	^false! !
!TParseNode methodsFor: 'testing'!
isComment

	^false! !
!TParseNode methodsFor: 'testing'!
isConstant

	^false! !
!TParseNode methodsFor: 'as yet unclassified' stamp: 'dtl 10/24/2006 21:56'!
isDirective
	"Preprocessor directive, e.g. a cpp macro"

	^false! !
!TParseNode methodsFor: 'testing'!
isGoTo

	^false! !
!TParseNode methodsFor: 'testing' stamp: 'eem 7/8/2008 19:57'!
isInline
	^false! !
!TParseNode methodsFor: 'testing'!
isLabel

	^false! !
!TParseNode methodsFor: 'testing'!
isLeaf
	"Answer true if the receiver is a variable or a constant node."

	^false! !
!TParseNode methodsFor: 'testing' stamp: 'eem 2/24/2009 14:48'!
isPreprocessorDirective
	^false! !
!TParseNode methodsFor: 'testing'!
isReturn

	^false! !
!TParseNode methodsFor: 'testing' stamp: 'eem 8/8/2008 11:57'!
isReturningIf
	^false! !
!TParseNode methodsFor: 'testing'!
isSend

	^false! !
!TParseNode methodsFor: 'testing'!
isStmtList

	^false! !
!TParseNode methodsFor: 'testing' stamp: 'eem 2/11/2009 13:32'!
isStructTarget: aCodeGen
	"Answer if the recever evaluates to a struct pointer
	 and hence can be dereferenced using ->"
	^false! !
!TParseNode methodsFor: 'testing' stamp: 'eem 2/10/2009 07:58'!
isSwitch
	^false! !
!TParseNode methodsFor: 'testing' stamp: 'eem 2/11/2009 17:12'!
isTParseNode
	^true! !
!TParseNode methodsFor: 'testing'!
isVariable

	^false! !
!TParseNode methodsFor: 'accessing' stamp: 'acg 12/17/1999 07:21'!
nameOrValue

	self error: 'object is neither variable nor constant'! !
!TParseNode methodsFor: 'utilities'!
nodeCount
	"Answer the number of nodes in this parseTree (a rough measure of its size)."

	| cnt |
	cnt := 0.
	self nodesDo: [ :n | cnt := cnt + 1 ].
	^cnt! !
!TParseNode methodsFor: 'enumerating'!
nodesDo: aBlock

	aBlock value: self.! !
!TParseNode methodsFor: 'as yet unclassified' stamp: 'JMM 11/23/2002 23:25'!
nodesVarCheckDo: aBlock

	aBlock value: self.! !
!TParseNode methodsFor: 'printing'!
printOn: aStream 
	"Append a description of the receiver onto the given stream."

	self printOn: aStream level: 0.! !
!TParseNode methodsFor: 'printing'!
printOn: aStream level: anInteger 
	"Typically overridden. If control actually gets here, avoid recursion loop by sending to super."

	super printOn: aStream.! !
!TParseNode methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	"default: do nothing"! !
!TParseNode methodsFor: 'transformations'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [self]! !
!TParseNode methodsFor: 'as yet unclassified' stamp: 'dtl 3/20/2005 14:23'!
requiresCLineTerminator

	^ self isComment not
! !

TParseNode subclass: #TReturnNode
	instanceVariableNames: 'expression'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TReturnNode methodsFor: 'transformations' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	expression := expression bindVariableUsesIn: aDictionary.! !
!TReturnNode methodsFor: 'transformations'!
bindVariablesIn: aDictionary

	expression := expression bindVariablesIn: aDictionary.! !
!TReturnNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setExpression: expression copyTree! !
!TReturnNode methodsFor: 'C code generation' stamp: 'eem 11/7/2009 15:43'!
emitCCodeOn: aStream level: level generator: aCodeGen

	(expression isSwitch
	 or: [expression isCaseStmt]) ifTrue:
		[^expression emitCCodeOn: aStream addToEndOfCases: self level: level generator: aCodeGen].

	('void' = aCodeGen currentMethod returnType) ifTrue: [
		"If the function is void, don't say 'return x' instead say ' x; return' "
		expression isLeaf ifFalse: [
			expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen.	
			aStream nextPutAll: ';'; space.
		].
		aStream nextPutAll: 'return'.
	] ifFalse: [
		aStream nextPutAll: 'return'.
		aStream space.
		expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen
	].! !
!TReturnNode methodsFor: 'accessing'!
expression

	^expression! !
!TReturnNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	expression := expression inlineMethodsUsing: aDictionary.! !
!TReturnNode methodsFor: 'testing'!
isReturn

	^true! !
!TReturnNode methodsFor: 'enumerating'!
nodesDo: aBlock

	expression nodesDo: aBlock.
	aBlock value: self.! !
!TReturnNode methodsFor: 'printing'!
printOn: aStream level: level

	aStream nextPut: $^.
	expression printOn: aStream level: level.! !
!TReturnNode methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	expression removeAssertions! !
!TReturnNode methodsFor: 'transformations'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		expression := expression replaceNodesIn: aDictionary.
		self]! !
!TReturnNode methodsFor: 'accessing'!
setExpression: aNode

	expression := aNode.! !

TParseNode subclass: #TSendNode
	instanceVariableNames: 'selector receiver arguments isBuiltinOperator isExpression'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TSendNode methodsFor: 'accessing'!
args

	^arguments! !
!TSendNode methodsFor: 'converting' stamp: 'dtl 11/7/2006 12:09'!
asExpression
	"Sender expects to use this node as a simple expression rather than as as statement"

	self isExpression: true.
	^self! !
!TSendNode methodsFor: 'transformations' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	receiver := receiver bindVariableUsesIn: aDictionary.
	arguments := arguments collect: [ :a | a bindVariableUsesIn: aDictionary ].! !
!TSendNode methodsFor: 'transformations'!
bindVariablesIn: aDictionary

	receiver := receiver bindVariablesIn: aDictionary.
	arguments := arguments collect: [ :a | a bindVariablesIn: aDictionary ].! !
!TSendNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setSelector: selector
		receiver: receiver copyTree
		arguments: (arguments collect: [ :arg | arg copyTree ])
		isBuiltInOp: isBuiltinOperator! !
!TSendNode methodsFor: 'C code generation' stamp: 'dtl 10/19/2010 22:20'!
emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen
	"Emit the receiver in a form that can be passed as an argument."

	"If the selector is a built-in construct, translate it and return"
	(aCodeGen emitBuiltinConstructAsArgumentFor: self asExpression on: aStream level: level) ifFalse:
		["If it is a pointer dereference generate it"
		(self emitCCodeAsPointerDereferenceOn: aStream level: level generator: aCodeGen) ifFalse:
			["Otherwise generate the vanilla C function call."
			 self emitCCodeAsFunctionCallOn: aStream level: level generator: aCodeGen]]! !
!TSendNode methodsFor: 'C code generation' stamp: ' 2/7/08 14:57'!
emitCCodeAsExpressionOn: aStream level: level generator: aCodeGen
	^self emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen! !
!TSendNode methodsFor: 'C code generation' stamp: 'eem 2/11/2009 17:01'!
emitCCodeAsFunctionCallOn: aStream level: level generator: aCodeGen

	"Translate this message send into a C function call"
	"Special case for pluggable modules. Replace messages to interpreterProxy
	 by interpreterProxy->message(..) if the message is not builtin"
	(aCodeGen isGeneratingPluginCode
	 and: [receiver isVariable
	 and: ['interpreterProxy' = receiver name
	 and: [self isBuiltinOperator not]]]) ifTrue:
		[aStream nextPutAll:'interpreterProxy->'].
	"Translate this message send into a C function call."
	aStream nextPutAll: (aCodeGen cFunctionNameFor: selector); nextPut: $(.
	"Only include the receiver as the first argument in certain cases.
	 The receiver is always included if it is an expression.
	 If it is a variable:
		 If the vmClass says it is an implicit variable, don't include it.
		 If the variable is 'self' and the method being called is not in
		 the method set (i.e. it is some external code), don't include it."
	(self shouldIncludeReceiverAsFirstArgument: aCodeGen) ifTrue:
		[receiver emitCCodeOn: aStream level: level generator: aCodeGen.
		arguments isEmpty ifFalse:
			[aStream nextPutAll: ', ']].
	arguments do:
		[ :arg| arg emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen]
		separatedBy: [aStream nextPut: $,; space].
	aStream nextPut: $)! !
!TSendNode methodsFor: 'C code generation' stamp: 'eem 4/7/2009 10:46'!
emitCCodeAsPointerDereferenceOn: aStream level: level generator: aCodeGen
	"If appropriate, translate this message send as a pointer dereference"

	(self isStructSend: aCodeGen) ifFalse:
		[^false].

	aStream nextPut: $(.
	receiver  emitCCodeAsExpressionOn: aStream level: 0 generator: aCodeGen.
	aStream nextPut: $-; nextPut: $>.
	aStream nextPutAll: (aCodeGen cFunctionNameFor: selector).
	arguments isEmpty ifFalse:
		[self assert: arguments size = 1.
		 aStream nextPutAll: ' = '.
		 arguments first emitCCodeAsExpressionOn: aStream level: level generator: aCodeGen].
	aStream nextPut: $).
	^true! !
!TSendNode methodsFor: 'C code generation' stamp: 'eem 7/2/2008 15:44'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit the receiver as a statement."

	"If the selector is a built-in construct, translate it and return"
	(aCodeGen emitBuiltinConstructFor: self on: aStream level: level) ifFalse:
		["If it is a pointer dereference generate it"
		(self emitCCodeAsPointerDereferenceOn: aStream level: level generator: aCodeGen) ifFalse:
			["Otherwise generate the vanilla C function call."
			 self emitCCodeAsFunctionCallOn: aStream level: level generator: aCodeGen]]! !
!TSendNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	arguments := arguments collect: [ :arg |
		arg inlineMethodsUsing: aDictionary.
	].
	"xxx inline this message if it is in the dictionary xxx"! !
!TSendNode methodsFor: 'testing' stamp: 'ikp 9/26/97 14:50'!
isAssertion
	^(selector beginsWith: 'assert') or: [selector beginsWith: 'verify']! !
!TSendNode methodsFor: 'testing'!
isBuiltinOperator

	^ isBuiltinOperator! !
!TSendNode methodsFor: 'testing'!
isBuiltinOperator: builtinFlag

	isBuiltinOperator := builtinFlag.! !
!TSendNode methodsFor: 'as yet unclassified' stamp: 'dtl 5/17/2010 15:20'!
isDirective
	"Preprocessor directive, e.g. a cpp macro"

	^ {	#preprocessorExpression: .
		#isDefined:inSmalltalk:comment:ifTrue:ifFalse: .
		#isDefined:inSmalltalk:comment:ifTrue: .
		#isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse:
		} identityIncludes: selector! !
!TSendNode methodsFor: 'accessing' stamp: 'dtl 11/11/2009 20:59'!
isExpression
	"Answer the value of isExpression. True if this node is expected to be used
	as an expression. Normally false but may be set by #asExpression to indicate
	that this node should be translated as a simple expression rather than as
	a statement."

	^ isExpression ifNil: [isExpression := false]! !
!TSendNode methodsFor: 'accessing' stamp: 'dtl 11/7/2006 12:06'!
isExpression: anObject
	"Set the value of isExpression"

	isExpression := anObject! !
!TSendNode methodsFor: 'testing'!
isSend

	^true! !
!TSendNode methodsFor: 'testing' stamp: 'eem 6/20/2009 11:40'!
isStructSend: aCodeGen
	"Answer if the recever is a send of a structure accessor.
	 This is tricky.  We want
		foo bar => foo->bar
		foo bar: expr => foo->bar = expr
	 but only if both foo is a struct type and bar is a field accessor.
	 The tricky cases are self-sends within struct class methods.  Here we need to
	 distinguish between self-sends of ordinary methods from self sends of accessors."
	^arguments size <= 1
	   and: [(receiver isStructTarget: aCodeGen)
	   and: [(aCodeGen methodNamed: selector)
				ifNil: [false]
				ifNotNil: [:method| method isStructAccessor]]]! !
!TSendNode methodsFor: 'testing' stamp: 'eem 2/11/2009 13:32'!
isStructTarget: aCodeGen
	"Answer if the recever evaluates to a struct pointer
	 and hence can be dereferenced using ->"
	selector == #cCoerceSimple:to: ifTrue:
		[^aCodeGen isTypePointerToStruct: arguments last value].

	^aCodeGen selectorReturnsPointerToStruct: selector! !
!TSendNode methodsFor: 'enumerating'!
nodesDo: aBlock

	receiver nodesDo: aBlock.
	arguments do: [ :arg | arg nodesDo: aBlock ].
	aBlock value: self.! !
!TSendNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	| keywords |
	receiver printOn: aStream level: level.
	arguments size = 0 ifTrue: [
		aStream space; nextPutAll: selector.
		^self
	].
	keywords := selector keywords.
	1 to: keywords size do: [ :i |
		aStream space.
		aStream nextPutAll: (keywords at: i); space.
		(arguments at: i) printOn: aStream level: level + 1.
	].! !
!TSendNode methodsFor: 'accessing'!
receiver

	^receiver! !
!TSendNode methodsFor: 'accessing'!
receiver: aNode

	receiver := aNode.! !
!TSendNode methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	receiver removeAssertions.
	arguments do: [:arg | arg removeAssertions].! !
!TSendNode methodsFor: 'transformations'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		receiver := receiver replaceNodesIn: aDictionary.
		arguments := arguments collect: [ :a | a replaceNodesIn: aDictionary ].
		self]! !
!TSendNode methodsFor: 'as yet unclassified' stamp: 'dtl 10/24/2006 22:05'!
requiresCLineTerminator

	^ (self isComment or: [self isDirective]) not
! !
!TSendNode methodsFor: 'accessing'!
selector

	^selector! !
!TSendNode methodsFor: 'accessing'!
setSelector: aSymbol receiver: rcvrNode arguments: argList

	selector := aSymbol.
	receiver := rcvrNode.
	arguments := argList asArray.
	isBuiltinOperator := false.! !
!TSendNode methodsFor: 'accessing'!
setSelector: aSymbol receiver: rcvrNode arguments: argList isBuiltInOp: builtinFlag

	selector := aSymbol.
	receiver := rcvrNode.
	arguments := argList asArray.
	isBuiltinOperator := builtinFlag.! !
!TSendNode methodsFor: 'C code generation' stamp: 'eem 2/11/2009 18:59'!
shouldExcludeReceiverAsFirstArgument: aCodeGen
	"Only include the receiver as the first argument in certain cases.
	 The receiver is always included if it is an expression.
	 If it is a variable:
		 If the vmClass says it is an implicit variable, don't include it.
		 If the method's definingClass says it is an implicit variable, don't include it.
		 If the variable is 'self' and the method being called is not in
		 the method set (i.e. it is some external code), don't include it."
	| m |
	^receiver isVariable
	    and: [(aCodeGen isNonArgumentImplicitReceiverVariableName: receiver name)
		    or: [(receiver name beginsWith: 'self')
			    and: [(receiver name = 'self' or: [receiver name beginsWith: 'self_in_'])
			    and: [(m := aCodeGen methodNamed: selector) isNil
					or: [m typeForSelf == #implicit]]]]]! !
!TSendNode methodsFor: 'C code generation' stamp: 'eem 2/11/2009 17:00'!
shouldIncludeReceiverAsFirstArgument: aCodeGen
	"Only include the receiver as the first argument in certain cases.
	 The receiver is always included if it is an expression.
	 If it is a variable:
		 If the vmClass says it is an implicit variable, don't include it.
		 If the variable is 'self' and the method being called is not in
		 the method set (i.e. it is some external code), don't include it."
	^(self shouldExcludeReceiverAsFirstArgument: aCodeGen) not! !

TParseNode subclass: #TStmtListNode
	instanceVariableNames: 'arguments statements'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TStmtListNode methodsFor: 'accessing'!
args

	^arguments! !
!TStmtListNode methodsFor: 'converting' stamp: 'dtl 10/28/2006 18:51'!
asExpression

	^ (self statements size = 1)
		ifTrue: [statements first]
		ifFalse: [self error: 'multiple statements can not serve as a simple expression']! !
!TStmtListNode methodsFor: 'transformations' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	statements := statements collect: [ :s | s bindVariableUsesIn: aDictionary ].! !
!TStmtListNode methodsFor: 'transformations'!
bindVariablesIn: aDictionary

	statements := statements collect: [ :s | s bindVariablesIn: aDictionary ].! !
!TStmtListNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setArguments: arguments copy
		statements: (statements collect: [ :s | s copyTree ])! !
!TStmtListNode methodsFor: 'C code generation' stamp: ' 2/7/08 14:57'!
emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen

	| statementWasComment |
	statementWasComment := false.
	statements
		do:
			[:s |
			s emitCCommentOn: aStream level: level.
			s emitCCodeAsArgumentOn: aStream level: 0 generator: aCodeGen.
			statementWasComment := s isComment]
		separatedBy:
			[((self endsWithCloseBracket: aStream)
			  or: [statementWasComment]) ifFalse: [aStream nextPut: $,]]! !
!TStmtListNode methodsFor: 'as yet unclassified' stamp: 'dtl 10/28/2006 16:42'!
emitCCodeOn: aStream level: level generator: aCodeGen

	statements do: [:s |
		s emitCCommentOn: aStream level: level.
		aStream tab: level.
		s emitCCodeOn: aStream level: level generator: aCodeGen.
		(((self endsWithCloseBracket: aStream) not
			and: [(s isComment) not])
				and: [s requiresCLineTerminator])
			ifTrue: [aStream nextPut: $;].
		aStream cr].
! !
!TStmtListNode methodsFor: 'testing' stamp: 'jm 11/25/1998 16:26'!
endsWithCloseBracket: aStream
	"Answer true if the given stream ends in a $} character."

	| ch pos |
	(pos := aStream position) > 0 ifTrue: [
		aStream position: pos - 1.
		ch := aStream next].
	^ ch = $}
! !
!TStmtListNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	statements do: [ :s | s inlineMethodsUsing: aDictionary ].! !
!TStmtListNode methodsFor: 'testing' stamp: 'acg 12/21/1999 02:25'!
isNilStmtListNode

	|stmt|
	statements size = 1 ifFalse: [^false].
	stmt := statements at: 1.
	^ stmt isVariable and: [stmt name = 'nil']! !
!TStmtListNode methodsFor: 'testing'!
isStmtList

	^true! !
!TStmtListNode methodsFor: 'enumerating'!
nodesDo: aBlock

	statements do: [ :s | s nodesDo: aBlock ].	
	aBlock value: self.! !
!TStmtListNode methodsFor: 'printing'!
printOn: aStream level: level

	aStream nextPut: $[.
	arguments size > 0 ifTrue: [
		arguments do: [ :arg | aStream nextPutAll: ' :', arg ].
		aStream nextPutAll: ' | '.
	].
	self printStatementsOn: aStream level: level.
	aStream nextPut: $].! !
!TStmtListNode methodsFor: 'printing'!
printStatementsOn: aStream level: level

	statements size > 1 ifTrue: [ aStream crtab: level + 1 ].
	1 to: statements size do: [ :i |
		(statements at: i) printOn: aStream level: level.
		i = statements size ifTrue: [
			(statements size > 1) ifTrue: [
				aStream crtab: level.
			].
		] ifFalse: [
			aStream nextPut: $.; crtab: level + 1.
		].
	].! !
!TStmtListNode methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	| newStatements |
	newStatements := OrderedCollection new: statements size.
	statements do: [ :stmt |
		stmt isAssertion ifFalse: [
			newStatements add: (stmt removeAssertions; yourself).
		]
	].
	self setStatements: newStatements asArray! !
!TStmtListNode methodsFor: 'transformations'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		statements := statements collect: [ :s | s replaceNodesIn: aDictionary ].
		self]! !
!TStmtListNode methodsFor: 'accessing'!
setArguments: argList

	arguments := argList.! !
!TStmtListNode methodsFor: 'accessing'!
setArguments: argList statements: statementList
	"Initialize this method using the given information."

	arguments := argList.
	statements := statementList.! !
!TStmtListNode methodsFor: 'accessing'!
setStatements: stmtList

	statements := stmtList asOrderedCollection.! !
!TStmtListNode methodsFor: 'accessing'!
statements

	^statements! !

TParseNode subclass: #TVariableNode
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Translation to C'!
!TVariableNode methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 16:56'!
bindVariableUsesIn: aDictionary

	^ (aDictionary at: name ifAbsent: [^ self]) copyTree! !
!TVariableNode methodsFor: 'as yet unclassified' stamp: 'sma 5/24/2000 23:42'!
bindVariablesIn: aDictionary 
	^ (aDictionary at: name ifAbsent: [^ self]) copyTree! !
!TVariableNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new setName: name! !
!TVariableNode methodsFor: 'as yet unclassified' stamp: 'JMM 4/5/2002 14:14'!
emitCCodeOn: aStream level: level generator: aCodeGen

	name = 'nil'
		ifTrue: [ aStream nextPutAll: (aCodeGen cLiteralFor: nil) ]
		ifFalse: [ aStream nextPutAll: (aCodeGen returnPrefixFromVariable: name) ].! !
!TVariableNode methodsFor: 'testing'!
isLeaf

	^true! !
!TVariableNode methodsFor: 'testing' stamp: 'eem 7/2/2008 14:42'!
isStructTarget: aCodeGen
	"Answer if the recever is a struct pointer
	 and hence can be dereferenced using ->"
	^aCodeGen isPointerToStructVariableName: name! !
!TVariableNode methodsFor: 'testing'!
isVariable

	^true! !
!TVariableNode methodsFor: 'as yet unclassified'!
name

	^name! !
!TVariableNode methodsFor: 'accessing' stamp: 'acg 12/17/1999 07:18'!
nameOrValue

	^name! !
!TVariableNode methodsFor: 'printing'!
printOn: aStream level: level

	aStream nextPutAll: name.! !
!TVariableNode methodsFor: 'accessing'!
setName: aString

	name := aString.! !

Object subclass: #VMMaker
	instanceVariableNames: 'inline forBrowser allPlugins internalPlugins externalPlugins platformName sourceDirName platformRootDirName logger allFilesList interpreterClassName'
	classVariableNames: 'CodeGeneratorCache DirNames'
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!VMMaker commentStamp: 'tpr 5/28/2008 17:08' prior: 0!
This class builds a VM codebase from the in-image and on-file code.

The platforms file tree you need can be downloaded via cvs from http://squeak.Sourceforge.net. See also the swiki (http://minnow.cc.gatech.edu/squeak/2106) for instructions.

It is fairly configurable as to where directories live and can handle multiple platform's source trees at once. It's main purpose is to allow easy building of source trees with any combination of internal/external/unused plugins to suit your platform needs and capabilities. For example, the Acorn has no need of Sound or AsynchFile plugins since I haven't written any platform code for them. 

There is a simple UI tool for this 
	VMMakerTool openInWorld
will open a reasonably self explanatory tool with balloon help to explain all the fields - and a help window on top of that.

There are some simple workspace & inspector commands, allowing scripted building:
	VMMaker default initializeAllExternal generateEntire
for example will build sources for a system with all the plugins external whereas 
	VMMaker default initializeAllInternal generateEntire
would build all applicable plugins for internal compilation.
	(VMMaker forPlatform: 'Mac OS') initializeAllExternal generateEntire
would build a source tree for a Mac even on a Windows machine (err, ignoring for now the irritation of lineends).

	If you have a slightly more complex configuration you want to use, perhaps with Socket and Serial support external (because for your case they are rarely used and saving the space has some value) then you could try
		(VMMaker default initializeAllInternalBut: #(SocketPlugin SerialPlugin) generateEntire
	More complex still would be
		(VMMaker default initializeInternal: #(BitBltPlugin MiscPrimsPlugin FilePlugin) external: #(SocketPlugin ZipPlugin B2DPlugin)
which allows you to precisely list all the plugins to use.

WARNING If you miss out a plugin you need, it won't be there. This message is really best suited to use by a UI like VMMakerTool.

	To save a configuration for later use, you need to send #saveConfiguration to an active instance of VMMaker. Obviously you could simply use
		(VMMaker default initializeAllInternalBut: #(SocketPlugin SerialPlugin) saveConfiguration
but inspecting 
		VMMaker default
and altering the internalPlugins and externalPlugins or the boolean flags for inline or forBrowser followed by saving the configuration allows ultimate power for now. To load a saved configuration file, use #loadConfigurationFrom: aFilename whilst inspecting a VMMaker. The loaded state will completely override any pre-existing state, so take care.
	You can generate only parts of the source tree if you wish; as shown above #generateEntire will create the whole collection of internal and external plugins as well as the core VM. To create only  the external plugins use #generateExternalPlugins, or create a single  plugin with #generateExternalPlugin: name. To assemble the main VM including the internal plugins, use #generateMainVM. The interpreter 'interp.c' file is made with #generateInterpreterFile. You can generate a single internal plugin with #generateInternalPlugin: only if it has already been generated before; this interlocking is intended to make sure the named primitive table in the vm is correct.

There are some rules to observe in order to use this:-
- under the working directory (by default - you can configure it) you need a directory called 'platforms' (also configurable) with subdirectories named as the platform names returned by Smalltalk platformName (ie unix, RiscOS, Mac OS, etc - this isn't configurable). At the very least you need the one for your own platform and the pseudo-platform called 'Cross'. By adding a 'DirNames' entry for #machineType you can cross 'compile' for some other platform. Now all we need is a cross-compiler for the C code :-)
- under this directory you must have a simple structure of directories for each generated plugin that you support on the platform, plus 'vm'. In each directory you place any/all platform specific files (and subdirectories) for that plugin. In 'misc' you can place any miscellaneous files such as makefiles, resources etc. For example, for unix you have
	platforms/
		unix/
			plugins/
				AsynchFilePlugin /
					sqUnixAsynchfile.c
			vm/
				sqGnu.h
				Profile/
			misc/
				makefile.in
				util/
				
				...etc
Any plugins requiring platform files that you don't support shouldn't appear in the resulting code tree. If you try to include an unsupported plugin in the list to be made external, the VMMaker simply ignores it. However, if you include it in the list to be made internal you will get an error since that seems like a potentially serious source of confusion.

There are three lists of plugins maintained herein:-
1) 'allPlugins' -  the list of all remaining generatable plugins. We scan this list and compare with the supported plugins as indicated by the file tree.
2) 'internalPlugins' -  the list of chosen internal plugins as moved from the allPlugins list.
3) 'externalPlugins' - the list of chosen external plugins as moved from the allPlugins list.
allPlugins is initialised with all the known plugins that can be built  with the classes and external files provided. This may well include some that are not applicable to the chosen platform and those will be filtered out if you try to move them to internalPlugins or externalPlugins later.
See initializeAllPlugins, initialiseAllExternal etc for fairly obvious usage.
There is also a short list of directory names in the class variable 'DirNames' that you can alter if needed.

Known problems:-
a) since Squeak has really poor filename handling, you can't simply change the directory names to '/foo/bar/myEvilCodeBase' and expect it to work. You fix file names and I'll fix VMMaker :-)
b) Squeak copying of a file loses the assorted permissions, filetype info and other useful bits. To workaround this problem, see the FileCopyPlugin, which provides the platform independent part of a simple access for the OS filecopy capability. So far there are functional plugins for unix, Mac and Acorn. DOS machines appear not to need one. This is less of a problem in practise now that unix, Acorn & Mac no longer copy files from /platforms to /src.

inline <Boolean> - is the generated code to be inlined or not
forBrowser <Boolean> - is this to be a build for in-Browser use? Only relevent to Macs
allPlugins <Collection> - all the known possible plugins
internalPlugins <Collection> - the plugins chosen to be generated for internal linking
externalPlugins <Collection> - the plugins intended to be external plugins
exportList <Collection> - a list of function names exported from plugins intended to be internal
platformName <String> - the name of the platform for which we are building a source tree. It is possible to do 'cross-compiles'
sourceDirName, platformRootDirName <String> - the name of the directory into which we write the generated sources and the name of the directory where we should find the platforms tree.!

VMMaker subclass: #MacOSPowerPCOS9VMMaker
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!MacOSPowerPCOS9VMMaker commentStamp: 'tpr 5/5/2003 12:27' prior: 0!
A VMMaker subclass to suit Mac OS!

MacOSPowerPCOS9VMMaker subclass: #MacOSPowerPCOS9BrowserVMMaker
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!MacOSPowerPCOS9BrowserVMMaker commentStamp: 'tpr 5/5/2003 12:26' prior: 0!
A Special subclass of VMMaker for building MAc OS-9 browser-plugin vms!
!MacOSPowerPCOS9BrowserVMMaker class methodsFor: 'initialisation'!
isActiveVMMakerClassFor: platformName
	^false! !
!MacOSPowerPCOS9BrowserVMMaker methodsFor: 'initialize' stamp: 'JMM 5/30/2001 18:12'!
initialize
	super initialize.
	forBrowser := true! !
!MacOSPowerPCOS9VMMaker class methodsFor: 'initialisation'!
isActiveVMMakerClassFor: platformName
	"Does this class claim to be that properly active subclass of VMMaker for this platform?"

	^platformName = 'Mac OS'" and: [Smalltalk platformSubtype = 'PowerPC'] <- this used to be used but prevents any attempt to do the crossplatform generation thang. How can we handle that bit properly?"! !
!MacOSPowerPCOS9VMMaker methodsFor: 'initialize' stamp: 'tpr 3/11/2003 15:48'!
createCodeGenerator
"set up a CCodeGenerator for this VMMaker - Mac OS uses the global struct and local def of the structure"
	^CCodeGeneratorGlobalStructure new initialize; globalStructDefined: true! !

VMMaker subclass: #RiscOSVMMaker
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!RiscOSVMMaker commentStamp: '<historical>' prior: 0!
Special VMMaker class for Acorn RiscOS - add generation of a configuration file for each plugin, required by the dynamic loading libraries!
!RiscOSVMMaker methodsFor: 'initialize' stamp: 'tpr 3/11/2003 13:49'!
createCodeGenerator
"set up a CCodeGenerator for this VMMaker - RiscOS uses the global struct and no local def of the structure because of the global register trickery"
	^CCodeGeneratorGlobalStructure new initialize; globalStructDefined: false! !
!RiscOSVMMaker methodsFor: 'generate sources' stamp: 'tpr 4/12/2006 12:17'!
export: exportList forExternalPlugin: aPlugin
"it may be useful on certain platforms to do something with the export list of external plugins, just as the internal plugins' exports get added to the VM list. Default is to do nothing though."
"For RiscOS using the 'rink' external linker each plugin needs a 'dsc' file that looks like
id:SqueakSO
main_version:100
code_version:001

entries:
//
named_entries:
getModuleName
//
with all the exported names in the list. We also need a '/o' directory for the object files"

	"open a file called plugindir/pluginname.dsc and write into it"
	| f fd dfd |
	fd := self externalPluginsDirectoryFor: aPlugin.

	"If we get an error to do with opening the .dsc file, we need to raise an application error to suit"
	[(fd directoryExists: 'dsc') ifFalse:[fd createDirectory: 'dsc'].
	dfd := fd directoryNamed: 'dsc'.
	f := CrLfFileStream forceNewFileNamed: (dfd fullNameFor: aPlugin moduleName)] on: FileStreamException do:[^self couldNotOpenFile: (dfd fullNameFor: aPlugin moduleName)].

	f nextPutAll: 'id:SqueakSO
main_version:100
code_version:001

entries:
//
named_entries:
'.
	exportList do:[:el|
		f nextPutAll: el.
		f cr].
	f nextPutAll: '//'; cr.
	f close.
	(fd directoryNamed: 'o') assureExistence
! !
!RiscOSVMMaker methodsFor: 'generate sources' stamp: 'tpr 3/12/2003 10:16'!
interpreterExportsFilePath
	"return the full path for the interpreter exports file"
	"RiscOS keeps the exports file in a 'h' subdirectory of coreVMDirectory"
	self coreVMDirectory assureExistenceOfPath: 'h'.
	^(self coreVMDirectory directoryNamed: 'h') fullNameFor: 'sqNamedPrims'! !
!RiscOSVMMaker methodsFor: 'generate sources' stamp: 'tpr 11/20/2003 14:32'!
interpreterFilePath
	"return the full path for the interpreter file"
	"RiscOS keeps the interp file in a 'c' subdirectory of coreVMDirectory"
	self coreVMDirectory assureExistenceOfPath: 'c'.
	^(self coreVMDirectory directoryNamed: 'c') fullNameFor: self interpreterFilename! !
!RiscOSVMMaker methodsFor: 'target directories' stamp: 'tpr 12/2/2003 12:47'!
interpreterFilename
	"what is the filename for the core interpreter. Default is interp.c"
	^'interp'! !
!RiscOSVMMaker methodsFor: 'generate sources' stamp: 'tpr 3/17/2005 16:26'!
interpreterHeaderPath
	"return the full path for the interpreter header file"
	"RiscOS keeps the interp file in a 'h' subdirectory of coreVMDirectory"
	self coreVMDirectory assureExistenceOfPath: 'h'.
	^(self coreVMDirectory directoryNamed: 'h') fullNameFor: self interpreterFilename! !
!RiscOSVMMaker methodsFor: 'initialize' stamp: 'dtl 4/30/2009 22:47'!
needsToRegenerateInterpreterFile
"check the timestamp for the relevant classes and then the timestamp for the interp.c file if it already exists. Return true if the file needs regenerating, false if not"

	| tStamp fstat |
	tStamp := {self interpreterClass. ObjectMemory}
				inject: 0
				into: [:tS :cl | tS max: cl timeStamp].

	"don't translate if the file is newer than my timeStamp"
	"RiscOS keeps the interp file in a 'c' subdirectory of coreVMDirectory"
	(self coreVMDirectory directoryExists: 'c') ifFalse:[^true].

	fstat := (self coreVMDirectory directoryNamed: 'c') entryAt: self interpreterFilename ifAbsent:[nil].
	fstat ifNotNil:[tStamp < fstat modificationTime ifTrue:[^false]].
	^true
! !
!RiscOSVMMaker methodsFor: 'processing external files' stamp: 'tpr 3/12/2003 10:17'!
processFilesForExternalPlugin: plugin 
	"After the plugin has created any files we need to move them around a little to suit RiscOS; any *.c file must be moved to a 'c' subdirectory, likwise any h file"
	| files fd |
	files := (fd := self externalPluginsDirectoryFor: plugin) fileNamesMatching:'*.c'.
	files notEmpty ifTrue:[fd assureExistenceOfPath: 'c'.
		files do:[:fn|
			self copyFileNamed: (fd fullNameFor: fn) to: ((fd directoryNamed:'c') fullNameFor:(fn allButLast: 2)).
			fd deleteFileNamed: fn]].

	files := (self externalPluginsDirectoryFor: plugin) fileNamesMatching:'*.h'.
	files notEmpty ifTrue:[fd assureExistenceOfPath: 'h'.
		files do:[:fn|
			self copyFileNamed: (fd fullNameFor: fn) to: ((fd directoryNamed:'h') fullNameFor:(fn allButLast: 2)).
			fd deleteFileNamed: fn]].
	super processFilesForExternalPlugin: plugin
! !
!RiscOSVMMaker methodsFor: 'processing external files' stamp: 'tpr 3/12/2003 10:18'!
processFilesForInternalPlugin: plugin 
	"After the plugin has created any files we need to move them around a little to suit RiscOS; any *.c file must be moved to a 'c' subdirectory, likwise any h file"
	| files fd |
	files := (fd := self internalPluginsDirectoryFor: plugin) fileNamesMatching:'*.c'.
	files notEmpty ifTrue:[fd assureExistenceOfPath: 'c'.
		files do:[:fn|
			self copyFileNamed: (fd localNameFor: fn) to: ((fd directoryNamed:'c') localNameFor:(fn allButLast: 2)).
			fd deleteFileNamed: fn]].

	files := (self internalPluginsDirectoryFor: plugin) fileNamesMatching:'*.h'.
	files notEmpty ifTrue:[fd assureExistenceOfPath: 'h'.
		files do:[:fn|
			self copyFileNamed: (fd localNameFor: fn) to: ((fd directoryNamed:'h') localNameFor:(fn allButLast: 2)).
			fd deleteFileNamed: fn]].
	super processFilesForInternalPlugin: plugin
! !
!RiscOSVMMaker methodsFor: 'exports' stamp: 'tpr 3/11/2003 14:11'!
storeExternalPluginList
	"RiscOS doesn't need this"! !
!RiscOSVMMaker methodsFor: 'exports' stamp: 'tpr 3/11/2003 14:11'!
storeInternalPluginList
	"RiscOS doesn't need this"! !

VMMaker subclass: #UnixVMMaker
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!UnixVMMaker class methodsFor: 'initialisation' stamp: 'ikp 8/25/2003 00:13'!
isActiveVMMakerClassFor: platformName

	^platformName = 'unix'! !
!UnixVMMaker methodsFor: 'initialisation' stamp: 'ikp 8/25/2003 00:00'!
createCodeGenerator

	^CCodeGeneratorGlobalStructure new
		initialize;
		globalStructDefined: true! !
!VMMaker class methodsFor: 'initialisation'!
activeVMMakerClassFor: platformName
	"Return the concrete VMMaker subclass for the platform on which we are currently running."

	VMMaker allSubclasses do: [:class |
		(class isActiveVMMakerClassFor: platformName) ifTrue: [^ class]].

	"no responding subclass; use VMMaker"
	^ VMMaker
! !
!VMMaker class methodsFor: 'accessing' stamp: 'tpr 12/1/2000 15:58'!
coreVMDirName
	^DirNames at: #coreVMDir! !
!VMMaker class methodsFor: 'initialisation' stamp: 'nk 4/5/2005 20:22'!
default
	"return a VMMaker initialised to build a default no-internal-plugins, no-external-plugins vm codebase"
	^self forPlatform: SmalltalkImage current platformName! !
!VMMaker class methodsFor: 'initialisation' stamp: 'tpr 10/12/2001 17:59'!
forConfigurationFile: aFileName
	| config  fileStream vmMaker |

	fileStream := FileStream oldFileNamed: aFileName.
	config := fileStream fileInObjectAndCode.
	vmMaker := self forPlatform: (config at: 5).
	vmMaker loadConfiguration: config.
	^vmMaker! !
!VMMaker class methodsFor: 'initialisation'!
forPlatform: platformName
	"return a VMMaker initialised to build a default no-internal-plugins, no-external-plugins vm codebase"
	^(self activeVMMakerClassFor: platformName) new initialize setPlatName: platformName! !
!VMMaker class methodsFor: 'version testing' stamp: 'dtl 9/16/2009 20:56'!
headerNotice
"return a string to be put at the front of generated code files"
	^String streamContents:[:strm|
		strm nextPutAll: 'Automatically generated from Squeak on '.
		Time dateAndTimeNow do: [:e | strm nextPutAll: e asString; nextPut: Character space].
		strm cr.
		strm nextPutAll: '   by VMMaker '.
		strm nextPutAll: self  versionString.
		strm cr]! !
!VMMaker class methodsFor: 'initialisation' stamp: 'dtl 12/21/2008 14:22'!
initialize
	"VMMaker initialize"
	DirNames := Dictionary new.
	DirNames at: #coreVMDir put: 'vm';
		at: #platformsDir put: 'platforms';
		at: #pluginsDir put: 'plugins';
		at: #sourceDir put: 'src'.
	(self respondsTo: #initializeBrowserSupport)
		ifTrue: [self initializeBrowserSupport "see package SlangBrowser"]! !
!VMMaker class methodsFor: 'initialisation' stamp: 'tpr 2/4/2002 19:18'!
isActiveVMMakerClassFor: platformName 
	"Does this class claim to be that properly active subclass of VMMaker for 
	this platform? Subclasses are welcome to override this default"
	^ platformName , '*' match: self name! !
!VMMaker class methodsFor: 'accessing' stamp: 'nk 4/5/2005 20:22'!
machinesDirName
	^DirNames at: #machineType ifAbsent:[SmalltalkImage current platformName]! !
!VMMaker class methodsFor: 'accessing' stamp: 'tpr 12/1/2000 16:03'!
platformsDirName
	^DirNames at: #platformsDir! !
!VMMaker class methodsFor: 'accessing' stamp: 'tpr 12/1/2000 16:12'!
pluginsDirName
	^DirNames at: #pluginsDir! !
!VMMaker class methodsFor: 'accessing' stamp: 'tpr 12/1/2000 16:14'!
sourceDirName
	^DirNames at: #sourceDir! !
!VMMaker class methodsFor: 'fetching updates' stamp: 'dtl 11/14/2009 20:38'!
updateFromServer
	"Update the image by loading all pending updates from the server. Also save local
	copies of the update files if the #updateSavesFile preference is set to true"

	"VMMaker updateFromServer"

	(Smalltalk hasClassNamed: #MCMcmUpdater)
		ifTrue: [(Smalltalk at: #MCMcmUpdater)
				updateFromRepositories: #('http://squeaksource.com/VMMaker' )]
		ifFalse: [self notify: 'MonticelloConfigurations not installed in this image']! !
!VMMaker class methodsFor: 'version testing' stamp: 'dtl 1/21/2011 21:06'!
versionString

	"VMMaker versionString"

	^'4.4.7'! !
!VMMaker methodsFor: 'plugin lists' stamp: 'ar 4/7/2002 13:09'!
allModuleNames
	"return the list of all the all plugins' moduleNames"
	^Array streamContents:[:strm| self allPluginsDo:[:pl| strm nextPut: pl moduleName ]]! !
!VMMaker methodsFor: 'plugin lists' stamp: 'ar 4/7/2002 13:10'!
allPluginsDo: aBlock 
	"for each class that should be an external plugin, evaluate aBlock"
	self externalPluginsDo: aBlock.
	self internalPluginsDo: aBlock.! !
!VMMaker methodsFor: 'UI access'!
availablePlugins
	allPlugins ifNil:[self initializeAllPlugins].
	^allPlugins! !
!VMMaker methodsFor: 'plugin lists' stamp: 'tpr 5/28/2008 19:44'!
canSupportPlugin: pluginClassName 
	"see if this plugin needs any external files and if so, check to see if 
	they seem to exist, as well as checking to see if the chosen platform can support it"
	[self validatePlugin: pluginClassName in: allPlugins , internalPlugins , externalPlugins]
		on: VMMakerException
		do: [:ex | self inform: ex messageText. ^false].
	^ true! !
!VMMaker methodsFor: 'objects from disk' stamp: 'dtl 5/27/2010 21:18'!
configurationInfo
	"build a simple Array of the configuration information that would be 
	usefully saved for later reloading:- 
	the list of internal & external plugins, the flags, the platform name, and the two major directory names"
	^ Array new writeStream nextPut: internalPlugins;
		 nextPut: externalPlugins;
		 nextPut: inline;
		 nextPut: forBrowser;
		 nextPut: self platformName;
		 nextPut: self sourceDirectory pathName;
		 nextPut: self platformRootDirectory pathName;
	contents! !
!VMMaker methodsFor: 'copying files' stamp: 'tpr 2/11/2002 14:50'!
copyAssortedFiles
	"copy any miscellaneous files/dirs from the cross-platformDirectory/misc/ToCopy -  
	general readme files etc, then from the platform specific directory/misc/ToCopy - makefiles, 
	utils etc that have to be copied."
	| srcDir |
	"Is there a crossPlatformDirectory subdirectory called 'misc'?"
	(self crossPlatformDirectory directoryExists: 'misc')
		ifTrue: [srcDir := self crossPlatformDirectory directoryNamed: 'misc'.
			"Is there a subdirectory called 'ToCopy' ?"
			(srcDir directoryExists: 'ToCopy') ifTrue:[
				srcDir := srcDir directoryNamed: 'ToCopy'.
				self copyFilesFromSourceDirectory: srcDir toTargetDirectory: self sourceDirectory]].
	"Is there a platformDirectory subdirectory called 'misc'?"
	(self platformDirectory directoryExists: 'misc')
		ifTrue: [srcDir := self platformDirectory directoryNamed: 'misc'.
			"Is there a subdirectory called 'ToCopy' ?"
			(srcDir directoryExists: 'ToCopy') ifTrue:[
				srcDir := srcDir directoryNamed: 'ToCopy'.
				self copyFilesFromSourceDirectory: srcDir toTargetDirectory: self sourceDirectory]]! !
!VMMaker methodsFor: 'private - copying files' stamp: 'ar 4/7/2002 15:59'!
copyFileNamed: srcName to: dstName 
	| dstEntry srcEntry |
	dstEntry := FileDirectory directoryEntryFor: dstName.
	dstEntry ifNotNil:[
		srcEntry := FileDirectory directoryEntryFor: srcName.
		srcEntry ifNil:[^self couldNotOpenFile: srcName].
		dstEntry modificationTime >= srcEntry modificationTime ifTrue:[^self].
	].
	logger show:'==> ', dstName; cr.
	^self primitiveCopyFileNamed: srcName to: dstName ! !
!VMMaker methodsFor: 'private - copying files' stamp: 'tpr 2/11/2002 15:11'!
copyFilesFrom: srcDir to: dstDir
"This really ought to be a facility in file system. The major annoyance here is that file types and permissions are not handled by current Squeak code"
	[srcDir fileNames do: [:filenm | 
		self copyFileNamed: (srcDir fullNameFor: filenm) to: (dstDir fullNameFor: filenm)]] on: InvalidDirectoryError do:["do nothing if the directory is invalid"]
! !
!VMMaker methodsFor: 'private - copying files' stamp: 'tpr 2/11/2002 15:10'!
copyFilesFromSourceDirectory: srcDir toTargetDirectory: dstDir 
	"copy all the files and directories from srcDir to dstDir, recursively"	
	self copyFilesFromSourceDirectory: srcDir
			toTargetDirectory: dstDir
			recursively: true! !
!VMMaker methodsFor: 'private - copying files' stamp: 'ar 1/18/2005 15:19'!
copyFilesFromSourceDirectory: srcDir toTargetDirectory: dstDir recursively: recurseBoolean
	"copy all files and subdirectories from srcDir to dstDir, optionally recursing down the tree.
	It is assumed that both directories already exist and have appropriate 
	permissions - proper error handling ought to be provided sometime. 
	Note how nice it would be if the file system classes already did this; 
	why, they could even defer to an improved file plugin for some of 
	these things."
	"copy all the files"
	| dirList  |
	srcDir localName = 'CVS' ifTrue:[logger show: 'CVS files NOT copied by VMMaker'; cr. ^self].
	srcDir localName = '.svn' ifTrue:[logger show: 'SVN files NOT copied by VMMaker'; cr. ^self].

	self copyFilesFrom: srcDir to: dstDir.

	recurseBoolean ifFalse:[^self].
	"If we are recursing create the subdirectories of srcDir in dstDir, and then copy that 
	subtree "
	dirList := srcDir directoryNames copyWithout: 'CVS'.
	dirList := srcDir directoryNames copyWithout: '.svn'.
	dirList do: 
		[:newDstDir | 
		(dstDir directoryExists: newDstDir)
			ifFalse: [dstDir createDirectory: newDstDir].
		self copyFilesFromSourceDirectory: (srcDir directoryNamed: newDstDir)
			toTargetDirectory: (dstDir directoryNamed: newDstDir)
			recursively: true]! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 2/14/2002 14:27'!
coreVMDirectory
	"return the target directory for the main VM sources, interp.c etc"
	| fd |
	fd := self sourceDirectory directoryNamed: self class coreVMDirName.
	fd assureExistence.
	^ fd! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 10/21/2001 11:13'!
couldNotFindDirectory: dirName
	"This should raise a nice exception to a UI"
	(VMMakerException new messageText: self class name, ' could not find directory ', dirName) signal! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 10/18/2001 19:41'!
couldNotFindPlatformDirectoryFor: platName
	"This should raise a nice exception to a UI"
	self couldNotFindDirectory: 'for: ', platName, ' specific files; is the platform root path set correctly?'! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 10/21/2001 11:14'!
couldNotFindPlatformFilesFor: plugin
	"This should raise a nice exception to a UI"
	(VMMakerException new messageText: self class name, ' could not find platform specific files for: ', plugin moduleName) signal! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 10/21/2001 11:15'!
couldNotFindPluginClass: pluginSymbol
	"This should raise a nice exception to a UI"
	(VMMakerException new messageText: self class name, ' could not find the class for: ', pluginSymbol) signal! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 10/21/2001 11:12'!
couldNotOpenFile: fileName
	"This should raise a nice exception to a UI"
	(VMMakerException new messageText: self class name, ' could not open file: ', fileName) signal! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 3/11/2003 12:55'!
createCodeGenerator
"set up a CCodeGenerator for this VMMaker"
	^CCodeGenerator new initialize! !
!VMMaker methodsFor: 'source directories' stamp: 'tpr 1/9/2002 20:35'!
crossPlatformDirectory
	"return the directory where we should find the cross-platform literal 
	sources - <sq.h> etc"
	| fd machDirNm |
	fd := self platformRootDirectory.
	(fd directoryExists: (machDirNm := 'Cross'))
		ifFalse: ["The supposed directory for the actual cross-platform code  
			does not exist."
			^ self couldNotFindPlatformDirectoryFor: 'cross-platform '].
	^ fd directoryNamed: machDirNm! !
!VMMaker methodsFor: 'source directories' stamp: 'tpr 10/18/2001 19:43'!
crossPlatformPluginsDirectory
	"return the directory where we should find the cross-platform plugin specific sources"

	(self crossPlatformDirectory directoryExists: self class pluginsDirName)
		ifFalse: ["The supposed directory for the plugins code does not 
					exist. We need to raise a suitable exception, but cant 
					think of one right now."
					^self couldNotFindPlatformDirectoryFor: 'any plugins needing cross-platform'].
	^self crossPlatformDirectory directoryNamed: self class pluginsDirName! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 3/27/2002 15:19'!
deleteEntireGeneratedTree
	"remove all the files - all of them I say"
	self sourceDirectory recursiveDelete! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 3/26/2002 18:34'!
deleteUnwantedExternalPluginDirectories
	"delete directories in the external plugins tree with names not in the list  
	of external plugins. This will make sure that only wanted plugins are  
	left after generating external plugins - no previous ones will get left  
	there like unwanted porridge"
	(self externalPluginsDirectory directoryNames copyWithoutAll: self externalModuleNames)
		do: [:nm | (self externalPluginsDirectory directoryNamed: nm) recursiveDelete]! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 3/26/2002 18:37'!
deleteUnwantedInternalPluginDirectories
	"delete directories in the internal plugins tree with names not in the list  
	of internal plugins. This will make sure that only wanted plugins are  
	left after generating internal plugins - no previous ones will get left  
	there like unwanted porridge"
	(self internalPluginsDirectory directoryNames copyWithoutAll: self internalModuleNames)
		do: [:nm | (self internalPluginsDirectory directoryNamed: nm) recursiveDelete]! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 7/28/2003 15:16'!
doInlining
	"default is true but see VMMaker>initialize for details"
	^inline! !
!VMMaker methodsFor: 'exports' stamp: 'tpr 4/20/2001 16:35'!
export: exportList forExternalPlugin: aPlugin
"it may be useful on certain platforms to do something with the export list of external plugins, just as the internal plugins' exports get added to the VM list. Default is to do nothing though."! !
!VMMaker methodsFor: 'plugin lists' stamp: 'tpr 7/2/2001 16:29'!
externalFilesRequiredFor: plugin
	^plugin requiresCrossPlatformFiles or:[plugin requiresPlatformFiles]! !
!VMMaker methodsFor: 'plugin lists' stamp: 'tpr 3/26/2002 18:34'!
externalModuleNames
	"return the list of all the external plugins' moduleNames"
	^Array streamContents:[:strm| self externalPluginsDo:[:pl| strm nextPut: pl moduleName ]]! !
!VMMaker methodsFor: 'UI access'!
externalModules
	^externalPlugins! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 2/14/2002 14:27'!
externalPluginsDirectory
	"return the target directory for the external plugins sources"
	| fd |
	fd := self sourceDirectory directoryNamed: self class pluginsDirName.
	fd assureExistence.
	^fd! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 2/14/2002 14:27'!
externalPluginsDirectoryFor: plugin
	"return the directory for the external plugin sources"
	|fd|
	fd := self externalPluginsDirectory directoryNamed: plugin moduleName.
	fd assureExistence.
	^fd! !
!VMMaker methodsFor: 'plugin lists' stamp: 'tpr 1/24/2001 12:53'!
externalPluginsDo: aBlock 
	"for each class that should be an external plugin, evaluate aBlock"
	self plugins: externalPlugins do: aBlock! !
!VMMaker methodsFor: 'generate sources' stamp: 'dtl 1/2/2011 13:01'!
generateEntire
"generate the interp, internal plugins and exports as well as the external plugins"

	self generateMainVM.
	self generateExternalPlugins.
	self generateUtilityPrograms
! !
!VMMaker methodsFor: 'exports' stamp: 'tpr 3/11/2003 14:03'!
generateExportsFile
	^self storeExportsOn: self interpreterExportsFilePath
! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 5/28/2008 19:58'!
generateExternalPlugin: pluginName 
	"generate the named external plugin"
	| exports plugin |

	"Refuse to translate this plugin if it is not in the external plugins list or requires platform specific support and it is not present."
	[plugin := self validateExternalPlugin: pluginName] on: VMMakerException do:[:ex | ^self inform: ex messageText].

	exports := plugin
				translateInDirectory: (self externalPluginsDirectoryFor: plugin)
				doInlining: inline.
	logger show: 'external plugin ' , plugin name , ' generated as ' , plugin moduleName; cr.
	exports ifNotNil: ["if exp is nil we skip this since the plugin was already up to date"
			self export: exports forExternalPlugin: plugin].
	self processFilesForExternalPlugin: plugin! !
!VMMaker methodsFor: 'generate sources' stamp: 'ar 4/7/2002 13:05'!
generateExternalPlugins
	"generate the external plugins"

	self deleteUnwantedExternalPluginDirectories.
	self externalPluginsDo: [:plugin | 
		self generateExternalPlugin: plugin].
	self storeExternalPluginList.! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 3/27/2002 15:01'!
generateInternalPlugin: pluginName 
	"generate the named internal plugin. Make sure the exports list is actually 
	correct and write it out"
	self deleteUnwantedInternalPluginDirectories.
	self privateGenerateInternalPlugin: pluginName.
	self generateExportsFile! !
!VMMaker methodsFor: 'generate sources' stamp: 'ar 4/7/2002 13:06'!
generateInternalPlugins
	"generate the internal plugins and add their exports to the main list. te exports list is NOT written to file by this method"

	self deleteUnwantedInternalPluginDirectories.
	self internalPluginsDo: [:plugin | 
		self privateGenerateInternalPlugin: plugin].
	self storeInternalPluginList.! !
!VMMaker methodsFor: 'generate sources' stamp: 'dtl 1/21/2011 21:00'!
generateInterpreterFile
	"Translate the Smalltalk description of the virtual machine into C.  If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead.  On the PPC, this results in a factor of three speedup with only 30% increase in code size.  Subclasses can use specialised versions of CCodeGenerator and interpreterClass."

	| cg cls |
	self needsToRegenerateInterpreterFile ifFalse: [^nil].
	self interpreterClass initialize.
	ObjectMemory initializeConstants.
	Interpreter initializeInterpreterSourceVersion.
	cg := self createCodeGenerator.
	cls := self interpreterClass.
	[cls == Object]
		whileFalse:
			[cg addClass: cls.
			cls := cls superclass].
	cg storeHeaderOnFile: self interpreterHeaderPath.
	cg storeCodeOnFile: self interpreterFilePath doInlining: self doInlining! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 3/4/2002 10:38'!
generateMainVM
"generate the interp, internal plugins and exports"

	self generateInterpreterFile;
		processFilesForCoreVM;
		processAssortedFiles;
		generateInternalPlugins;
		generateExportsFile! !
!VMMaker methodsFor: 'generate sources' stamp: 'dtl 1/2/2011 17:40'!
generateUtilityPrograms
	"Any additional sources not directly part of the VM may be generated here"

	Smalltalk
		at: #ImageFormat
		ifPresent: [:cls |  "generate ckformat utility program"
			cls storeCkstatusOnFile: (self sourceDirectory fullNameFor: 'ckformat.c')]! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 5/28/2008 19:45'!
inform: aProblemString
"log the problem in the transcript window"
	logger show: aProblemString; cr! !
!VMMaker methodsFor: 'initialize' stamp: 'dtl 5/27/2010 21:23'!
initialize
	logger := Transcript.
	inline := true.
	forBrowser := false.
	internalPlugins := SortedCollection new.
	externalPlugins := SortedCollection new.
	platformName := self class machinesDirName.
	allFilesList := Dictionary new.
	interpreterClassName := Interpreter name! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 10/16/2001 09:54'!
initializeAllExternal
	"add all the plugins to the external list and make sure the internal list is empty"

	self initializeInternal: #() external: self availablePlugins ! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 10/16/2001 09:54'!
initializeAllExternalBut: arrayOfInternalPluginNames
	"add all the plugins to the external list except for those listed, which should be added to the internal list"

	self initializeInternal: arrayOfInternalPluginNames external: (self availablePlugins copyWithoutAll: arrayOfInternalPluginNames )! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 10/16/2001 09:54'!
initializeAllInternal
	"add all the plugins to the internal list and make sure the external list is empty"

	self initializeInternal: self availablePlugins  external: #()! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 10/16/2001 09:54'!
initializeAllInternalBut: arrayOfExternalPluginNames
	"add all the plugins to the internal list except for those listed, which should be added to the external list"

	self initializeInternal: (self availablePlugins copyWithoutAll: arrayOfExternalPluginNames) external:  arrayOfExternalPluginNames! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 5/28/2008 17:11'!
initializeAllPlugins
"build the initial list of all possible plugins installed in the image"
	allPlugins := self providedPlugins! !
!VMMaker methodsFor: 'initialize'!
initializeInternal: arrayOfInternalPluginNames external: arrayOfExternalPluginNames
	"try to set up with the listed internal and external plugins."

	self initialize.

	self internal: arrayOfInternalPluginNames external: arrayOfExternalPluginNames! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 5/28/2008 18:03'!
internal: arrayOfInternalPluginNames external: arrayOfExternalPluginNames
	"try to set up with the listed internal and external plugins. Check that they are supportable plugins, reject those that are not - remember that this depends on the platform etc. This is the batch equivalent of using the VMMakerTool to drag each plugin to the relevant list(s) "

	"the intersection of the availablePlugins list and the input list stops any attempt to force in an improper plugin class"
	internalPlugins := (self availablePlugins intersection: arrayOfInternalPluginNames) select: [:pl | self canSupportPlugin: pl].
	allPlugins := allPlugins copyWithoutAll: internalPlugins.
	externalPlugins := (allPlugins intersection: arrayOfExternalPluginNames) select: [:pl | self canSupportPlugin: pl ].
	allPlugins := allPlugins copyWithoutAll: externalPlugins.
	! !
!VMMaker methodsFor: 'plugin lists' stamp: 'tpr 3/26/2002 18:36'!
internalModuleNames
	"return the list of all the internal plugins' moduleNames"
	^Array streamContents:[:strm| self internalPluginsDo:[:pl| strm nextPut: pl moduleName ]]! !
!VMMaker methodsFor: 'UI access'!
internalModules
	^internalPlugins! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 2/14/2002 14:27'!
internalPluginsDirectory
	"return the directory for the internal plugins sources"
	|fd|
	fd := self coreVMDirectory directoryNamed: 'intplugins'.
	fd assureExistence.
	^fd! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 2/14/2002 14:27'!
internalPluginsDirectoryFor: plugin
	"return the directory for the internal plugin sources"
	|fd|
	fd := self internalPluginsDirectory directoryNamed: plugin moduleName.
	fd assureExistence.
	^fd! !
!VMMaker methodsFor: 'plugin lists' stamp: 'tpr 1/24/2001 12:53'!
internalPluginsDo: aBlock 
	"for each class that should be an internal plugin, evaluate aBlock"
	self plugins: internalPlugins do: aBlock! !
!VMMaker methodsFor: 'generate sources' stamp: 'svp 11/14/2002 21:11'!
interpreterClass

	^Smalltalk at: interpreterClassName asSymbol! !
!VMMaker methodsFor: 'generate sources' stamp: 'svp 11/14/2002 21:11'!
interpreterClass: aClass

	interpreterClassName := aClass name asString! !
!VMMaker methodsFor: 'generate sources' stamp: 'svp 11/14/2002 21:03'!
interpreterClassName

	^interpreterClassName! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 5/28/2008 19:52'!
interpreterClassName: aString

	| tmp |
	interpreterClassName := aString.
	tmp := Smalltalk at: aString asSymbol ifAbsent: [nil].
	(tmp isNil or: [tmp isBehavior not]) ifTrue:
		[self invalidInterpreterClassName].! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 3/11/2003 14:02'!
interpreterExportsFilePath
	"return the full path for the interpreter exports file"
	^self coreVMDirectory fullNameFor: 'sqNamedPrims.h'! !
!VMMaker methodsFor: 'generate sources' stamp: 'ikp 9/2/2004 14:09'!
interpreterFilePath
	"Answer the fully-qualified path for the generated interpreter file."

	^self coreVMDirectory fullNameFor: self interpreterFilename! !
!VMMaker methodsFor: 'target directories' stamp: 'ikp 9/2/2004 14:11'!
interpreterFilename
	"Answer the filename for the core interpreter.  Default is 'interp.c'."

	^'interp.c'! !
!VMMaker methodsFor: 'target directories' stamp: 'ikp 9/2/2004 14:11'!
interpreterHeaderName
	"Answer the filename for the core interpreter header.  Default is 'interp.h'."

	^'interp.h'! !
!VMMaker methodsFor: 'generate sources' stamp: 'ikp 9/2/2004 14:10'!
interpreterHeaderPath
	"Answer the fully-qualified path for the generated interpreter header file."

	^self coreVMDirectory fullNameFor: self interpreterHeaderName! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 5/28/2008 19:55'!
invalidInterpreterClassName
	"This should raise a nice exception to a UI"
	(VMMakerException new messageText: 'Problem - ''', interpreterClassName, ''' - is invalid as an interpreter class name: ') signal! !
!VMMaker methodsFor: 'UI access' stamp: 'tpr 10/12/2001 15:34'!
listOfName: aSymbol
	"work out which list is the one associated with this symbol"
	#availableModules = aSymbol ifTrue:[^allPlugins].
	#internalModules = aSymbol ifTrue:[^internalPlugins].
	#externalModules =aSymbol ifTrue:[^externalPlugins].
	^nil! !
!VMMaker methodsFor: 'objects from disk' stamp: 'dtl 12/26/2010 19:03'!
loadConfiguration: aConfigArray
	"load the configuration but ignore the platformName - the platform name must have been handled during the creation of this vmmaker in order for it to work correctly"

	inline := aConfigArray at:3.
	forBrowser := aConfigArray at: 4.
	"This part must be ignored --> self setPlatName: (aConfigArray at: 5)."
	self sourceDirectoryName: (aConfigArray at: 6).
	self platformRootDirectoryName: ( aConfigArray at:7).
	self initializeAllPlugins.
	self internal: (aConfigArray at:1) external:(aConfigArray at:2).
	"Note - reserve slots 7 and 8 for backward compatibility. Slot 8 was
	previously used for the 32bit / 64bit flag, which is no longer required
	for the standard interpreter VM. Any new slots added should begin at 9."
	self changed: #reinitialize ! !
!VMMaker methodsFor: 'UI access' stamp: 'ar 3/10/2002 15:02'!
logger
	^logger! !
!VMMaker methodsFor: 'UI access' stamp: 'ar 3/10/2002 15:02'!
logger: aStream
	logger := aStream.! !
!VMMaker methodsFor: 'UI access' stamp: 'md 10/27/2004 14:23'!
makeAllModulesAvailable
	self internal: #() external: #().
	self reinitializePluginsLists! !
!VMMaker methodsFor: 'UI access' stamp: 'tpr 10/16/2001 12:10'!
makeAllModulesExternal
	self initializeAllPlugins.
	self internal: #() external: self availablePlugins.
	self changed: #reinitialize ! !
!VMMaker methodsFor: 'UI access' stamp: 'tpr 10/16/2001 12:10'!
makeAllModulesInternal
	self initializeAllPlugins.
	self internal: self availablePlugins external: #().
	self changed: #reinitialize ! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 4/9/2002 17:34'!
makefileDirectory
"where to put generated makefile related files"
	^self sourceDirectory! !
!VMMaker methodsFor: 'UI access' stamp: 'tpr 5/28/2008 17:10'!
movePlugin: pluginName from: srcListName to: dstListName
	"the VMMakerTool UI has been used to drag a plugin from one list to another "
	"we need to do some tests - 
		+are the lists actually ours? 
		+is the plugin ours? 
		+is the destination list one where we must check the plugin for 
		acceptability?
	return true if all is ok, false otherwise"
	| dstList srcList |
	dstList := self listOfName: dstListName.
	srcList := self listOfName: srcListName.
	dstList == allPlugins
		ifTrue: [dstList
				add: (srcList remove: pluginName)]
		ifFalse: ["the dest must be internal or external, so check the plugin for acceptability "
			(self canSupportPlugin: pluginName)
				ifTrue: [dstList
						add: (srcList remove: pluginName)]]! !
!VMMaker methodsFor: 'initialize' stamp: 'dtl 4/30/2009 22:47'!
needsToRegenerateInterpreterFile
"check the timestamp for the relevant classes and then the timestamp for the interp.c file if it already exists. Return true if the file needs regenerating, false if not"

	| tStamp fstat |
	tStamp := {self interpreterClass. ObjectMemory}
				inject: 0
				into: [:tS :cl | tS max: cl timeStamp].

	"don't translate if the file is newer than my timeStamp"
	fstat := self coreVMDirectory entryAt: self interpreterFilename ifAbsent:[nil].
	fstat ifNotNil:[tStamp < fstat modificationTime ifTrue:[^false]].
	^true
! !
!VMMaker methodsFor: 'processing external files' stamp: 'dtl 4/7/2010 09:26'!
nonAdminFilesIn: directory 
	"Answer file names in directory tree, excluding those associated with
	version control systems"
	^ directory fullNamesOfAllFilesInSubtree
		reject: [:el | (el findString: 'CVS' startingAt: 1) ~= 0
				or: [(el findString: '.svn' startingAt: 1) ~= 0]]! !
!VMMaker methodsFor: 'private - errors' stamp: 'tpr 5/28/2008 19:26'!
notSuitablePlugin: pluginClass forPlatform: platName
	(VMMakerException new messageText: pluginClass name, ' is not suitable for building for ', platName) signal! !
!VMMaker methodsFor: 'source directories' stamp: 'tpr 1/9/2002 20:35'!
platformDirectory
	"return the directory where we should find the platform specific sources"
	| fd platNm |
	fd := self platformRootDirectory.
	(fd directoryExists: (platNm := self platformName))
		ifFalse: ["The supposed directory for the actual platform code  
			does not exist."
			^ self couldNotFindPlatformDirectoryFor: platNm].
	^ fd directoryNamed: platNm! !
!VMMaker methodsFor: 'UI access'!
platformName
	^platformName! !
!VMMaker methodsFor: 'source directories' stamp: 'tpr 10/18/2001 19:46'!
platformPluginsDirectory
	"return the directory where we should find the platform plugin specific sources"

	(self platformDirectory directoryExists: self class pluginsDirName)
		ifFalse: ["The supposed directory for the plugins code does not 
					exist. We need to raise a suitable exception, but cant 
					think of one right now."
					^self couldNotFindPlatformDirectoryFor: 'any plugins needing ', self platformName].
	^self platformDirectory directoryNamed: self class pluginsDirName! !
!VMMaker methodsFor: 'source directories' stamp: 'tpr 1/9/2002 20:33'!
platformRootDirectory
	"return the directory where we should find all platform's sources"
	(FileDirectory default
			directoryExists: (platformRootDirName
					ifNil: [self class platformsDirName]))
		ifFalse: ["The supposed directory for the platforms code does not  
			exist."
			^ self couldNotFindDirectory: 'the platform code tree'].
	^ FileDirectory default
		directoryNamed: (platformRootDirName
				ifNil: [self class platformsDirName])! !
!VMMaker methodsFor: 'source directories' stamp: 'tpr 1/9/2002 20:28'!
platformRootDirectoryName: aString
	"set the directory where we should find all platform's sources
	There really ought to be plausible sanity checks done here"
	platformRootDirName := aString.
	(FileDirectory default directoryExists: aString) ifFalse:[self couldNotFindDirectory: aString. ^false].
	self reinitializePluginsLists.
	^true! !
!VMMaker methodsFor: 'plugin lists' stamp: 'tpr 1/24/2001 11:57'!
plugins: aCollection do: aBlock 
	"for each class in aCollection that should be a plugin, evaluate aBlock"
	aCollection do: [:sym | (Smalltalk hasClassNamed: sym)
			ifTrue: [aBlock value: (Smalltalk classNamed: sym)]
			ifFalse:["Another place to raise a sensible error to the UI"
				^self couldNotFindPluginClass: sym]]! !
!VMMaker methodsFor: 'private - copying files' stamp: 'ar 3/26/2006 17:32'!
primitiveCopyFileNamed: srcName to: dstName 
	"This really ought to be a facility in file system. The major annoyance 
	here is that file types and permissions are not handled by current 
	Squeak code"
	| buffer src dst |
	<primitive: 'primitiveFileCopyNamedTo' module:'FileCopyPlugin'> "primitiveExternalCall" 
	"If the plugin doesn't do it, go the slow way and lose the filetype info"
	"This method may signal FileDoesNotExistException if either the source or 
	dest files cannnot be opened; possibly permissions or bad name problems"
	[[src := FileStream readOnlyFileNamed: srcName]
		on: FileDoesNotExistException
		do: [^ self couldNotOpenFile: srcName].
	src binary.
	[dst := FileStream forceNewFileNamed: dstName]
		on: FileDoesNotExistException
		do: [^ self couldNotOpenFile: dstName].
	dst binary.
	buffer := ByteArray new: 50000.
	[src atEnd]
		whileFalse: [dst
				nextPutAll: (src nextInto: buffer)]]
		ensure: [src
				ifNotNil: [src close].
			dst
				ifNotNil: [dst close]]! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 5/28/2008 19:43'!
privateGenerateInternalPlugin: pluginName 
	"generate the named internal plugin"
	| plugin |
	"Refuse to translate this plugin if it is not in the internal plugins list or requires platform specific support and it is not present."
	[plugin := self validateInternalPlugin: pluginName] on: VMMakerException do:[:ex | self inform: ex messageText].

	plugin
		ifNil: [^ self couldNotFindPluginClass: pluginName].
	plugin
		translateInDirectory: (self internalPluginsDirectoryFor: plugin)
		doInlining: inline.
	logger show: 'internal plugin ' , plugin name , ' generated as ' , plugin moduleName; cr.
	self processFilesForInternalPlugin: plugin.
! !
!VMMaker methodsFor: 'processing external files' stamp: 'tpr 3/13/2002 14:25'!
processAssortedFiles
	"Here is where we get a chance to process any files needed as part of the make process; instructions, makefile fragments, resources etc.
	The default is to copy any miscellaneous files/dirs from the cross-platformDirectory/misc/ToCopy, then from the platform specific directory/misc/ToCopy. You can put any tree structure you like under misc/ToCopy, should that be important to you."
	| srcDir |
	"Is there a crossPlatformDirectory subdirectory called 'misc'?"
	(self crossPlatformDirectory directoryExists: 'misc')
		ifTrue: [srcDir := self crossPlatformDirectory directoryNamed: 'misc'.
			"Is there a subdirectory called 'ToCopy' ?"
			(srcDir directoryExists: 'ToCopy') ifTrue:[
				srcDir := srcDir directoryNamed: 'ToCopy'.
				self copyFilesFromSourceDirectory: srcDir toTargetDirectory: self sourceDirectory]].
	"Is there a platformDirectory subdirectory called 'misc'?"
	(self platformDirectory directoryExists: 'misc')
		ifTrue: [srcDir := self platformDirectory directoryNamed: 'misc'.
			"Is there a subdirectory called 'ToCopy' ?"
			(srcDir directoryExists: 'ToCopy') ifTrue:[
				srcDir := srcDir directoryNamed: 'ToCopy'.
				self copyFilesFromSourceDirectory: srcDir toTargetDirectory: self sourceDirectory]]! !
!VMMaker methodsFor: 'processing external files' stamp: 'dtl 4/7/2010 09:27'!
processFilesForCoreVM
	"process any cross-platform files from the crossPlatformDir and then any files relating to the core vm from the platformDirectory's vm subdirectory."
	"This is a stub ready for collecting all the filenames etc that might be needed to write a makefile. No details are yet certain."

	| vmDirName fList |
	vmDirName := self class coreVMDirName.
	fList := OrderedCollection new.
	{self crossPlatformDirectory directoryNamed: vmDirName.
	self platformDirectory directoryNamed: vmDirName.
	self coreVMDirectory}
		do:[:dir| fList addAll: (self nonAdminFilesIn: dir)].
	allFilesList at: 'vm' put: fList
! !
!VMMaker methodsFor: 'processing external files' stamp: 'dtl 4/7/2010 09:28'!
processFilesForExternalPlugin: plugin 
	"process any files relating to the external plugin.
	This also provides a  stub ready for collecting all the filenames etc that might be needed to write a makefile, carefully weeding out any CVS related files. No details are yet certain."
	|fList|
	fList := OrderedCollection new.
	{self crossPlatformPluginsDirectory directoryNamed:  plugin moduleName.
	self platformPluginsDirectory directoryNamed:  plugin moduleName.
	self externalPluginsDirectoryFor: plugin}
		do:[:dir| fList addAll: (self nonAdminFilesIn: dir)].
	allFilesList at: plugin moduleName put: fList! !
!VMMaker methodsFor: 'processing external files' stamp: 'dtl 4/7/2010 09:28'!
processFilesForInternalPlugin: plugin 
	"process any files relating to the internal plugin.
	This also provides a  stub ready for collecting all the filenames etc that might be needed to write a makefile, carefully weeding out any CVS related files. No details are yet certain."
	|fList|
	fList := OrderedCollection new.
	{self crossPlatformPluginsDirectory directoryNamed:  plugin moduleName.
	self platformPluginsDirectory directoryNamed:  plugin moduleName.
	self internalPluginsDirectoryFor: plugin}
		do:[:dir| fList addAll: (self nonAdminFilesIn: dir)].
	allFilesList at: plugin moduleName put: fList! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 10/12/2001 15:40'!
providedPlugins
	"generate the list by asking the InterpreterPlugins"
	^ ((InterpreterPlugin allSubclasses
		select: [:cl | cl shouldBeTranslated])
		collect: [:cl | cl name]) asSortedCollection! !
!VMMaker methodsFor: 'objects from disk' stamp: 'tpr 5/14/2001 15:07'!
readConfigurationFrom: aFileName
	"read info about the current configuration from a file. Return the array that would have been made by #configurationInfo"
	|  fileStream |

	fileStream := FileStream oldFileNamed: aFileName.
	^fileStream fileInObjectAndCode! !
!VMMaker methodsFor: 'UI access' stamp: 'tpr 10/11/2001 13:06'!
reinitializePluginsLists
	"something has changed that affects the validity of the plugin lists. Recalculate them as best we can. It is probably possible to check on the current lists and keep the configuration as close as possible the same; but for the moment just try to use the same lists "
	self initializeAllPlugins.
	self internal: internalPlugins external: externalPlugins.
	self changed: #reinitialize ! !
!VMMaker methodsFor: 'objects from disk' stamp: 'rww 9/23/2001 09:49'!
saveConfigurationTo: aFile
	"write info about the current configuration to a file."
	| fileStream |
	fileStream := FileStream newFileNamed: aFile.
	fileStream fileOutClass: nil andObject: self configurationInfo! !
!VMMaker methodsFor: 'initialize' stamp: 'tpr 10/11/2001 12:53'!
setPlatName: aString
	"private - just set the platform name string, nothing else. Go away...."
	platformName := aString! !
!VMMaker methodsFor: 'target directories' stamp: 'dtl 5/27/2010 21:11'!
sourceDirectory
	| fd |
	fd := FileDirectory default
				directoryNamed: (sourceDirName
						ifNil: [self class sourceDirName]).
	fd assureExistence.
	^ fd! !
!VMMaker methodsFor: 'target directories' stamp: 'tpr 2/14/2002 14:27'!
sourceDirectoryName: aString
	"Sanity check really ought to be added, This is the root directory for where the sources will be WRITTEN"
	sourceDirName := aString.
	(FileDirectory on: aString) assureExistence.
	self changed: #sourceDirectory.
	^true! !
!VMMaker methodsFor: 'exports' stamp: 'tpr 4/12/2006 12:28'!
storeExportsOn: aFilename 
	"Store the exports on the given file"
	| s |
	[s := CrLfFileStream forceNewFileNamed: aFilename] 
		on: FileDoesNotExistException 
		do:[^self couldNotOpenFile: aFilename].
	s nextPutAll: '/* '.
	s nextPutAll: VMMaker headerNotice.
	s nextPutAll: ' */'; cr.
	s nextPutAll:'/* This is an automatically generated table of all builtin modules in the VM */'; cr.
	s cr; nextPutAll:'extern sqExport vm_exports[];'.
	s cr; nextPutAll: 'extern sqExport os_exports[];'.
	self internalPluginsDo:[:cls|
		s cr; nextPutAll: 'extern sqExport '; nextPutAll: cls moduleName; nextPutAll:'_exports[];'.
	].
	s cr.

	s cr; nextPutAll:'sqExport *pluginExports[] = {'.
	s crtab; nextPutAll:'vm_exports,'.
	s crtab; nextPutAll: 'os_exports,'.
	self internalPluginsDo:[:cls|
		s crtab; nextPutAll: cls moduleName; nextPutAll:'_exports,'
	].
	s crtab; nextPutAll:'NULL'.
	s cr; nextPutAll:'};'; cr.
	s close! !
!VMMaker methodsFor: 'exports' stamp: 'tpr 4/12/2006 12:27'!
storeExternalPluginList
	| s fileName |
	fileName := self makefileDirectory fullNameFor: 'plugins.ext'.
	[s := CrLfFileStream forceNewFileNamed: fileName] 
		on: FileDoesNotExistException 
		do:[^self couldNotOpenFile: fileName].
	s nextPutAll:'# Automatically generated makefile include for external plugins'.
	s cr; nextPutAll:'EXTERNAL_PLUGINS ='.
	self externalPluginsDo:[:cls|
		s space; nextPutAll: cls moduleName.
	].
	s cr; close! !
!VMMaker methodsFor: 'exports' stamp: 'tpr 4/12/2006 12:27'!
storeInternalPluginList
	| s fileName |
	fileName := self makefileDirectory fullNameFor: 'plugins.int'.
	[s := CrLfFileStream forceNewFileNamed: fileName] 
		on: FileDoesNotExistException 
		do:[^self couldNotOpenFile: fileName].
	s nextPutAll:'# Automatically generated makefile include for internal plugins'.
	s cr; nextPutAll:'INTERNAL_PLUGINS ='.
	self internalPluginsDo:[:cls|
		s space; nextPutAll: cls moduleName.
	].
	s cr; close! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 10/17/2001 13:15'!
validateExternalPlugin:	plName

	^self validatePlugin: plName in: externalPlugins! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 10/17/2001 13:15'!
validateInternalPlugin:	plName

	^self validatePlugin: plName in: internalPlugins! !
!VMMaker methodsFor: 'generate sources' stamp: 'tpr 5/28/2008 19:05'!
validatePlugin:	plName in: listOfPlugins
"check that the plName is either an actual plugin class or a plugin class name. Return the plugin class or raise an error if nil"
	| plugin |
	plName isString
		ifTrue: [(listOfPlugins includes: plName)
				ifTrue: [plugin := Smalltalk classNamed: plName]]
		ifFalse: [((plName isBehavior
						and: [plName inheritsFrom: InterpreterPlugin])
					and: [listOfPlugins includes: plName name])
				ifTrue: [plugin := plName]].
	plugin ifNil: [^ self couldNotFindPluginClass: plName].

	"Make sure we have any and all platform and file support for this plugin"

	(plugin isSuitablePluginForPlatform: self platformName) ifFalse:[^self notSuitablePlugin: plugin forPlatform: self platformName].
		
	"Is there a cross-platform or platform files directory of the same name as this plugin?"
	plugin requiresPlatformFiles
		ifTrue: [(self platformPluginsDirectory directoryExists: plugin moduleName)
				ifFalse: [logger show: 'No platform specific files found for ' , plugin moduleName printString; cr.
					^ self couldNotFindPlatformFilesFor: plugin]].
	plugin requiresCrossPlatformFiles
		ifTrue: [(self crossPlatformPluginsDirectory directoryExists: plugin moduleName)
				ifFalse: [logger show: 'No cross platform files found for ' , plugin moduleName printString; cr.
					^ self couldNotFindPlatformFilesFor: plugin]].

	^plugin! !

VMMaker subclass: #VMMakerWithFileCopying
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!VMMakerWithFileCopying commentStamp: '<historical>' prior: 0!
This subclass of VMMaker is a hopefully temporary way to provide the copying of files from platforms/{Cross|foo} to src/ until all platforms are able to do their compiling with the platforms tree in place.

The default class will NOT do the file copies and gradually the platform specific classes can be removed as they all catch up.!
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 4/9/2002 18:51'!
copyCrossPlatformFilesFor: plugin internal: aBoolean
	| srcDir targetDir |
	[srcDir := self crossPlatformPluginsDirectory directoryNamed: plugin moduleName.
	targetDir := aBoolean ifTrue:[self internalPluginsDirectoryFor: plugin]
					ifFalse:[self externalPluginsDirectoryFor: plugin].
	logger show: 'Copy any cross platform files from: ' , srcDir printString , ' to ' , targetDir printString; cr.
	self copyFilesFromSourceDirectory: srcDir toTargetDirectory: targetDir]
		on: FileStreamException
		do: ["If any file related exceptions get here, we've had some problem, probably path of permissions. Raise the general exception"
			^ self couldNotFindPlatformFilesFor: plugin]! !
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 4/17/2002 16:23'!
copyCrossPlatformVMFiles
	| srcDir targetDir vmDirName |
	vmDirName := self class coreVMDirName.

	"Is there a crossPlatformDirectory subdirectory called 'vmDirName'?"
	(self crossPlatformDirectory directoryExists: vmDirName)
		ifTrue: [srcDir := self crossPlatformDirectory directoryNamed: vmDirName.
			targetDir := self coreVMDirectory.
			self copyFilesFromSourceDirectory: srcDir toTargetDirectory: targetDir]! !
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 4/9/2002 18:51'!
copyPlatformFilesFor: plugin internal: aBoolean
	| srcDir targetDir |
	[srcDir := self platformPluginsDirectory directoryNamed: plugin moduleName.
	targetDir := aBoolean ifTrue:[self internalPluginsDirectoryFor: plugin]
					ifFalse:[self externalPluginsDirectoryFor: plugin].
	logger show: 'Copy any platform files from: ' , srcDir printString , ' to ' , targetDir printString; cr.
	self copyFilesFromSourceDirectory: srcDir toTargetDirectory: targetDir]
		on: FileStreamException
		do: ["If any file related exceptions get here, we've had some problem, probably path of permissions. Raise the general exception"
			^ self couldNotFindPlatformFilesFor: plugin]! !
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 4/17/2002 16:23'!
copyPlatformVMFiles
	| srcDir targetDir vmDirName |
	vmDirName := self class coreVMDirName.

	"Is there a platformDirectory subdirectory called 'vmDirName'?"
	(self platformDirectory directoryExists: vmDirName)
		ifTrue: [srcDir := self platformDirectory directoryNamed: vmDirName.
			targetDir := self coreVMDirectory.
			self copyFilesFromSourceDirectory: srcDir toTargetDirectory: targetDir]! !
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 3/4/2002 10:34'!
processAssortedFiles
	"See the comment in VMMaker> processAssortedFiles first.
	This version of the method will copy any miscellaneous files/dirs from the cross-platformDirectory -  readme files etc, then from the platform specific directory - makefiles, utils etc. "
	 
	| srcDir |
	"Is there a crossPlatformDirectory subdirectory called 'misc'?"
	(self crossPlatformDirectory directoryExists: 'misc')
		ifTrue: [srcDir := self crossPlatformDirectory directoryNamed: 'misc'.
			self copyFilesFromSourceDirectory: srcDir toTargetDirectory: self sourceDirectory].
	"Is there a platformDirectory subdirectory called 'misc'?"
	(self platformDirectory directoryExists: 'misc')
		ifTrue: [srcDir := self platformDirectory directoryNamed: 'misc'.
			self copyFilesFromSourceDirectory: srcDir toTargetDirectory: self sourceDirectory].

	"Now copy any files that are always copied for all platforms"
	super processAssortedFiles
! !
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 4/17/2002 16:24'!
processFilesForCoreVM
	"When using a copying version of VMMaker, copy any cross-platform files from the crossPlatformDir and then copy any files relating to the core vm from the platformDirectory's vm subdirectory."
	super processFilesForCoreVM.

	"Is there a crossPlatformDirectory subdirectory called 'vmDirName'?"
	self copyCrossPlatformVMFiles.

	"Is there a platformDirectory subdirectory called 'vmDirName'?"
	self copyPlatformVMFiles
! !
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 4/9/2002 18:51'!
processFilesForExternalPlugin: plugin 
	"See comment in VMMaker>processFileForExternalPlugin: first.
	When using a copying version of VMMaker, copy any files relating to the external plugin from the crossPlatform & platformDirectory subdir 'plugins'"

	super processFilesForExternalPlugin: plugin.

	"This version of the method has to actually copy files around"
	self copyCrossPlatformFilesFor: plugin internal: false;
		copyPlatformFilesFor: plugin internal: false! !
!VMMakerWithFileCopying methodsFor: 'copying files' stamp: 'tpr 4/9/2002 18:52'!
processFilesForInternalPlugin: plugin 
	"See comment in VMMaker>processFileForInternalPlugin: first.
	When using a copying version of VMMaker, copy any files relating to the internal plugin from the crossPlatform & platformDirectory subdir 'plugins'"

	super processFilesForInternalPlugin: plugin.

	"This version of the method has to actually copy files around"
	self copyCrossPlatformFilesFor: plugin internal: true;
		copyPlatformFilesFor: plugin internal: true! !

VMMaker subclass: #Win32VMMaker
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!Win32VMMaker commentStamp: 'tpr 5/5/2003 12:30' prior: 0!
A special form of VMMaker to suit Windows machines.  Copies files around a little.!
!Win32VMMaker methodsFor: 'target directories' stamp: 'ar 9/4/2006 18:01'!
deleteUnwantedExternalPluginDirectories
	"Don't."! !
!Win32VMMaker methodsFor: 'target directories' stamp: 'ar 9/4/2006 18:01'!
deleteUnwantedInternalPluginDirectories
	"Don't."! !
!Win32VMMaker methodsFor: 'target directories' stamp: 'ar 9/4/2006 17:55'!
externalPluginsDirectory
	"return the target directory for the external plugins sources"
	^self sourceDirectory
"	| fd |
	fd := self sourceDirectory directoryNamed: 'external'.
	fd assureExistence.
	^fd"! !
!Win32VMMaker methodsFor: 'target directories' stamp: 'ar 9/4/2006 17:55'!
internalPluginsDirectory
	"return the target directory for the internal plugins sources"
	^self sourceDirectory
"	| fd |
	fd := self sourceDirectory directoryNamed: 'internal'.
	fd assureExistence.
	^fd"! !
!Win32VMMaker methodsFor: 'copying files' stamp: 'ar 5/5/2002 01:57'!
processAssortedFiles
	"Do nothing."! !
!Win32VMMaker methodsFor: 'generate sources' stamp: 'tpr 5/28/2008 19:22'!
validatePlugin:	plName in: listOfPlugins
	"The normal file release process bundles all files in the plugin directory, so don't bother users telling them 'there are no cross platform files for xyz' if there is are platform specific files present."
	| plugin |
	plName isString
		ifTrue: [(listOfPlugins includes: plName)
				ifTrue: [plugin := Smalltalk classNamed: plName]]
		ifFalse: [((plName isBehavior
						and: [plName inheritsFrom: InterpreterPlugin])
					and: [listOfPlugins includes: plName name])
				ifTrue: [plugin := plName]].
	plugin ifNil: [^ self couldNotFindPluginClass: plName].

	"Make sure we have any and all platform and file support for this plugin"

	(plugin isSuitablePluginForPlatform: self platformName) ifFalse:[^self notSuitablePlugin: plugin forPlatform: self platformName].
		
	"Is there a cross-platform or platform files directory of the same name as this plugin?"
	plugin requiresPlatformFiles
		ifTrue: [(self platformPluginsDirectory directoryExists: plugin moduleName)
				ifFalse: [logger show: 'No platform specific files found for ' , plugin moduleName printString; cr.
					^ self couldNotFindPlatformFilesFor: plugin]].
	plugin requiresCrossPlatformFiles ifTrue: [
		((self platformPluginsDirectory directoryExists: plugin moduleName)
			or:[self crossPlatformPluginsDirectory directoryExists: plugin moduleName])
				ifFalse: [logger show: 'No cross platform files found for ' , plugin moduleName printString; cr.
					^ self couldNotFindPlatformFilesFor: plugin]].

	^plugin! !

Error subclass: #VMMakerException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Building'!
!VMMakerException commentStamp: 'tpr 5/5/2003 12:28' prior: 0!
An exception class for the use of VMMaker!
!IntegerArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:17'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asIntPtrFrom: anInteger on: aStream! !
!IntegerArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/25/1999 15:00'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asIntPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isWords')! !
!IntegerArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:18'!
ccgDeclareCForVar: aSymbolOrString

	^'int *', aSymbolOrString! !
!Array class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:12'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asIntPtrFrom: anInteger on: aStream! !
!Array class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/19/1999 13:10'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asIntPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isIndexable')! !
!Array class methodsFor: '*VMMaker-plugin generation' stamp: 'ikp 3/31/2005 14:20'!
ccgDeclareCForVar: aSymbolOrString

	^'sqInt *', aSymbolOrString! !
!FloatArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:17'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asFloatPtrFrom: anInteger on: aStream! !
!FloatArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/18/1999 17:07'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asWBFloatPtrFrom: anInteger! !
!FloatArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:14'!
ccgDeclareCForVar: aSymbolOrString

	^'float *', aSymbolOrString! !
!Boolean class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:06'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asBooleanValueFrom: anInteger on: aStream ! !
!Boolean class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 10/5/1999 06:05'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToBooleanObjectFrom: aNode on: aStream! !
!Boolean class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 10/5/1999 06:10'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToBooleanValueFrom: aNode on: aStream! !
!Boolean class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/18/1999 17:08'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asBooleanValueFrom: anInteger! !
!Bitmap methodsFor: '*VMMaker-interpreter simulator' stamp: 'ajh 8/20/2002 01:13'!
coerceTo: cTypeString sim: interpreter

	^ self! !
!WordArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:19'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asIntPtrFrom: anInteger on: aStream! !
!WordArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/20/1999 13:16'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asUnsignedPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isWords')! !
!WordArray class methodsFor: '*VMMaker-plugin generation' stamp: 'ikp 3/31/2005 14:19'!
ccgDeclareCForVar: aSymbolOrString

	^'usqInt *', aSymbolOrString! !
!SmallInteger class methodsFor: '*VMMaker-plugin generation' stamp: 'eem 10/2/2010 14:12'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream
	"N.B.  The is used both for generation and simulation so answer the result (for interpretation)"
	^cg generateCoerceToSmallIntegerObjectFrom: aNode on: aStream! !
!SmallInteger class methodsFor: '*VMMaker-plugin generation' stamp: 'eem 10/3/2010 08:09'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream
	"N.B.  The could be used both for generation and simulation so answer the result (for interpretation)"
	^cg generateCoerceToSmallIntegerValueFrom: aNode on: aStream! !
!SmallInteger class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/18/1999 17:09'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asIntegerValueFrom: anInteger! !
!SmallInteger class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/20/1999 11:20'!
ccgCanConvertFrom: anObject

	^anObject class == self! !
!VariableNode methodsFor: '*VMMaker-C translation' stamp: 'eem 10/2/2009 11:26'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"
	name = 'true' ifTrue: [^ TConstantNode new setValue: true].
	name = 'false' ifTrue: [^ TConstantNode new setValue: false].
	^ TVariableNode new setName: name! !

TestCase subclass: #JPEGReadWriter2PluginTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Tests'!
!JPEGReadWriter2PluginTest commentStamp: 'dtl 10/9/2010 12:22' prior: 0!
Unit tests for JPEGReadWriter2Plugin. Initially this is a single test that documents a bug report, other tests may be added over time.
!
!JPEGReadWriter2PluginTest methodsFor: 'private' stamp: 'dtl 11/2/2010 13:15'!
formBytes
	"A jpeg that was generated from Squeak. When written to and from a
	stream, the same bytes should be obtained."

	^ #(255 216 255 224 0 16 74 70 73 70 0 1 1 0 0 1 0 1 0 0 255 219 0 67 0 8 6 6 7 6 5 8 7 7 7 9 9 8 10 12 20 13 12 11 11 12 25 18 19 15 20 29 26 31 30 29 26 28 28 32 36 46 39 32 34 44 35 28 28 40 55 41 44 48 49 52 52 52 31 39 57 61 56 50 60 46 51 52 50 255 219 0 67 1 9 9 9 12 11 12 24 13 13 24 50 33 28 33 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 255 192 0 17 8 0 1 0 1 3 1 34 0 2 17 1 3 17 1 255 196 0 31 0 0 1 5 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 2 3 4 5 6 7 8 9 10 11 255 196 0 181 16 0 2 1 3 3 2 4 3 5 5 4 4 0 0 1 125 1 2 3 0 4 17 5 18 33 49 65 6 19 81 97 7 34 113 20 50 129 145 161 8 35 66 177 193 21 82 209 240 36 51 98 114 130 9 10 22 23 24 25 26 37 38 39 40 41 42 52 53 54 55 56 57 58 67 68 69 70 71 72 73 74 83 84 85 86 87 88 89 90 99 100 101 102 103 104 105 106 115 116 117 118 119 120 121 122 131 132 133 134 135 136 137 138 146 147 148 149 150 151 152 153 154 162 163 164 165 166 167 168 169 170 178 179 180 181 182 183 184 185 186 194 195 196 197 198 199 200 201 202 210 211 212 213 214 215 216 217 218 225 226 227 228 229 230 231 232 233 234 241 242 243 244 245 246 247 248 249 250 255 196 0 31 1 0 3 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 1 2 3 4 5 6 7 8 9 10 11 255 196 0 181 17 0 2 1 2 4 4 3 4 7 5 4 4 0 1 2 119 0 1 2 3 17 4 5 33 49 6 18 65 81 7 97 113 19 34 50 129 8 20 66 145 161 177 193 9 35 51 82 240 21 98 114 209 10 22 36 52 225 37 241 23 24 25 26 38 39 40 41 42 53 54 55 56 57 58 67 68 69 70 71 72 73 74 83 84 85 86 87 88 89 90 99 100 101 102 103 104 105 106 115 116 117 118 119 120 121 122 130 131 132 133 134 135 136 137 138 146 147 148 149 150 151 152 153 154 162 163 164 165 166 167 168 169 170 178 179 180 181 182 183 184 185 186 194 195 196 197 198 199 200 201 202 210 211 212 213 214 215 216 217 218 226 227 228 229 230 231 232 233 234 242 243 244 245 246 247 248 249 250 255 218 0 12 3 1 0 2 17 3 17 0 63 0 40 162 138 0 255 217) asByteArray
! !
!JPEGReadWriter2PluginTest methodsFor: 'testing' stamp: 'dtl 10/9/2010 12:28'!
testPluginPresent

	self assert: JPEGReadWriter2 new isPluginPresent! !
!JPEGReadWriter2PluginTest methodsFor: 'testing' stamp: 'dtl 10/9/2010 14:13'!
testPrimJPEGReadImage

	| form |
	form := JPEGReadWriter2 formFromStream: self formBytes readStream.
	self should: form bits first = 16rFF808080

"[Vm-dev] JPEGReadWriter2Plugin
Bert Freudenberg bert at freudenbergs.de
Mon Sep 27 15:22:43 UTC 2010

Hi,

have there been changes lately to the jpeg plugin?

On a Mac 4.2.4 VM I see an off-by-one error, all pixels are moved to the right, the first pixel is transparent. On a Mac 5.8.1 Cog VM it works as expected though.

Here's my little test:

(JPEGReadWriter2 formFromStream: #[16rFF 16rD8 16rFF 16rE0 16r00 16r10 16r4A 16r46 16r49 16r46 16r00 16r01 16r01 16r01 16r00 16r48 16r00 16r48 16r00 16r00 16rFF 16rDB 16r00 16r43 16r00 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rFF 16rC2 16r00 16r0B 16r08 16r00 16r01 16r00 16r01 16r01 16r01 16r11 16r00 16rFF 16rC4 16r00 16r14 16r10 16r01 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16r00 16rFF 16rDA 16r00 16r08 16r01 16r01 16r00 16r01 16r3F 16r10] readStream) bits first hex

On 5.8.11 I get 16rFF808080 as expected, on 4.2.4 I get 0.
"! !
!JPEGReadWriter2PluginTest methodsFor: 'testing' stamp: 'dtl 10/9/2010 14:14'!
testPrimJPEGWriteImage

	| form bytes ws |
	form := JPEGReadWriter2 formFromStream: self formBytes readStream.
	ws := WriteStream on: ByteArray new.
	JPEGReadWriter2 putForm: form onStream: ws.
	bytes := ws contents.
	self should: self formBytes = bytes
! !

TestCase subclass: #MiscPrimitivePluginTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Tests'!
!MiscPrimitivePluginTest commentStamp: 'dtl 11/10/2010 22:04' prior: 0!
Various classes in the image contain methods intended for translation to C for execution as primitives in MiscPrimitivePlugin. MiscPrimitivePluginTest provides tests to validate these methods.
!
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/9/2010 19:48'!
compare: string1 with: string2 collated: order
	"Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array."

	<primitive: 'primitiveCompareString' module: 'MiscPrimitivePlugin'>
	self primitiveFailed
! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/10/2010 19:42'!
compress: bm toByteArray: ba

	<primitive: 'primitiveCompressToByteArray' module: 'MiscPrimitivePlugin'>
	self primitiveFailed! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/10/2010 20:03'!
convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer
	"Copy the contents of the given array of signed 8-bit samples into the given array of 16-bit signed samples."

	<primitive: 'primitiveConvert8BitSigned' module: 'MiscPrimitivePlugin'>
	self primitiveFailed
! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/10/2010 19:42'!
decompress: bm fromByteArray: ba at: index

	<primitive: 'primitiveDecompressFromByteArray' module: 'MiscPrimitivePlugin'>
	self primitiveFailed
! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/10/2010 20:03'!
findFirstInString: aString  inSet: inclusionMap  startingAt: start

	<primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
	self primitiveFailed
! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/9/2010 19:38'!
findSubstring: key in: body startingAt: start matchTable: matchTable
	"Answer the index in the string body at which the substring key first occurs, at or beyond start.  The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches.  If no match is found, zero will be returned."

	<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
	self primitiveFailed
! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/10/2010 21:36'!
hashBytes: aByteArray startingWith: speciesHash
	"Answer the hash of a byte-indexed collection,
	using speciesHash as the initial value.
	See SmallInteger>>hashMultiply.

	The primitive should be renamed at a
	suitable point in the future"

	<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>
	self primitiveFailed
! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/10/2010 20:03'!
indexOfAscii: anInteger inString: aString startingAt: start

	<primitive: 'primitiveIndexOfAsciiInString' module: 'MiscPrimitivePlugin'>
	self primitiveFailed
! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/9/2010 20:00'!
testCompareWithCollated
	"Verify that primitive exists in the VM"

	self assert: 3 = (self compare: 'foo' with: 'bar' collated: ((0 to: 255) as: ByteArray))
! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/10/2010 08:03'!
testCompressToByteArray

	| bitmap byteArray |
	bitmap := Bitmap with: 16rFFFFFFFF.
	byteArray := ByteArray new:  4.
	self compress: bitmap toByteArray: byteArray.
	self should: byteArray = #[1 5 255 0]! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/10/2010 20:14'!
testConvert8bitSignedFromTo16Bit
	"SampledSound class>>convert8bitSignedFrom:to16Bit:"


	| aByteArray aSoundBuffer |
	aByteArray := #[1 2 3 4 5 6 7 8 9].
	aSoundBuffer := SoundBuffer newMonoSampleCount: aByteArray size.
	self convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer.
	self assert: aSoundBuffer = ((SoundBuffer new: 10) at: 1 put: 256; at: 2 put: 512;
		at: 3 put: 768; at: 4 put: 1024; at: 5 put: 1280; at: 6 put: 1536; at: 7 put: 1792;
		at: 8 put: 2048; at: 9 put: 2304; at: 10 put: 0; yourself)! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/10/2010 20:00'!
testDecompressFromByteArrayAt

	| bitmap byteArray s size |
	byteArray := #(1 5 255  0) asByteArray.
	s := ReadStream on: byteArray.
	size := Bitmap decodeIntFrom: s.
	bitmap := Bitmap new: size.
	self decompress: bitmap fromByteArray: byteArray at: s position + 1.
	self should: bitmap = ((Bitmap new: 1) at: 1 put: 4294967295; yourself)! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/9/2010 20:54'!
testFindFirstInStringInSetStartingAt

	| position set |
	set := ((0 to: 255) collect: [:e | (e \\ 2) + $0 asciiValue]) asByteArray.
	position := self findFirstInString: 'abcdef' inSet: set startingAt: 1.
	self assert: position = 1
! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/9/2010 20:14'!
testFindSubstring
	"Verify that primitive exists in the VM and that non byte array arguments cause primitive to fail"

	| position |
	position := MiscPrimitivePluginTest new
				findSubstring: 'bc'
				in: 'abcdef'
				startingAt: 1
				matchTable: ((0 to: 255)
						as: ByteArray).
	self assert: position = 2.
	self should: [MiscPrimitivePluginTest new
				findSubstring: 'bc' asWideString
				in: 'abcdef'
				startingAt: 1
				matchTable: ((0 to: 255)
						as: ByteArray)]
					raise: Error.
	self should: [MiscPrimitivePluginTest new
				findSubstring: 'bc'
				in: 'abcdef' asWideString
				startingAt: 1
				matchTable: ((0 to: 255)
						as: ByteArray)]
					raise: Error.
	self should: [MiscPrimitivePluginTest new
				findSubstring: 'bc' asWideString
				in: 'abcdef' asWideString
				startingAt: 1
				matchTable: ((0 to: 255)
						as: ByteArray)]
					raise: Error
! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/10/2010 21:48'!
testHashBytesStartingWith

	| ba result |
	ba := #[1 2 3 4 5 6 7 8 9].
	result := self hashBytes: ba startingWith: 12345.
	self assert: result = 170953102
! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/9/2010 20:57'!
testIindexOfAsciiInStringStartingAt

	| position |
	position := self indexOfAscii: 50 inString: '012345' startingAt: 1.
	self assert: position = 3! !
!MiscPrimitivePluginTest methodsFor: 'testing' stamp: 'dtl 11/9/2010 20:33'!
testTranslateFromToTable
	"Verify that primitive exists in the VM"

	| s t |
	s := 'foo' copy. "copy so string is instantiated each time"
	t := ByteArray withAll: ((1 to: 255) as: ByteArray).
	self translate: s from: 1 to: 3 table: t.
	self assert: s = 'gpp'
! !
!MiscPrimitivePluginTest methodsFor: 'primitives' stamp: 'dtl 11/10/2010 20:03'!
translate: aString from: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"

	<primitive: 'primitiveTranslateStringWithTable' module: 'MiscPrimitivePlugin'>
	self primitiveFailed! !

TestCase subclass: #ObjectMemoryVariablesTest
	instanceVariableNames: 'saveWordSize omv32 omv64'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Tests'!
!ObjectMemoryVariablesTest commentStamp: 'dtl 5/31/2010 16:47' prior: 0!
ObjectMemoryVariablesTest validates the values of the constants defined in ObjectMemory class>>initBytesPerWord:

The intent is to enable rewriting these constants in a manner that permits them to be fully defined as C preprocessor macros at compile time, such that separate code generation is not required for 32-bit and 64-bit object memory.

See CCodeGenerator>>emitDefineBytesPerWordOn: for the C preprocessor macro definitions.!
!ObjectMemoryVariablesTest methodsFor: 'running' stamp: 'dtl 6/6/2010 12:25'!
setUp
	ObjectMemory initializeConstants! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:35'!
testByte0Mask

	self assert: ObjectMemory byte0Mask = 16r00000000000000FF! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:36'!
testByte0Shift

	self assert: ObjectMemory byte0Shift = 0! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:36'!
testByte1Mask

	self assert: ObjectMemory byte1Mask = 16r000000000000FF00! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:36'!
testByte1Shift

	self assert: ObjectMemory byte1Shift = 8! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:36'!
testByte1ShiftNegated
	"Note - signed values are not relevant for bit mask operations, can be recoded as positive"

	self assert: ObjectMemory byte1ShiftNegated = -16r0000000000000008.! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:37'!
testByte2Mask

	self assert: ObjectMemory byte2Mask = 16r0000000000FF0000! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:37'!
testByte2Shift

	self assert: ObjectMemory byte2Shift = 16! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:37'!
testByte3Mask

	self assert: ObjectMemory byte3Mask = 16r00000000FF000000! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:37'!
testByte3Shift

	self assert: ObjectMemory byte3Shift = 24! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:37'!
testByte3ShiftNegated
	"Note - signed values are not relevant for bit mask operations, can be recoded as positive"

	self assert: ObjectMemory byte3ShiftNegated = -16r0000000000000018! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte4Mask

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory byte4Mask = 16r0000000000000000."

	self assert: ObjectMemory byte4Mask = 16r000000FF00000000! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:37'!
testByte4Shift

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemoryConstantsAccess byte4Shift = 0."

	self assert: ObjectMemory byte4Shift = 32! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte4ShiftNegated
	"Note - signed values are not relevant for bit mask operations, can be recoded as positive"

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory  initBytesPerWord: 4.
	self assert: ObjectMemory byte4ShiftNegated = 16r0000000000000000."

	self assert: ObjectMemory byte4ShiftNegated = -16r0000000000000020! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte5Mask

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory byte5Mask = 16r0000000000000000."

	self assert: ObjectMemory byte5Mask = 16r0000FF0000000000! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte5Shift

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory byte5Shift = 0."

	self assert: ObjectMemory byte5Shift = 40! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte5ShiftNegated
	"Note - signed values are not relevant for bit mask operations, can be recoded as positive"

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory  initBytesPerWord: 4.
	self assert: ObjectMemory byte5ShiftNegated = 16r0000000000000000."

	self assert: ObjectMemory byte5ShiftNegated = -16r0000000000000028! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte6Mask

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory byte6Mask = 16r0000000000000000."

	self assert: ObjectMemory byte6Mask = 16r00FF000000000000! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte6Shift

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory byte6Shift = 0."

	self assert: ObjectMemory byte6Shift = 48! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte7Mask

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory byte7Mask = 16r0000000000000000."

	self assert: ObjectMemory byte7Mask = 16rFF00000000000000! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte7Shift

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory byte7Shift = 0."

	self assert: ObjectMemory byte7Shift = 56! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:39'!
testByte7ShiftNegated
	"Note - signed values are not relevant for bit mask operations, can be recoded as positive"

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory  initBytesPerWord: 4.
	self assert: ObjectMemory byte7ShiftNegated = 16r0000000000000000."

	self assert: ObjectMemory byte7ShiftNegated = -16r0000000000000038! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:38'!
testBytes3to0Mask

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory bytes3to0Mask = 16r0000000000000000."

	self assert: ObjectMemory bytes3to0Mask = 16r00000000FFFFFFFF! !
!ObjectMemoryVariablesTest methodsFor: 'testing - constants' stamp: 'dtl 5/31/2010 16:38'!
testBytes7to4Mask

	"Note - unused for 32-bit object memory, so 32-bit test is no longer relevant
	ObjectMemory initBytesPerWord: 4.
	self assert: ObjectMemory bytes7to4Mask = 16r0000000000000000."

	self assert: ObjectMemory bytes7to4Mask = 16rFFFFFFFF00000000! !

TestCase subclass: #SlangTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Tests'!
!SlangTest commentStamp: 'dtl 9/18/2010 17:43' prior: 0!
The SlangTest tests verify code generation and inlining.
!
!SlangTest methodsFor: 'running' stamp: 'dtl 9/19/2010 21:29'!
setUp

	"Some of the test may be long running when SlangTestSupport is a subclass
	of ObjectMemory."
	(self respondsTo: #timeout: ) "Recent Squeak images with test case timeout"
		ifTrue: [self perform: #timeout: with: 30].
	VMMaker clearCacheEntriesFor: SlangTestSupportPlugin.
	VMMaker clearCacheEntriesFor: SlangTestSupportSSIP! !
!SlangTest methodsFor: 'slang browser dependency' stamp: 'dtl 9/19/2010 21:27'!
testASlangBrowserInstalled
	"The SlangBrowser package must be installed in order for these tests
	to run"

	self assert: (SlangTestSupportPlugin respondsTo: #asCString)! !
!SlangTest methodsFor: 'testing interpreter' stamp: 'dtl 9/18/2010 17:42'!
testInterpDeclareExport
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportInterpreter asCString: #declareExportTrueByMethod)
			copyReplaceAll: 'declareExportTrueByMethod'
			with: 'methodName'.
	p := (SlangTestSupportInterpreter asCString: #declareExportTrueByPragma)
			copyReplaceAll: 'declareExportTrueByPragma'
			with: 'methodName'.
	self assert: m = p.

	m := (SlangTestSupportInterpreter asCString: #declareExportFalseByMethod)
			copyReplaceAll: 'declareExportFalseByMethod'
			with: 'methodName'.
	p := (SlangTestSupportInterpreter asCString: #declareExportFalseByPragma)
			copyReplaceAll: 'declareExportFalseByPragma'
			with: 'methodName'.
	self assert: m = p.! !
!SlangTest methodsFor: 'testing interpreter' stamp: 'dtl 9/18/2010 18:08'!
testInterpDeclareInline
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := ((SlangTestSupportInterpreter asInlinedCString: #inlineByMethod)
			copyReplaceAll: 'inlineByMethod'
			with: 'methodName')
				copyReplaceAll: 'methodThatShouldNotBeInlinedByMethod'
				with: 'calledMethodName'.
	p := ((SlangTestSupportInterpreter asInlinedCString: #inlineByPragma)
			copyReplaceAll: 'inlineByPragma'
			with: 'methodName')
				copyReplaceAll: 'methodThatShouldNotBeInlinedByPragma'
				with: 'calledMethodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing interpreter' stamp: 'dtl 9/19/2010 21:23'!
testInterpDeclareStatic

	| m1 p1 m2 p2 |
	m1 := (SlangTestSupportInterpreter asCString: #declareStaticTrueByMethod)
			copyReplaceAll: 'declareStaticTrueByMethod'
			with: 'methodName'.
	p1 := (SlangTestSupportInterpreter asCString: #declareStaticTrueByPragma)
			copyReplaceAll: 'declareStaticTrueByPragma'
			with: 'methodName'.
	self assert: m1 = p1.

	m2 := (SlangTestSupportInterpreter asCString: #declareStaticFalseByMethod)
			copyReplaceAll: 'declareStaticFalseByMethod'
			with: 'methodName'.
	p2 := (SlangTestSupportInterpreter asCString: #declareStaticFalseByPragma)
			copyReplaceAll: 'declareStaticFalseByPragma'
			with: 'methodName'.
	self assert: m2 = p2.

	"verify that the keyword 'static appears in the generated C source"
	self assert: (m1 includesSubString: 'static').
	self assert: (p1 includesSubString: 'static').
	self deny: (m2 includesSubString: 'static').
	self deny: (p2 includesSubString: 'static')
! !
!SlangTest methodsFor: 'testing interpreter' stamp: 'dtl 9/19/2010 22:26'!
testInterpMixedMethodAndPragmaDeclarations
	"Pragmas and method declarations should coexist"

	| s |
	s := (SlangTestSupportInterpreter asCString: #varDefByMethodAndPragma)
			copyReplaceAll: 'varDefByMethod'
			with: 'methodName'.
	self assert: (s includesSubString: 'unsigned int * bar').
	self assert: (s includesSubString: 'char *foo').
	self assert: (s includesSubString: 'float baz').
	self assert: (s includesSubString: 'double fum').
! !
!SlangTest methodsFor: 'testing interpreter' stamp: 'dtl 9/18/2010 17:36'!
testInterpReturnTypeC
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportInterpreter asCString: #returnTypeByMethod)
			copyReplaceAll: 'returnTypeByMethod'
			with: 'methodName'.
	p := (SlangTestSupportInterpreter asCString: #returnTypeByPragma)
			copyReplaceAll: 'returnTypeByPragma'
			with: 'methodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing interpreter' stamp: 'dtl 9/18/2010 17:37'!
testInterpTypeDeclarations
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportInterpreter asCString: #varDefByMethod)
			copyReplaceAll: 'varDefByMethod'
			with: 'methodName'.
	p := (SlangTestSupportInterpreter asCString: #varDefByPragma)
			copyReplaceAll: 'varDefByPragma'
			with: 'methodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing base plugins' stamp: 'dtl 9/19/2010 21:28'!
testPluginDeclareExport
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportPlugin asCString: #declareExportTrueByMethod)
			copyReplaceAll: 'declareExportTrueByMethod'
			with: 'methodName'.
	p := (SlangTestSupportPlugin asCString: #declareExportTrueByPragma)
			copyReplaceAll: 'declareExportTrueByPragma'
			with: 'methodName'.
	self assert: m = p.

	m := (SlangTestSupportPlugin asCString: #declareExportFalseByMethod)
			copyReplaceAll: 'declareExportFalseByMethod'
			with: 'methodName'.
	p := (SlangTestSupportPlugin asCString: #declareExportFalseByPragma)
			copyReplaceAll: 'declareExportFalseByPragma'
			with: 'methodName'.
	self assert: m = p.! !
!SlangTest methodsFor: 'testing base plugins' stamp: 'dtl 9/19/2010 21:27'!
testPluginDeclareInline
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := ((SlangTestSupportPlugin asInlinedCString: #inlineByMethod)
			copyReplaceAll: 'inlineByMethod'
			with: 'methodName')
				copyReplaceAll: 'methodThatShouldNotBeInlinedByMethod'
				with: 'calledMethodName'.
	p := ((SlangTestSupportPlugin asInlinedCString: #inlineByPragma)
			copyReplaceAll: 'inlineByPragma'
			with: 'methodName')
				copyReplaceAll: 'methodThatShouldNotBeInlinedByPragma'
				with: 'calledMethodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing base plugins' stamp: 'dtl 9/19/2010 21:27'!
testPluginDeclareStatic

	| m1 p1 m2 p2 |
	m1 := (SlangTestSupportPlugin asCString: #declareStaticTrueByMethod)
			copyReplaceAll: 'declareStaticTrueByMethod'
			with: 'methodName'.
	p1 := (SlangTestSupportPlugin asCString: #declareStaticTrueByPragma)
			copyReplaceAll: 'declareStaticTrueByPragma'
			with: 'methodName'.
	self assert: m1 = p1.

	m2 := (SlangTestSupportPlugin asCString: #declareStaticFalseByMethod)
			copyReplaceAll: 'declareStaticFalseByMethod'
			with: 'methodName'.
	p2 := (SlangTestSupportPlugin asCString: #declareStaticFalseByPragma)
			copyReplaceAll: 'declareStaticFalseByPragma'
			with: 'methodName'.
	self assert: m2 = p2.

	"verify that the keyword 'static appears in the generated C source"
	self assert: (m1 includesSubString: 'static').
	self assert: (p1 includesSubString: 'static').
	self deny: (m2 includesSubString: 'static').
	self deny: (p2 includesSubString: 'static')
! !
!SlangTest methodsFor: 'testing base plugins' stamp: 'dtl 9/19/2010 21:27'!
testPluginMixedMethodAndPragmaDeclarations
	"Pragmas and method declarations should coexist"

	| s |
	s := (SlangTestSupportPlugin asCString: #varDefByMethodAndPragma)
			copyReplaceAll: 'varDefByMethod'
			with: 'methodName'.
	self assert: (s includesSubString: 'unsigned int * bar').
	self assert: (s includesSubString: 'char *foo').
	self assert: (s includesSubString: 'float baz').
	self assert: (s includesSubString: 'double fum').
! !
!SlangTest methodsFor: 'testing base plugins' stamp: 'dtl 9/19/2010 21:28'!
testPluginReturnTypeC
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportPlugin asCString: #returnTypeByMethod)
			copyReplaceAll: 'returnTypeByMethod'
			with: 'methodName'.
	p := (SlangTestSupportPlugin asCString: #returnTypeByPragma)
			copyReplaceAll: 'returnTypeByPragma'
			with: 'methodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing base plugins' stamp: 'dtl 9/19/2010 21:28'!
testPluginTypeDeclarations
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportPlugin asCString: #varDefByMethod)
			copyReplaceAll: 'varDefByMethod'
			with: 'methodName'.
	p := (SlangTestSupportPlugin asCString: #varDefByPragma)
			copyReplaceAll: 'varDefByPragma'
			with: 'methodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing ssip plugins' stamp: 'dtl 9/18/2010 17:42'!
testSSIPDeclareExport
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportSSIP asCString: #declareExportTrueByMethod)
			copyReplaceAll: 'declareExportTrueByMethod'
			with: 'methodName'.
	p := (SlangTestSupportSSIP asCString: #declareExportTrueByPragma)
			copyReplaceAll: 'declareExportTrueByPragma'
			with: 'methodName'.
	self assert: m = p.

	m := (SlangTestSupportSSIP asCString: #declareExportFalseByMethod)
			copyReplaceAll: 'declareExportFalseByMethod'
			with: 'methodName'.
	p := (SlangTestSupportSSIP asCString: #declareExportFalseByPragma)
			copyReplaceAll: 'declareExportFalseByPragma'
			with: 'methodName'.
	self assert: m = p.! !
!SlangTest methodsFor: 'testing ssip plugins' stamp: 'dtl 9/18/2010 18:08'!
testSSIPDeclareInline
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := ((SlangTestSupportSSIP asInlinedCString: #inlineByMethod)
			copyReplaceAll: 'inlineByMethod'
			with: 'methodName')
				copyReplaceAll: 'methodThatShouldNotBeInlinedByMethod'
				with: 'calledMethodName'.
	p := ((SlangTestSupportSSIP asInlinedCString: #inlineByPragma)
			copyReplaceAll: 'inlineByPragma'
			with: 'methodName')
				copyReplaceAll: 'methodThatShouldNotBeInlinedByPragma'
				with: 'calledMethodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing ssip plugins' stamp: 'dtl 9/19/2010 21:23'!
testSSIPDeclareStatic

	| m1 p1 m2 p2 |
	m1 := (SlangTestSupportSSIP asCString: #declareStaticTrueByMethod)
			copyReplaceAll: 'declareStaticTrueByMethod'
			with: 'methodName'.
	p1 := (SlangTestSupportSSIP asCString: #declareStaticTrueByPragma)
			copyReplaceAll: 'declareStaticTrueByPragma'
			with: 'methodName'.
	self assert: m1 = p1.

	m2 := (SlangTestSupportSSIP asCString: #declareStaticFalseByMethod)
			copyReplaceAll: 'declareStaticFalseByMethod'
			with: 'methodName'.
	p2 := (SlangTestSupportSSIP asCString: #declareStaticFalseByPragma)
			copyReplaceAll: 'declareStaticFalseByPragma'
			with: 'methodName'.
	self assert: m2 = p2.

	"verify that the keyword 'static appears in the generated C source"
	self assert: (m1 includesSubString: 'static').
	self assert: (p1 includesSubString: 'static').
	self deny: (m2 includesSubString: 'static').
	self deny: (p2 includesSubString: 'static')
! !
!SlangTest methodsFor: 'testing ssip plugins' stamp: 'dtl 9/19/2010 22:20'!
testSSIPMixedMethodAndPragmaDeclarations
	"Pragmas and method declarations should coexist"

	| s |
	s := (SlangTestSupportSSIP asCString: #varDefByMethodAndPragma)
			copyReplaceAll: 'varDefByMethod'
			with: 'methodName'.
	self assert: (s includesSubString: 'unsigned int * bar').
	self assert: (s includesSubString: 'char *foo').
	self assert: (s includesSubString: 'float baz').
	self assert: (s includesSubString: 'double fum').
! !
!SlangTest methodsFor: 'testing ssip plugins' stamp: 'dtl 9/18/2010 17:36'!
testSSIPReturnTypeC
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportSSIP asCString: #returnTypeByMethod)
			copyReplaceAll: 'returnTypeByMethod'
			with: 'methodName'.
	p := (SlangTestSupportSSIP asCString: #returnTypeByPragma)
			copyReplaceAll: 'returnTypeByPragma'
			with: 'methodName'.
	self assert: m = p! !
!SlangTest methodsFor: 'testing ssip plugins' stamp: 'dtl 9/18/2010 17:37'!
testSSIPTypeDeclarations
	"Pragma declarations should generate the same C source code as the
	traditional method send declarations"

	| m p |
	m := (SlangTestSupportSSIP asCString: #varDefByMethod)
			copyReplaceAll: 'varDefByMethod'
			with: 'methodName'.
	p := (SlangTestSupportSSIP asCString: #varDefByPragma)
			copyReplaceAll: 'varDefByPragma'
			with: 'methodName'.
	self assert: m = p! !
!BlockNode methodsFor: '*VMMaker-C translation' stamp: 'eem 10/2/2009 11:26'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"
	| statementList |
	statementList := OrderedCollection new.
	statements
		do: [:s | | newS | 
			newS := s asTranslatorNodeIn: aTMethod.
			newS isStmtList
				ifTrue: ["inline the statement list returned when a CascadeNode is 
					translated "
					statementList addAll: newS statements]
				ifFalse: [statementList add: newS]].
	^ TStmtListNode new
		setArguments: (arguments asArray
				collect: [:arg | arg key])
		statements: statementList;
		 comment: comment! !
!LiteralNode methodsFor: '*VMMaker-C translation' stamp: 'eem 10/2/2009 11:26'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"

	^TConstantNode new setValue: key! !

InterpreterPlugin subclass: #KlattSynthesizerPlugin
	instanceVariableNames: 'resonators frame pitch t0 nper nopen nmod a1 a2 x1 x2 b1 c1 glast vlast nlast periodCount samplesCount seed cascade samplesPerFrame samplingRate'
	classVariableNames: 'A1v A2f A2v A3f A3v A4f A4v A5f A6f Anv Aspiration Atv B1 B2 B2f B3 B3f B4 B4f B5 B5f B6 B6f Bnp Bnz Btp Btz Bypass Db1 Df1 Diplophonia Epsilon F0 F1 F2 F3 F4 F5 F6 Flutter Fnp Fnz Friction Ftp Ftz Gain Jitter PI Ra Rk Ro Shimmer Turbulence Voicing'
	poolDictionaries: 'KlattResonatorIndices'
	category: 'VMMaker-Plugins'!
!KlattSynthesizerPlugin commentStamp: '<historical>' prior: 0!
This is a pluggable primitive implementation of the KlattSynthesizer.!
!KlattSynthesizerPlugin class methodsFor: 'translation' stamp: 'eem 3/5/2009 13:18'!
declareCVarsIn: cg 
	cg var: #resonators type: #'float *'.
	cg var: #frame type: #'float *'.
	cg var: #pitch type: #float.
	cg var: #a1 type: #float.
	cg var: #a2 type: #float.
	cg var: #x1 type: #float.
	cg var: #x2 type: #float.
	cg var: #b1 type: #float.
	cg var: #c1 type: #float.
	cg var: #glast type: #float.
	cg var: #vlast type: #float.
	cg var: #nlast type: #float! !
!KlattSynthesizerPlugin class methodsFor: 'class initialization' stamp: 'dtl 11/15/2009 10:44'!
initialize
	"
	KlattSynthesizerPlugin initialize
	"
	| parameterClass |
	parameterClass := (Smalltalk hasClassNamed: #KlattFrame)
		ifTrue: [Smalltalk at: #KlattFrame "original package structure"]
		ifFalse: [Smalltalk at: #KlattResonatorIndices "repackaged to separate plugin from Speech dependency"].
	
	parameterClass parameterNames
		doWithIndex: [ :each :i | self classPool at: each capitalized asSymbol put: i-1].
	PI := Float pi	.
	Epsilon := 1.0e-04! !
!KlattSynthesizerPlugin class methodsFor: 'translation' stamp: 'len 9/25/1999 23:14'!
moduleName
	"
	KlattSynthesizerPlugin translateDoInlining: true
	"
	^ 'Klatt'! !
!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len (auto pragmas 12/08) 12/17/1999 03:16'!
addAmplitudeDiplophonia
	"Add diplophonia (bicyclic voice). Change voicing amplitude."
	<returnTypeC: 'void'>
	periodCount \\ 2 = 0
		ifFalse: [x1 := x1 * (1.0 - (frame at: Diplophonia)).
				"x1 must be <= 0"
				x1 > 0 ifTrue: [x1 := 0]]! !
!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:49'!
addFlutter
	"Add F0 flutter, as specified in:
		'Analysis, synthesis and perception of voice quality variations among
		female and male talkers' D.H. Klatt and L.C. Klatt JASA 87(2) February 1990.
	Flutter is added by applying a quasi-random element constructed from three
	slowly varying sine waves."
	| timeCount asin bsin csin deltaF0 |
	<returnTypeC: 'void'>
	<var: 'timeCount' type: 'float '>
	<var: 'asin' type: 'float '>
	<var: 'bsin' type: 'float '>
	<var: 'csin' type: 'float '>
	<var: 'deltaF0' type: 'double '>
	timeCount := (self cCoerce: samplesCount to: 'float') / (self cCoerce: samplingRate to: 'float').
	asin := (2.0 * PI * 12.7 * timeCount) sin.
	bsin := (2.0 * PI * 7.1 * timeCount) sin.
	csin := (2.0 * PI * 4.7 * timeCount) sin.
	deltaF0 := (frame at: Flutter) * 2.0 * (frame at: F0) / 100.0 * (asin + bsin + csin).
	pitch := pitch + deltaF0! !
!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len (auto pragmas 12/08) 12/17/1999 03:11'!
addFrequencyDiplophonia
	"Add diplophonia (bicyclic voice). Change F0."
	<returnTypeC: 'void'>
	periodCount \\ 2 = 0
		ifTrue: [pitch := pitch + ((frame at: Diplophonia) * (frame at: F0) * (1.0 - (frame at: Ro)))]
		ifFalse: [pitch := pitch - ((frame at: Diplophonia) * (frame at: F0) * (1.0 - (frame at: Ro)))]! !
!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len (auto pragmas 12/08) 11/22/1999 02:44'!
addJitter
	"Add jitter (random F0 perturbation)."
	<returnTypeC: 'void'>
	pitch := pitch + (self nextRandom - 32767 * (frame at: Jitter) / 32768.0 * (frame at: F0))! !
!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len (auto pragmas 12/08) 11/22/1999 02:45'!
addShimmer
	"Add shimmer (random voicing amplitude perturbation)."
	<returnTypeC: 'void'>
	x1 := x1 + (self nextRandom - 32767 * (frame at: Shimmer) / 32768.0 * x1).
	"x1 must be <= 0"
	x1 > 0 ifTrue: [x1 := 0]! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:50'!
antiResonator: index frequency: freq bandwidth: bw
	"Set up an anti-resonator"
	| arg r a b c |
	<returnTypeC: 'void'>
	<var: 'freq' type: 'float '>
	<var: 'bw' type: 'float '>
	<var: 'arg' type: 'double '>
	<var: 'a' type: 'float '>
	<var: 'b' type: 'float '>
	<var: 'c' type: 'float '>
	<var: 'r' type: 'float '>
	arg := 0.0 - PI / samplingRate * bw.
	r := arg exp.
	c := 0.0 - (r * r).
	arg := PI * 2.0 / samplingRate * freq.
	b := r * arg cos * 2.0.
	a := 1.0 - b - c.
	a := 1.0 / a.
	b := 0.0 - b * a.
	c := 0.0 - c * a.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:50'!
antiResonator: index value: aFloat
	| answer p1 |
	<inline: true>
	<returnTypeC: 'float'>
	<var: 'aFloat' type: 'double '>
	<var: 'answer' type: 'double '>
	<var: 'p1' type: 'double '>
	answer := (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 := self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	self resonatorP2: index put: p1.
	self resonatorP1: index put: aFloat.
	^ answer! !
!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:50'!
cascadeBranch: source
	"Cascade vocal tract, excited by laryngeal sources.
	Nasal antiresonator, nasal resonator, tracheal antirresonator,
	tracheal resonator, then formants F8, F7, F6, F5, F4, F3, F2, F1."
	| out |
	<inline: true>
	<returnTypeC: 'float'>
	<var: 'source' type: 'float '>
	<var: 'out' type: 'float '>
	cascade > 0 ifFalse: [^ 0.0].
	out := self antiResonator: Rnz value: source.
	out := self resonator: Rnpc value: out.
	out := self antiResonator: Rtz value: out.
	out := self resonator: Rtpc value: out.
	"Do not use unless sample rate >= 16000"
	cascade >= 8 ifTrue: [out := self resonator: R8c value: out].
	"Do not use unless sample rate >= 16000"
	cascade >= 7 ifTrue: [out := self resonator: R7c value: out].
	"Do not use unless long vocal tract or sample rate increased"
	cascade >= 6 ifTrue: [out := self resonator: R6c value: out].
	cascade >= 5 ifTrue: [out := self resonator: R5c value: out].
	cascade >= 4 ifTrue: [out := self resonator: R4c value: out].
	cascade >= 3 ifTrue: [out := self resonator: R3c value: out].
	cascade >= 2 ifTrue: [out := self resonator: R2c value: out].
	cascade >= 1 ifTrue: [out := self resonator: R1c value: out].
	^ out! !
!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'hmm (auto pragmas dtl 2010-09-28) 5/10/1999 06:49'!
checkedFloatPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	<returnTypeC: 'float *'>
	interpreterProxy success: (interpreterProxy isWords: oop).
	interpreterProxy failed ifTrue:[^0].
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to:'float *'! !
!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'hmm (auto pragmas dtl 2010-09-28) 5/10/1999 06:50'!
checkedShortPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	<returnTypeC: 'short *'>
	interpreterProxy success: (interpreterProxy isWords: oop).
	interpreterProxy failed ifTrue:[^0].
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to:'short *'! !
!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:50'!
glottalSource
	| x0 |
	<inline: true>
	<returnTypeC: 'float'>
	<var: 'x0' type: 'float '>
	t0 = 0 ifTrue: [^ 0].
	nper < nopen
		ifTrue: [x0 := a1 * x1 + (a2 * x2).
				x2 := x1.
				x1 := x0]
		ifFalse: [x0 := b1 * x1 - c1.
				x1 := x0].
	"Reset period when 'nper' reaches t0."
	nper >= t0 ifTrue: [nper := 0. self pitchSynchronousReset].
	nper := nper + 1.
	^ x0! !
!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:50'!
linearFromdB: aNumber
	<inline: true>
	<returnTypeC: 'float'>
	<var: 'aNumber' type: 'double '>
	^ (2.0 raisedTo: (aNumber-87.0/6.0)) * 32.767! !
!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'len 12/17/1999 03:27'!
loadFrom: klattOop
	| oop |
	interpreterProxy success: (interpreterProxy slotSizeOf: klattOop) = 22.
	interpreterProxy failed ifTrue:[^ false].

	oop := interpreterProxy fetchPointer: 0 ofObject: klattOop.
	resonators := self checkedFloatPtrOf: oop.

	pitch := interpreterProxy fetchFloat: 2 ofObject: klattOop.
	t0 := interpreterProxy fetchInteger: 3 ofObject: klattOop.
	nper := interpreterProxy fetchInteger: 4 ofObject: klattOop.
	nopen := interpreterProxy fetchInteger: 5 ofObject: klattOop.
	nmod := interpreterProxy fetchInteger: 6 ofObject: klattOop.
	a1 := interpreterProxy fetchFloat: 7 ofObject: klattOop.
	a2 := interpreterProxy fetchFloat: 8 ofObject: klattOop.
	x1 := interpreterProxy fetchFloat: 9 ofObject: klattOop.
	x2 := interpreterProxy fetchFloat: 10 ofObject: klattOop.
	b1 := interpreterProxy fetchFloat: 11 ofObject: klattOop.
	c1 := interpreterProxy fetchFloat: 12 ofObject: klattOop.
	glast := interpreterProxy fetchFloat: 13 ofObject: klattOop.
	vlast := interpreterProxy fetchFloat: 14 ofObject: klattOop.
	nlast := interpreterProxy fetchFloat: 15 ofObject: klattOop.
	periodCount := interpreterProxy fetchInteger: 16 ofObject: klattOop.
	samplesCount := interpreterProxy fetchInteger: 17 ofObject: klattOop.
	seed := interpreterProxy fetchInteger: 18 ofObject: klattOop.
	cascade := interpreterProxy fetchInteger: 19 ofObject: klattOop.
	samplesPerFrame := interpreterProxy fetchInteger: 20 ofObject: klattOop.
	samplingRate := interpreterProxy fetchInteger: 21 ofObject: klattOop.

	^ interpreterProxy failed == false! !
!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len (auto pragmas 12/08) 11/9/1999 22:40'!
nextRandom
	"Answer a random number between 0 and 65535."
	<inline: true>
	seed := (seed * 1309) + 13849 bitAnd: 65535.
	^ seed! !
!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:51'!
normalizeGlottalPulse
	| s1 s2 s0 |
	<inline: true>
	<returnTypeC: 'void'>
	<var: 's0' type: 'float '>
	<var: 's1' type: 'float '>
	<var: 's2' type: 'float '>
	s0 := 0.0.
	s1 := x1.
	s2 := x2.
	1 to: nopen do: [ :ingore |
		s0 := a1 * s1 + (a2 * s2).
		s2 := s1.
		s1 := s0].
	s0 = 0.0 ifFalse: [x1 := x1 / s0 * 10000.0]! !
!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:51'!
parallelFrictionBranch: source
	"Friction-excited parallel vocal tract formants F6, F5, F4, F3, F2,
	outputs added with alternating sign. Sound source for other
	parallel resonators is friction plus first difference of
	voicing waveform."
	<inline: true>
	<returnTypeC: 'float'>
	<var: 'source' type: 'float '>
	^ (self resonator: R2fp value: source) - (self resonator: R3fp value: source) + (self resonator: R4fp value: source) - (self resonator: R5fp value: source) + (self resonator: R6fp value: source)! !
!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:51'!
parallelVoicedBranch: source
	"Voice-excited parallel vocal tract F1, F2, F3, F4, FNP and FTP."
	<inline: true>
	<returnTypeC: 'float'>
	<var: 'source' type: 'float '>
	^ (self resonator: R1vp value: source) + (self resonator: R2vp value: source) + (self resonator: R3vp value: source) + (self resonator: R4vp value: source) + (self resonator: Rnpp value: source) + (self resonator: Rtpp value: source)! !
!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len (auto pragmas 12/08) 12/21/1999 02:24'!
pitchSynchronousReset
	<returnTypeC: 'void'>
	(frame at: F0) > 0
		ifTrue: [self voicedPitchSynchronousReset.
				periodCount := periodCount + 1 \\ 65535]
		ifFalse: [t0 := 1.
				nmod := t0]! !
!KlattSynthesizerPlugin methodsFor: 'primitives' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:51'!
primitiveSynthesizeFrameIntoStartingAt
	| aKlattFrame buffer startIndex rcvr bufferOop |
	<export: true>
	<var: 'aKlattFrame' type: 'float *'>
	<var: 'buffer' type: 'short *'>
	aKlattFrame := self checkedFloatPtrOf: (interpreterProxy stackValue: 2).
	buffer := self checkedShortPtrOf: (bufferOop := interpreterProxy stackValue: 1).
	startIndex := interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue: [^nil].
	rcvr := interpreterProxy stackObjectValue: 3.
	(self loadFrom: rcvr) ifFalse:[^nil].
	interpreterProxy success: (interpreterProxy stSizeOf: bufferOop) * 2 >= samplesPerFrame.
	interpreterProxy failed ifTrue: [^nil].
	self synthesizeFrame: aKlattFrame into: buffer startingAt: startIndex.
	(self saveTo: rcvr) ifFalse: [^nil].
	interpreterProxy pop: 3! !
!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:51'!
qu: u phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| expuphi |
	<returnTypeC: 'float'>
	<var: 'u' type: 'float '>
	<var: 'phi' type: 'float '>
	<var: 'cosphi' type: 'float '>
	<var: 'sinphi' type: 'float '>
	<var: 'rphid' type: 'float '>
	<var: 'expuphi' type: 'float '>
	expuphi := (u * phi) exp.
	^ expuphi * ((rphid * (u*u + 1.0) + u) * sinphi - cosphi) + 1.0! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:52'!
resonator: index frequency: freq bandwidth: bw
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	| arg r a b c |
	<returnTypeC: 'void'>
	<var: 'freq' type: 'float '>
	<var: 'bw' type: 'float '>
	<var: 'arg' type: 'double '>
	<var: 'a' type: 'float '>
	<var: 'b' type: 'float '>
	<var: 'c' type: 'float '>
	<var: 'r' type: 'float '>
	arg := 0.0 - PI / samplingRate * bw.
	r := arg exp.
	c := 0.0 - (r * r).
	arg := PI * 2.0 / samplingRate * freq.
	b := r * arg cos * 2.0.
	a := 1.0 - b - c.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:52'!
resonator: index frequency: freq bandwidth: bw gain: gain
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	<returnTypeC: 'void'>
	<var: 'freq' type: 'float '>
	<var: 'bw' type: 'float '>
	<var: 'gain' type: 'float '>
	self resonator: index frequency: freq bandwidth: bw.
	self resonatorA: index put: (self resonatorA: index) * gain! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:53'!
resonator: index value: aFloat
	| answer p1 |
	<inline: true>
	<returnTypeC: 'float'>
	<var: 'aFloat' type: 'float '>
	<var: 'answer' type: 'float '>
	<var: 'p1' type: 'float '>
	answer := (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 := self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	"(p1 between: -100000 and: 100000) ifFalse: [self halt].
	(answer between: -100000 and: 100000) ifFalse: [self halt]."
	self resonatorP2: index put: p1.
	self resonatorP1: index put: answer.
	^ answer! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len (auto pragmas 12/08) 9/6/1999 00:16'!
resonatorA: index
	<inline: true>
	<returnTypeC: 'float'>
	^resonators at: index*5-5! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:51'!
resonatorA: index put: aFloat
	<inline: true>
	<returnTypeC: 'void'>
	<var: 'aFloat' type: 'float '>
	resonators at: index*5-5 put: aFloat! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len (auto pragmas 12/08) 9/6/1999 00:16'!
resonatorB: index
	<inline: true>
	<returnTypeC: 'float'>
	^resonators at: index*5-4! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:52'!
resonatorB: index put: aFloat
	<inline: true>
	<returnTypeC: 'void'>
	<var: 'aFloat' type: 'float '>
	resonators at: index*5-4 put: aFloat! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len (auto pragmas 12/08) 9/6/1999 00:16'!
resonatorC: index
	<inline: true>
	<returnTypeC: 'float'>
	^resonators at: index*5-3! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:52'!
resonatorC: index put: aFloat
	<inline: true>
	<returnTypeC: 'void'>
	<var: 'aFloat' type: 'float '>
	resonators at: index*5-3 put: aFloat! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len (auto pragmas 12/08) 9/6/1999 00:16'!
resonatorP1: index
	<inline: true>
	<returnTypeC: 'float'>
	^resonators at: index*5-2! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:52'!
resonatorP1: index put: aFloat
	<inline: true>
	<returnTypeC: 'void'>
	<var: 'aFloat' type: 'float '>
	resonators at: index*5-2 put: aFloat! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len (auto pragmas 12/08) 9/6/1999 00:16'!
resonatorP2: index
	<inline: true>
	<returnTypeC: 'float'>
	^resonators at: index*5-1! !
!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:52'!
resonatorP2: index put: aFloat
	<inline: true>
	<returnTypeC: 'void'>
	<var: 'aFloat' type: 'float '>
	resonators at: index*5-1 put: aFloat! !
!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:53'!
ro: roNumber ra: raNumber rk: rkNumber
	| r d phi cosphi sinphi rphid u theta rho gamma gammapwr te ro ra rk |

	<returnTypeC: 'void'>
	<var: 'roNumber' type: 'float '>
	<var: 'raNumber' type: 'float '>
	<var: 'rkNumber' type: 'float '>
	<var: 'r' type: 'float '>
	<var: 'd' type: 'float '>
	<var: 'phi' type: 'float '>
	<var: 'cosphi' type: 'float '>
	<var: 'sinphi' type: 'float '>
	<var: 'rphid' type: 'float '>
	<var: 'u' type: 'float '>
	<var: 'theta' type: 'float '>
	<var: 'rho' type: 'float '>
	<var: 'gamma' type: 'float '>
	<var: 'gammapwr' type: 'float '>
	<var: 'ro' type: 'float '>
	<var: 'ra' type: 'float '>
	<var: 'rk' type: 'float '>

	te := (t0 * roNumber) asInteger.
	ro := te asFloat / t0 asFloat.
	rk := rkNumber.
	ra := raNumber.

	ra <= 0.0
		ifTrue: [d := 1.0]
		ifFalse: [r := 1.0 - ro / ra.
				d := 1.0 - (r / (r exp - 1.0))].

	phi := PI * (rk + 1.0).
	cosphi := phi cos.
	sinphi := phi sin.
	rphid := ra / ro * phi * d.

	u := self zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
	theta := phi / te.
	rho := (u * theta) exp.
	a1 := 2.0 * theta cos * rho.
	a2 := 0.0 - (rho * rho).
	x2 := 0.0.
	x1 := rho * theta sin.

	gamma := (-1.0 / (ra * t0)) exp.
	gammapwr := gamma raisedTo: t0 - te.

	b1 := gamma.
	c1 := (1.0 - gamma) * gammapwr / (1.0 - gammapwr).

	self normalizeGlottalPulse! !
!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'len 12/19/1999 05:25'!
saveTo: origKlattOop
	| pitchOop a1Oop a2Oop x1Oop x2Oop b1Oop c1Oop glastOop vlastOop nlastOop klattOop |
	interpreterProxy pushRemappableOop: origKlattOop.
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: pitch).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: a1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: a2).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: x1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: x2).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: b1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: c1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: glast).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: vlast).
	nlastOop := interpreterProxy floatObjectOf: nlast.
	vlastOop := interpreterProxy popRemappableOop.
	glastOop := interpreterProxy popRemappableOop.
	c1Oop := interpreterProxy popRemappableOop.
	b1Oop := interpreterProxy popRemappableOop.
	x2Oop := interpreterProxy popRemappableOop.
	x1Oop := interpreterProxy popRemappableOop.
	a2Oop := interpreterProxy popRemappableOop.
	a1Oop := interpreterProxy popRemappableOop.
	pitchOop := interpreterProxy popRemappableOop.
	klattOop := interpreterProxy popRemappableOop.
	interpreterProxy failed ifTrue:[^ false].

	interpreterProxy storePointer: 2 ofObject: klattOop withValue: pitchOop.
	interpreterProxy storeInteger: 3 ofObject: klattOop withValue: t0.
	interpreterProxy storeInteger: 4 ofObject: klattOop withValue: nper.
	interpreterProxy storeInteger: 5 ofObject: klattOop withValue: nopen.
	interpreterProxy storeInteger: 6 ofObject: klattOop withValue: nmod.
	interpreterProxy storePointer: 7 ofObject: klattOop withValue: a1Oop.
	interpreterProxy storePointer: 8 ofObject: klattOop withValue: a2Oop.
	interpreterProxy storePointer: 9 ofObject: klattOop withValue: x1Oop.
	interpreterProxy storePointer: 10 ofObject: klattOop withValue: x2Oop.
	interpreterProxy storePointer: 11 ofObject: klattOop withValue: b1Oop.
	interpreterProxy storePointer: 12 ofObject: klattOop withValue: c1Oop.
	interpreterProxy storePointer: 13 ofObject: klattOop withValue: glastOop.
	interpreterProxy storePointer: 14 ofObject: klattOop withValue: vlastOop.
	interpreterProxy storePointer: 15 ofObject: klattOop withValue: nlastOop.
	interpreterProxy storeInteger: 16 ofObject: klattOop withValue: periodCount.
	interpreterProxy storeInteger: 17 ofObject: klattOop withValue: samplesCount.
	interpreterProxy storeInteger: 18 ofObject: klattOop withValue: seed.

	^ interpreterProxy failed == false! !
!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:54'!
setCurrentFrame: aKlattFrame
	| ampFNV ampFTV ampF1V ampF2V ampF3V ampF4V ampF2F ampF3F ampF4F ampF5F ampF6F |
	<returnTypeC: 'void'>
	<var: 'aKlattFrame' type: 'float *'>
	<var: 'ampFNV' type: 'float '>
	<var: 'ampFTV' type: 'float '>
	<var: 'ampF1V' type: 'float '>
	<var: 'ampF2V' type: 'float '>
	<var: 'ampF3V' type: 'float '>
	<var: 'ampF4V' type: 'float '>
	<var: 'ampF2F' type: 'float '>
	<var: 'ampF3F' type: 'float '>
	<var: 'ampF4F' type: 'float '>
	<var: 'ampF5F' type: 'float '>
	<var: 'ampF6F' type: 'float '>

	frame := aKlattFrame.

	"Fudge factors..."
	ampFNV := (self linearFromdB: (frame at: Anv)) * 0.6.	"-4.44 dB"
	ampFTV := (self linearFromdB: (frame at: Atv)) * 0.6.		"-4.44 dB"
	ampF1V := (self linearFromdB: (frame at: A1v)) * 0.4.		"-7.96 dB"
	ampF2V := (self linearFromdB: (frame at: A2v)) * 0.15.	"-16.5 dB"
	ampF3V := (self linearFromdB: (frame at: A3v)) * 0.06.	"-24.4 dB"
	ampF4V := (self linearFromdB: (frame at: A4v)) * 0.04.	"-28.0 dB"
	ampF2F := (self linearFromdB: (frame at: A2f)) * 0.15.		"-16.5 dB"
	ampF3F := (self linearFromdB: (frame at: A3f)) * 0.06.	"-24.4 dB"
	ampF4F := (self linearFromdB: (frame at: A4f)) * 0.04.	"-28.0 dB"
	ampF5F := (self linearFromdB: (frame at: A5f)) * 0.022.	"-33.2 dB"
	ampF6F := (self linearFromdB: (frame at: A6f)) * 0.03.	"-30.5 dB"

	"Set coefficients of variable cascade resonators"
	cascade >= 8
		ifTrue: [samplingRate >= 16000	"Inside Nyquist rate?"
					ifTrue: [self resonator: R8c frequency: 7500 bandwidth: 600]
					ifFalse: [cascade := 6]].
	cascade >= 7
		ifTrue: [samplingRate >= 16000	"Inside Nyquist rate?"
					ifTrue: [self resonator: R7c frequency: 6500 bandwidth: 500]
					ifFalse: [cascade := 6]].
	cascade >= 6 ifTrue: [self resonator: R6c frequency: (frame at: F6) bandwidth: (frame at: B6)].
	cascade >= 5 ifTrue: [self resonator: R5c frequency: (frame at: F5) bandwidth: (frame at: B5)].
	self resonator: R4c frequency: (frame at: F4) bandwidth: (frame at: B4).
	self resonator: R3c frequency: (frame at: F3) bandwidth: (frame at: B3).
	self resonator: R2c frequency: (frame at: F2) bandwidth: (frame at: B2).
	self resonator: R1c frequency: (frame at: F1) bandwidth: (frame at: B1).

	"Set coefficients of nasal and tracheal resonators and antiresonators"
	self resonator: Rnpc frequency: (frame at: Fnp) bandwidth: (frame at: Bnp).
	self resonator: Rtpc frequency: (frame at: Ftp) bandwidth: (frame at: Btp).
	self antiResonator: Rnz frequency: (frame at: Fnz) bandwidth: (frame at: Bnz).
	self antiResonator: Rtz frequency: (frame at: Ftz) bandwidth: (frame at: Btz).

	"Set coefficients of parallel resonators, and amplitude of outputs"
	self resonator: Rnpp frequency: (frame at: Fnp) bandwidth: (frame at: Bnp) gain: ampFNV.
	self resonator: Rtpp frequency: (frame at: Ftp) bandwidth: (frame at: Btp) gain: ampFTV.
	self resonator: R1vp frequency: (frame at: F1) bandwidth: (frame at: B1) gain: ampF1V.
	self resonator: R2vp frequency: (frame at: F2) bandwidth: (frame at: B2) gain: ampF2V.
	self resonator: R3vp frequency: (frame at: F3) bandwidth: (frame at: B3) gain: ampF3V.
	self resonator: R4vp frequency: (frame at: F4) bandwidth: (frame at: B4) gain: ampF4V.
	self resonator: R2fp frequency: (frame at: F2) bandwidth: (frame at: B2f) gain: ampF2F.
	self resonator: R3fp frequency: (frame at: F3) bandwidth: (frame at: B3f) gain: ampF3F.
	self resonator: R4fp frequency: (frame at: F4) bandwidth: (frame at: B4f) gain: ampF4F.
	self resonator: R5fp frequency: (frame at: F5) bandwidth: (frame at: B5f) gain: ampF5F.
	self resonator: R6fp frequency: (frame at: F6) bandwidth: (frame at: B6f) gain: ampF6F! !
!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:54'!
synthesizeFrame: aKlattFrame into: buffer startingAt: startIndex
	| noise voice frictionNoise aspirationNoise glotout
	parGlotout source temp out
	index top
	voicing parVoicing turbulence friction aspiration bypass
	gain ampGain |

	<returnTypeC: 'void'>
	<var: 'aKlattFrame' type: 'float *'>
	<var: 'buffer' type: 'short *'>
	<var: 'noise' type: 'float '>
	<var: 'voice' type: 'float '>
	<var: 'frictionNoise' type: 'float '>
	<var: 'aspirationNoise' type: 'float '>
	<var: 'voicing' type: 'float '>
	<var: 'parVoicing' type: 'float '>
	<var: 'turbulence' type: 'float '>
	<var: 'friction' type: 'float '>
	<var: 'aspiration' type: 'float '>
	<var: 'bypass' type: 'float '>
	<var: 'glotout' type: 'float '>
	<var: 'parGlotout' type: 'float '>
	<var: 'source' type: 'float '>
	<var: 'gain' type: 'float '>
	<var: 'ampGain' type: 'float '>
	<var: 'out' type: 'float '>

	self setCurrentFrame: aKlattFrame.

	pitch > 0
		ifTrue: [voicing := self linearFromdB: (frame at: Voicing) - 7.
				parVoicing := self linearFromdB: (frame at: Voicing).
				turbulence := (self linearFromdB: (frame at: Turbulence)) * 0.1]
		ifFalse: [voicing := parVoicing := turbulence := 0.0].

	friction := (self linearFromdB: (frame at: Friction)) * 0.25.
	aspiration := (self linearFromdB: (frame at: Aspiration)) * 0.05.
	bypass := (self linearFromdB: (frame at: Bypass)) * 0.05.		"-26.0 dB"

	"Flod overall gain into output resonator (low-pass filter)"
	gain := (frame at: Gain) - 3.
	gain <= 0 ifTrue: [gain := 57].
	ampGain := self linearFromdB: gain.
	self resonator: Rout frequency: 0 bandwidth: samplingRate gain: ampGain.

	noise := nlast.
	index := startIndex.
	top := samplesPerFrame + startIndex - 1.
	[index <= top] whileTrue: [
		"Get low-passed random number for aspiration and friction noise"
		noise := (self nextRandom - 32768) asFloat / 4.0. "radom number between -8196.0 and 8196.0"

		"Tilt down noise spectrum by soft low-pass filter having
		 a pole near the origin in the z-plane."
		noise := noise + (0.75 * nlast).
		nlast := noise.

		"Amplitude modulate noise (reduce noise amplitude during second
		 half of glottal period) if voicing  simultaneously present."
		nper > nmod ifTrue: [noise := noise * 0.5].

		"Compute frictation noise"
		frictionNoise := friction * noise.

		"Compute voicing waveform."
		voice := self glottalSource.
		vlast := voice.

		"Add turbulence during glottal open phase.
		 Use random rather than noise because noise is low-passed."
		nper < nopen ifTrue: [voice := voice + (turbulence * (self nextRandom - 32768) asFloat / 4.0)].

		"Set amplitude of voicing."
		glotout := voicing * voice.
		parGlotout := parVoicing * voice.

		"Compute aspiration amplitude and add to voicing source."
		aspirationNoise := aspiration * noise.
		glotout := glotout + aspirationNoise.
		parGlotout := parGlotout + aspirationNoise.

		"Cascade vocal tract, excited by laryngeal sources.
		 Nasal antiresonator, nasal resonator, trachearl antirresonator,
		 tracheal resonator, then formants F8, F7, F6, F5, F4, F3, F2, F1."
		out := self cascadeBranch: glotout.

		"Voice-excited parallel vocal tract F1, F2, F3, F4, FNP and FTP."
		source := parGlotout.	"Source is voicing plus aspiration."
		out := out + (self parallelVoicedBranch: source).

		"Friction-excited parallel vocal tract formants F6, F5, F4, F3, F2,
		 outputs added with alternating sign. Sound source for other
		 parallel resonators is friction plus first difference of
		 voicing waveform."
		source := frictionNoise + parGlotout - glast.
		glast := parGlotout.
		out := (self parallelFrictionBranch: source) - out.

		"Apply bypas and output low-pass filter"
		out := bypass * source - out.
		out := self resonator: Rout value: out.
		temp := (out * ampGain) asInteger.
		temp < -32768 ifTrue: [temp := -32768].
		temp > 32767 ifTrue: [temp := 32767].
		buffer at: index - 1 put: temp.
		index := index + 1.
		samplesCount := samplesCount + 1]! !
!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len (auto pragmas 12/08) 12/19/1999 04:52'!
voicedPitchSynchronousReset
	<returnTypeC: 'void'>

	"Set the pitch."
	pitch := frame at: F0.

	"Add flutter and jitter (F0 perturbations)."
	self addFlutter.
	self addJitter.
	self addFrequencyDiplophonia.
	pitch < 0 ifTrue: [pitch := 0].

	"Recompute t0 (it is the number of samples in one pitch period)."
	t0 := (samplingRate / pitch) asInteger.

	"Duration of period before amplitude modulation."
	nmod := t0.
	(frame at: Voicing) > 0 ifTrue: [nmod := nmod // 2].

	"Set open phase of glottal period."
	nopen := (t0 * (frame at: Ro)) asInteger.

	"Set the LF glottal pulse model parameters."
	self ro: (frame at: Ro) ra: (frame at: Ra) rk: (frame at: Rk).

	"Add shimmer and diplophonia amplitude pertirbations.
	(This must be done AFTER the actual computation of the LF parameters.)"
	self addShimmer.
	self addAmplitudeDiplophonia! !
!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'tpr (auto pragmas 12/08) 12/29/2005 16:55'!
zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| qzero ua ub qa qb uc qc |
	<returnTypeC: 'float'>
	<var: 'qzero' type: 'float '>
	<var: 'ua' type: 'float '>
	<var: 'ub' type: 'float '>
	<var: 'qa' type: 'float '>
	<var: 'qb' type: 'float '>
	<var: 'uc' type: 'float '>
	<var: 'qc' type: 'float '>
	<var: 'phi' type: 'float '>
	<var: 'cosphi' type: 'float '>
	<var: 'sinphi' type: 'float '>
	<var: 'rphid' type: 'float '>

	qzero := self qu: 0 phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.

	qzero > 0
		ifTrue: [ua := 0. ub := 1.
				qa := qzero. qb := self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
				[qb > 0]
					whileTrue: [ua := ub. qa := qb.
								ub := ub * 2. qb := self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]]
		ifFalse: [ua := -1. ub := 0.
				qa := self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid. qb := qzero.
				[qa < 0]
					whileTrue: [ub := ua. qb := qa.
								ua := ua * 2. qa := self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]].
	[ub - ua > Epsilon]
		whileTrue: [uc := ub + ua / 2.0. qc := self qu: uc phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
					qc > 0 ifTrue: [ua := uc. qa := qc] ifFalse: [ub := uc. qb := qc]].
	^ ub + ua / 2.0! !
!AssignmentNode methodsFor: '*VMMaker-C translation' stamp: 'eem 10/2/2009 11:26'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"
	^TAssignmentNode new
		setVariable: (variable asTranslatorNodeIn: aTMethod)
		expression: (value asTranslatorNodeIn: aTMethod);
		comment: comment! !
!ReturnNode methodsFor: '*VMMaker-C translation' stamp: 'eem 10/2/2009 11:26'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"
	^TReturnNode new 
		setExpression: (expr asTranslatorNodeIn: aTMethod);
		comment: comment! !
!MessageNode methodsFor: '*VMMaker-C translation' stamp: 'eem 10/2/2009 11:26'!
asTranslatorNodeIn: aTMethod
	"make a CCodeGenerator equivalent of me"
	"selector is sometimes a Symbol, sometimes a SelectorNode!!
	On top of this, numArgs is needed due to the (truly grody) use of
	arguments as a place to store the extra expressions needed to generate
	code for in-line to:by:do:, etc.  see below, where it is used."
	| sel args |
	sel := (selector isSymbol) ifTrue: [selector] ifFalse: [selector key].
	args := (1 to: sel numArgs) collect:
			[:i | (arguments at: i) asTranslatorNodeIn: aTMethod].
	(sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]])
		ifTrue: ["Restore limit expr that got moved by transformToDo:"
				args at: 1 put: ((arguments at: 7) value asTranslatorNodeIn: aTMethod)].
	(sel = #or: and: [arguments size = 2 and: [(arguments at: 2) notNil]])
		ifTrue: ["Restore argument block that got moved by transformOr:"
				args at: 1 put: ((arguments at: 2) asTranslatorNodeIn: aTMethod)].
	(sel = #ifFalse: and: [arguments size = 2 and: [(arguments at: 2) notNil]])
		ifTrue: ["Restore argument block that got moved by transformIfFalse:"
				args at: 1 put: ((arguments at: 2) asTranslatorNodeIn: aTMethod)].
	^ TSendNode new
		setSelector: sel
		receiver: (receiver ~~ nil ifTrue: [receiver asTranslatorNodeIn: aTMethod])
		arguments: args! !
!ByteArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:13'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asCharPtrFrom: anInteger on: aStream! !
!ByteArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/19/1999 00:25'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asCharPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isBytes')! !
!ByteArray class methodsFor: '*VMMaker-plugin generation' stamp: 'acg 9/17/1999 01:13'!
ccgDeclareCForVar: aSymbolOrString

	^'char *', aSymbolOrString! !

Behavior subclass: #Oop
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-SmartSyntaxPlugins'!
!Oop commentStamp: '<historical>' prior: 0!
Cooercion specification for Identity coercions:

	x asOop: Oop == x
	y asValue: Oop == y!
!Oop class methodsFor: 'plugin generation' stamp: 'eem 10/2/2010 14:12'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream
	"N.B.  The is used both for generation and simulation so answer the result (for interpretation)"
	^cg emitCExpression: aNode on: aStream! !
!Oop class methodsFor: 'plugin generation' stamp: 'eem 10/3/2010 08:09'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream
	"N.B.  The could be used both for generation and simulation so answer the result (for interpretation)"
	^cg emitCExpression: aNode on: aStream! !
!Oop class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 15:58'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asRawOopFrom: anInteger! !
!Oop class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:17'!
ccgCanConvertFrom: anObject

	^(anObject isKindOf: SmallInteger) not! !
!Oop class methodsFor: 'plugin generation' stamp: 'ikp 3/31/2005 14:20'!
ccgDeclareCForVar: aSymbolOrString

	^'sqInt ', aSymbolOrString! !

Behavior subclass: #Unsigned
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-SmartSyntaxPlugins'!
!Unsigned commentStamp: 'tpr 5/5/2003 12:21' prior: 0!
Coercion specification for 32-bit unsigned numbers within plugins.

Note: "x asOop: Unsigned" can cause garbage collection when x is outside SmallInteger range.!
!Unsigned class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:04'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToUnsignedObjectFrom: aNode on: aStream! !
!Unsigned class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:11'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToUnsignedValueFrom: aNode on: aStream! !
!Unsigned class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:30'!
ccgCanConvertFrom: anObject

	anObject isInteger ifFalse: 
		[self error: 'Not an Integer object'. ^false].
	anObject >= 0 ifFalse: 
		[self error: 'Object is negative integer'. ^false].
	anObject < (2 raisedToInteger: 32) ifFalse: 
		[self error: 'Object is too large'. ^false].
	^true! !
!Unsigned methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 09:49'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asUnsignedValueFrom: anInteger! !
!Unsigned methodsFor: 'as yet unclassified' stamp: 'ikp 3/31/2005 14:19'!
ccgDeclareCForVar: aSymbolOrString

	^'unsigned int ', aSymbolOrString! !

InterpreterPlugin subclass: #FFIPlugin
	instanceVariableNames: 'ffiLastError ffiArgClass ffiArgSpec ffiArgSpecSize ffiArgHeader ffiRetOop ffiRetClass ffiRetSpec ffiRetSpecSize ffiRetHeader'
	classVariableNames: ''
	poolDictionaries: 'FFIConstants'
	category: 'VMMaker-Plugins'!
!FFIPlugin commentStamp: 'tpr 5/5/2003 11:54' prior: 0!
This plugin provides access to foreign function interfaces on those platforms that provide such. For example Windows DLLs and unix .so's.!
!FFIPlugin class methodsFor: 'accessing' stamp: 'ar 11/28/1999 18:55'!
declareCVarsIn: aCCodeGen
	aCCodeGen addHeaderFile: '"sqFFI.h"'! !
!FFIPlugin class methodsFor: 'C support code' stamp: 'tpr 5/23/2001 17:09'!
hasHeaderFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
	^true! !
!FFIPlugin class methodsFor: 'accessing' stamp: 'ar 12/2/1999 22:19'!
moduleName "FFIPlugin translate"
	"IMPORTANT: IF YOU CHANGE THE NAME OF THIS PLUGIN YOU MUST CHANGE
		Interpreter>>primitiveCalloutToFFI
	TO REFLECT THE CHANGE."
	^'SqueakFFIPrims'! !
!FFIPlugin class methodsFor: 'translation' stamp: 'tpr 11/29/2000 22:40'!
requiresPlatformFiles
	"this plugin requires platform specific files in order to work"
	^true! !
!FFIPlugin methodsFor: 'primitive support' stamp: 'ar 12/2/1999 21:02'!
atomicTypeOf: value
	^(value bitAnd: FFIAtomicTypeMask) >> FFIAtomicTypeShift! !
!FFIPlugin methodsFor: 'primitive support' stamp: 'tpr 12/21/2005 16:58'!
ffiAddressOf: rcvr startingAt: byteOffset size: byteSize
"return an int of the address of the byteSize slot (byte, short, int, whatever) at byteOffset in rcvr. Nominally intended for use with ExternalAddress objects, this code will work (for obscure historical reasons) with plain Byte or Word Arrays as well. "
	| rcvrClass rcvrSize addr |
	(interpreterProxy isBytes: rcvr) ifFalse:[^interpreterProxy primitiveFail].
	(byteOffset > 0) ifFalse:[^interpreterProxy primitiveFail].
	rcvrClass := interpreterProxy fetchClassOf: rcvr.
	rcvrSize := interpreterProxy byteSizeOf: rcvr.
	rcvrClass == interpreterProxy classExternalAddress ifTrue:[
		(rcvrSize = 4) ifFalse:[^interpreterProxy primitiveFail].
		addr := interpreterProxy fetchPointer: 0 ofObject: rcvr.
		"don't you dare to read from object memory!!"
		(addr == 0 or:[interpreterProxy isInMemory: addr])
			ifTrue:[^interpreterProxy primitiveFail].
	] ifFalse:[
		(byteOffset+byteSize-1 <= rcvrSize)
			ifFalse:[^interpreterProxy primitiveFail].
		addr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'int'.
	].
	addr := addr + byteOffset - 1.
	^addr! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas dtl 2010-09-27) 1/26/2000 19:24'!
ffiArgByValue: oop
	"Support for generic callout. Prepare an argument by value for a callout."
	| atomicType intValue floatValue |
	<inline: true>
	atomicType := self atomicTypeOf: ffiArgHeader.
	"check if the range is valid"
	(atomicType < 0 or:[atomicType > FFITypeDoubleFloat])
		ifTrue:[^self ffiFail: FFIErrorBadAtomicType].
	atomicType < FFITypeSingleFloat ifTrue:["integer types"
		(atomicType >> 1) = (FFITypeSignedLongLong >> 1)
			ifTrue:[intValue := oop] "ffi support code must coerce longlong"
			ifFalse:[intValue := self ffiIntegerValueOf: oop]. "does all the coercions"
		interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
		self dispatchOn: atomicType
			in: #(
				ffiPushVoid:
				ffiPushUnsignedInt:
				ffiPushUnsignedByte:
				ffiPushSignedByte:
				ffiPushUnsignedShort:
				ffiPushSignedShort:
				ffiPushUnsignedInt:
				ffiPushSignedInt:
				ffiPushUnsignedLongLongOop:
				ffiPushSignedLongLongOop:
				ffiPushUnsignedChar:
				ffiPushSignedChar:)
		with: intValue.
	] ifFalse:[
		"either float or double"
		floatValue := self ffiFloatValueOf: oop.
		interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
		atomicType = FFITypeSingleFloat
			ifTrue:[self ffiPushSingleFloat: floatValue]
			ifFalse:[self ffiPushDoubleFloat: floatValue].
	].
	^0! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas dtl 2010-09-27) 1/27/2000 00:06'!
ffiArgument: oop Spec: argSpec Class: argClass
	"Callout support. Prepare the given oop as argument.
	argSpec defines the compiled spec for the argument.
	argClass (if non-nil) defines the required (super)class for the argument."
	| valueOop oopClass isStruct nilOop |
	<inline: false>
	oopClass := interpreterProxy fetchClassOf: oop. "Prefetch class (we'll need it)"
	nilOop :=  interpreterProxy nilObject.
	"Do the necessary type checks"
	argClass == nilOop ifFalse:[
		"Type check 1: 
		Is the required class of the argument a subclass of ExternalStructure?"
		(interpreterProxy includesBehavior: argClass 
						ThatOf: interpreterProxy classExternalStructure)
			ifFalse:[^self ffiFail: FFIErrorWrongType]. "Nope. Fail."
		"Type check 2:
		Is the class of the argument a subclass of required class?"
		((nilOop == oop) or:[interpreterProxy includesBehavior: oopClass ThatOf: argClass])
				ifFalse:[^self ffiFail: FFIErrorCoercionFailed]. "Nope. Fail."
		"Okay, we've passed the type check (so far)"
	].

	"Check if oopClass is a subclass of ExternalStructure.
	If this is the case we'll work on it's handle and not the actual oop."
	isStruct := false.
	((interpreterProxy isIntegerObject: oop) or:[oop == nilOop]) ifFalse:[
		"#isPointers: will fail if oop is SmallInteger so don't even attempt to use it"
		(interpreterProxy isPointers: oop) 
			ifTrue:[isStruct := interpreterProxy includesBehavior: oopClass 
								ThatOf: interpreterProxy classExternalStructure.
					(argClass == nilOop or:[isStruct]) 
						ifFalse:[^self ffiFail: FFIErrorCoercionFailed]].
		"note: the test for #isPointers: above should speed up execution since no pointer type ST objects are allowed in external calls and thus if #isPointers: is true then the arg must be ExternalStructure to work. If it isn't then the code fails anyways so speed isn't an issue"
	].

	"Determine valueOop (e.g., the actual oop to pass as argument)"
	isStruct
		ifTrue:[valueOop := interpreterProxy fetchPointer: 0 ofObject: oop]
		ifFalse:[valueOop := oop].

	ffiArgClass := argClass.

	"Fetch and check the contents of the compiled spec"
	(interpreterProxy isIntegerObject: argSpec)
		ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	(interpreterProxy isWords: argSpec)
		ifFalse:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiArgSpecSize := interpreterProxy slotSizeOf: argSpec.
	ffiArgSpecSize = 0 ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiArgSpec := self cCoerce: (interpreterProxy firstIndexableField: argSpec) to: 'int'.
	ffiArgHeader := interpreterProxy longAt: ffiArgSpec.

	"Do the actual preparation of the argument"
	"Note: Order is important since FFIFlagStructure + FFIFlagPointer is used to represent 'typedef void* VoidPointer' and VoidPointer really is *struct* not pointer."

	(ffiArgHeader anyMask: FFIFlagStructure) ifTrue:[
		"argument must be ExternalStructure"
		isStruct ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		(ffiArgHeader anyMask: FFIFlagAtomic) 
			ifTrue:[^self ffiFail: FFIErrorWrongType]. "bad combination"
		^self ffiPushStructureContentsOf: valueOop].

	(ffiArgHeader anyMask: FFIFlagPointer) ifTrue:[
		"no integers for pointers please"
		(interpreterProxy isIntegerObject: oop) 
			ifTrue:[^self ffiFail: FFIErrorIntAsPointer].

		"but allow passing nil pointer for any pointer type"
		oop == interpreterProxy nilObject ifTrue:[^self ffiPushPointer: nil].

		"argument is reference to either atomic or structure type"
		(ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
			isStruct "e.g., ExternalData"
				ifTrue:[^self ffiAtomicStructByReference: oop Class: oopClass]
				ifFalse:[^self ffiAtomicArgByReference: oop Class: oopClass].
			"********* NOTE: The above uses 'oop' not 'valueOop' (for ExternalData) ******"
		].

		"Needs to be external structure here"
		isStruct ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		^self ffiPushPointerContentsOf: valueOop].

	(ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
		"argument is atomic value"
		self ffiArgByValue: valueOop.
		^0].
	"None of the above - bad spec"
	^self ffiFail: FFIErrorWrongType! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas 12/08) 1/26/2000 22:38'!
ffiAtomicArgByReference: oop Class: oopClass
	"Support for generic callout. Prepare a pointer reference to an atomic type for callout. Note: for type 'void*' we allow either one of ByteArray/String/Symbol or wordVariableSubclass."
	| atomicType isString |
	<inline: true>
	atomicType := self atomicTypeOf: ffiArgHeader.
	(atomicType = FFITypeBool) "No bools on input"
		ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
	((atomicType >> 1) = (FFITypeSignedChar >> 1)) ifTrue:["string value (char*)"
		"note: the only types allowed for passing into char* types are
		ByteArray, String, Symbol and *no* other byte indexed objects
		(e.g., CompiledMethod, LargeInteger). We only check for strings
		here and fall through to the byte* check otherwise."
		isString := interpreterProxy 
					includesBehavior: oopClass 
					ThatOf: interpreterProxy classString.
		isString ifTrue:["String/Symbol"
			"Strings must be allocated by the ffi support code"
			^self ffiPushString: (self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'int') OfLength: (interpreterProxy byteSizeOf: oop)].
		"Fall through to byte* test"
		atomicType := FFITypeUnsignedByte].

	(atomicType = FFITypeVoid or:[(atomicType >> 1) = (FFITypeSignedByte >> 1)]) ifTrue:[
		"byte* -- see comment on string above"
		oopClass = interpreterProxy classByteArray ifTrue:["ByteArray"
			^self ffiPushPointer: (self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int')].
		isString := interpreterProxy includesBehavior: oopClass 
					ThatOf: interpreterProxy classString.
		isString ifTrue:["String/Symbol"
			^self ffiPushPointer: (self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int')].
		atomicType = FFITypeVoid ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		"note: type void falls through"
	].

	(atomicType <= FFITypeSignedInt "void/short/int"
		or:[atomicType = FFITypeSingleFloat]) ifTrue:[
			"require a word subclass to work"
			(interpreterProxy isWords: oop) ifTrue:[
				^self ffiPushPointer: (self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int')]].

	^self ffiFail: FFIErrorCoercionFailed.! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas 12/08) 1/26/2000 23:43'!
ffiAtomicStructByReference: oop Class: oopClass
	"Support for generic callout. Prepare an external pointer reference to an atomic type for callout."
	| atomicType valueOop |
	<inline: true>
	"must be external data to pass pointers to atomic type"
	oopClass == interpreterProxy classExternalData 
		ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
	atomicType := self atomicTypeOf: ffiArgHeader.
	"no type checks for void pointers"
	atomicType ~= FFITypeVoid ifTrue:[
		self ffiValidateExternalData: oop AtomicType: atomicType.
		interpreterProxy failed ifTrue:[^nil].
	].
	"and push pointer contents"
	valueOop := interpreterProxy fetchPointer: 0 ofObject: oop.
	^self ffiPushPointerContentsOf: valueOop! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas 12/08) 12/2/1999 22:19'!
ffiCall: address WithFlags: callType AndTypes: argTypeArray
	"Generic callout. Does the actual work."
	| stackIndex argType argTypes oop nArgs argClass argSpec |
	<inline: true>
	"check if the calling convention is supported"
	(self ffiSupportsCallingConvention: callType)
		ifFalse:[^self ffiFail: FFIErrorCallType].
	argTypes := argTypeArray.
	"Fetch return type and args"
	argType := interpreterProxy fetchPointer: 0 ofObject: argTypes.
	argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
	argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
	self ffiCheckReturn: argSpec With: argClass.
	interpreterProxy failed ifTrue:[^0]. "cannot return"
	ffiRetOop := argType.
	nArgs := interpreterProxy methodArgumentCount.
	stackIndex := nArgs - 1. "stack index goes downwards"
	1 to: nArgs do:[:i|
		argType := interpreterProxy fetchPointer: i ofObject: argTypes.
		argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
		argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
		oop := interpreterProxy stackValue: stackIndex.
		self ffiArgument: oop Spec: argSpec Class: argClass.
		interpreterProxy failed ifTrue:[^0]. "coercion failed"
		stackIndex := stackIndex - 1.
	].
	"Go out and call this guy"
	^self ffiCalloutTo: address WithFlags: callType! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas 12/08) 12/2/1999 22:19'!
ffiCall: address WithFlags: callType Args: argArray AndTypes: argTypeArray OfSize: nArgs
	"Generic callout. Does the actual work."
	| argType argTypes oop argSpec argClass |
	<inline: true>
	"check if the calling convention is supported"
	(self ffiSupportsCallingConvention: callType)
		ifFalse:[^self ffiFail: FFIErrorCallType].
	argTypes := argTypeArray.
	"Fetch return type and args"
	argType := interpreterProxy fetchPointer: 0 ofObject: argTypes.
	argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
	argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
	self ffiCheckReturn: argSpec With: argClass.
	interpreterProxy failed ifTrue:[^0]. "cannot return"
	ffiRetOop := argType.
	1 to: nArgs do:[:i|
		argType := interpreterProxy fetchPointer: i ofObject: argTypes.
		argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
		argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
		oop := interpreterProxy fetchPointer: i-1 ofObject: argArray.
		self ffiArgument: oop Spec: argSpec Class: argClass.
		interpreterProxy failed ifTrue:[^0]. "coercion failed"
	].
	"Go out and call this guy"
	^self ffiCalloutTo: address WithFlags: callType! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas 12/08) 1/26/2000 23:11'!
ffiCalloutTo: address WithFlags: callType
	"Go out, call this guy and create the return value"
	| retVal |
	<inline: false>
	"Note: Order is important here since FFIFlagPointer + FFIFlagStructure is used to represent 'typedef void* VoidPointer' and VoidPointer must be returned as pointer *not* as struct"
	(ffiRetHeader anyMask: FFIFlagPointer) ifTrue:[
		retVal := self ffiCallAddressOf: address WithPointerReturn: callType.
		^self ffiCreateReturnPointer: retVal.
	].
	(ffiRetHeader anyMask: FFIFlagStructure) ifTrue:[
		self 
			ffiCallAddressOf: address 
			With: callType 
			Struct: (self cCoerce: ffiRetSpec to:'int*')
			Return: ffiRetSpecSize.
		^self ffiCreateReturnStruct.
	].
	retVal := self ffiCallAddressOf: address With: callType ReturnType: ffiRetHeader.
	^self ffiCreateReturn: retVal.! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas 12/08) 12/2/1999 21:29'!
ffiCheckReturn: retSpec With: retClass
	"Make sure we can return an object of the given type"
	<inline: true>
	retClass == interpreterProxy nilObject ifFalse:[
		(interpreterProxy includesBehavior: retClass 
						ThatOf: interpreterProxy classExternalStructure)
			ifFalse:[^self ffiFail: FFIErrorBadReturn]].
	ffiRetClass := retClass.

	(interpreterProxy isIntegerObject: retSpec)
		ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	(interpreterProxy isWords: retSpec)
		ifFalse:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiRetSpecSize := interpreterProxy slotSizeOf: retSpec.
	ffiRetSpecSize = 0 ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiRetSpec := self cCoerce: (interpreterProxy firstIndexableField: retSpec) to: 'int'.
	ffiRetHeader := interpreterProxy longAt: ffiRetSpec.
	(self isAtomicType: ffiRetHeader) ifFalse:[
		(ffiRetClass == interpreterProxy nilObject)
			ifTrue:[^self ffiFail: FFIErrorBadReturn]].
	(self ffiCan: (self cCoerce: ffiRetSpec to:'int*') Return: ffiRetSpecSize)
		ifFalse:[self ffiFail: FFIErrorBadReturn]. "cannot return this type"
	^0! !
!FFIPlugin methodsFor: 'callout support' stamp: 'di (auto pragmas 12/08) 7/4/2004 08:39'!
ffiContentsOfHandle: oop errCode: errCode
	"Make sure that the given oop is a valid external handle"
	<inline: true>
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^self ffiFail: errCode].
	(interpreterProxy isBytes: oop)
		ifFalse:[^self ffiFail: errCode].
	((interpreterProxy byteSizeOf: oop) == 4)
		ifFalse:[^self ffiFail: errCode].
	^interpreterProxy fetchPointer: 0 ofObject: oop! !
!FFIPlugin methodsFor: 'callout support' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:02'!
ffiCreateLongLongReturn: isSigned
	"Create a longlong return value from a previous call out"
	| lowWord highWord largeClass nBytes largeInt ptr |
	<var: #ptr type: 'unsigned char *'>
	lowWord := self ffiLongLongResultLow.
	highWord := self ffiLongLongResultHigh.
	isSigned ifTrue:["check for 32 bit signed"
		(highWord = 0 and:[lowWord >= 0])
			ifTrue:[^interpreterProxy signed32BitIntegerFor: lowWord].
		(highWord = -1 and:[lowWord < 0])
			ifTrue:[^interpreterProxy signed32BitIntegerFor: lowWord].
		"negate value for negative longlong"
		highWord < 0 
			ifTrue:[	largeClass := interpreterProxy classLargeNegativeInteger.
					lowWord := lowWord bitInvert32.
					highWord := highWord bitInvert32.
					lowWord = -1 "e.g., overflow when adding one"
						ifTrue:[highWord := highWord + 1].
					lowWord := lowWord + 1]
			ifFalse:[largeClass := interpreterProxy classLargePositiveInteger].
			"fall through"
	] ifFalse:["check for 32 bit unsigned"
		highWord = 0 ifTrue:[
			^interpreterProxy positive32BitIntegerFor: lowWord].
		largeClass := interpreterProxy classLargePositiveInteger.
		"fall through"
	].
	"Create LargeInteger result"
	nBytes := 8.
	(highWord anyMask: 255 << 24) ifFalse:[
		nBytes := 7.
		highWord < (1 << 16) ifTrue:[nBytes := 6].
		highWord < (1 << 8) ifTrue:[nBytes := 5].
		highWord = 0 ifTrue:[nBytes := 4]].
	"now we know how many bytes to create"
	largeInt := interpreterProxy instantiateClass: largeClass indexableSize: nBytes.
	(interpreterProxy isBytes: largeInt) 
		ifFalse:[^self ffiFail: FFIErrorBadReturn]. "Hossa!!"
	ptr := interpreterProxy firstIndexableField: largeInt.
	4 to: nBytes-1 do:[:i|
		ptr at: i put: (highWord >> (i-4*8) bitAnd: 255)].
	ptr at: 3 put: (lowWord >> 24 bitAnd: 255).
	ptr at: 2 put: (lowWord >> 16 bitAnd: 255).
	ptr at: 1 put: (lowWord >> 8 bitAnd: 255).
	ptr at: 0 put: (lowWord bitAnd: 255).
	^largeInt! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar (auto pragmas 12/08) 1/26/2000 19:47'!
ffiCreateReturn: retVal
	"Generic callout support. Create an atomic return value from an external function call"
	| atomicType retOop oop |
	<inline: true>
	interpreterProxy failed ifTrue:[^nil].
	atomicType := self atomicTypeOf: ffiRetHeader.
	"void returns self"
	atomicType <= FFITypeVoid ifTrue:[
		^interpreterProxy pop: interpreterProxy methodArgumentCount].
	"everything else returns value"
	interpreterProxy pop: 
		interpreterProxy methodArgumentCount+1.
	interpreterProxy pushRemappableOop: ffiRetClass.
	retOop := self ffiCreateReturnOop: retVal.
	ffiRetClass := interpreterProxy popRemappableOop.
	ffiRetClass == interpreterProxy nilObject ifTrue:[
		"Just return oop"
		^interpreterProxy push: retOop].
	"Otherwise create an instance of external structure and store the return oop"
	interpreterProxy pushRemappableOop: retOop.
	retOop := interpreterProxy instantiateClass: ffiRetClass indexableSize: 0.
	oop := interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: retOop withValue: oop.
	^interpreterProxy push: retOop.! !
!FFIPlugin methodsFor: 'callout support' stamp: 'ar 5/16/2000 13:39'!
ffiCreateReturnOop: retVal
	"Callout support. Return the appropriate oop for the given atomic value"
	| atomicType shift value mask byteSize |
	atomicType := self atomicTypeOf: ffiRetHeader.
	atomicType = FFITypeBool ifTrue:[
			"Make sure bool honors the byte size requested"
			byteSize := ffiRetHeader bitAnd: FFIStructSizeMask.
			byteSize = 4
				ifTrue:[value := retVal]
				ifFalse:[value := retVal bitAnd: 1 << (byteSize * 8) - 1].
			value = 0
				ifTrue:[^interpreterProxy falseObject]
				ifFalse:[^interpreterProxy trueObject]].
	atomicType <= FFITypeSignedInt ifTrue:[
		"these are all generall integer returns"
		atomicType <= FFITypeSignedShort ifTrue:[
			"byte/short. first extract partial word, then sign extend"
			shift := (atomicType >> 1) * 8. "# of significant bits"
			value := retVal bitAnd: (1 << shift - 1). 
			(atomicType anyMask: 1) ifTrue:[
				"make the guy signed"
				mask := 1 << (shift-1).
				value := (value bitAnd: mask-1) - (value bitAnd: mask)].
			^interpreterProxy integerObjectOf: value].
		"32bit integer return"
		(atomicType anyMask: 1)
			ifTrue:[^(interpreterProxy signed32BitIntegerFor: retVal)] "signed return"
			ifFalse:[^(interpreterProxy positive32BitIntegerFor: retVal)]]. "unsigned return"

	atomicType < FFITypeSingleFloat ifTrue:[
		"longlong, char"
		(atomicType >> 1) = (FFITypeSignedLongLong >> 1) 
			ifTrue:[^self ffiCreateLongLongReturn: (atomicType anyMask: 1)]
			ifFalse:[^(interpreterProxy 
						fetchPointer: (retVal bitAnd: 255)
						ofObject: interpreterProxy characterTable)]].
	"float return"
	^interpreterProxy floatObjectOf: (self ffiReturnFloatValue).! !
!FFIPlugin methodsFor: 'callout support' stamp: 'tpr (auto pragmas dtl 2010-09-27) 12/29/2005 16:02'!
ffiCreateReturnPointer: retVal
	"Generic callout support. Create a pointer return value from an external function call"
	| atomicType retOop oop ptr classOop |
	<var: #ptr type: 'int *'>
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: interpreterProxy methodArgumentCount+1.
	(ffiRetClass == interpreterProxy nilObject) ifTrue:[
		"Create Exte