'From Squeak3.8 of ''5 May 2005'' [latest update: #6665] on 2 March 2006 at 9:05:01 pm'!

!CinnabarxClosure commentStamp: '<historical>' prior: 0!
The runtime closure objects representing Smalltalk Block Closures that can be sent #value...!

Object subclass: #CinnabarxContextBase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarxContextBase commentStamp: '<historical>' prior: 0!
A base class for runtime context objects for holding captured variables that might be used my multple blocks and scopes!

CinnabarxBase subclass: #CinnabarxGenDeclaratons
	instanceVariableNames: 'extraFields masterInits '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxBase subclass: #CinnabarxGenInitializations
	instanceVariableNames: 'symDict nextTackyNum nextClassyNum '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxBase subclass: #CinnabarxTranslateClass
	instanceVariableNames: 'nextSerialNumber myDecls myInits body specialCases firstPass blockStack method contextStack saveStack theClass captureStack masterDecls masterVars masterInits senderCacheArraySize '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/26/2006 17:14'!
literalArray: litArray 
	| n z |
	n := self serial asString.
	z := 'lit_' , n.
	declarations write: 'static oop ' , z , ';'.
	initializations write: z , '= BasicNewColon(PASS_VAT  & C_Array_TypeObj, ' , litArray size asString , ');'.
	initializations write: 'assert(' , z , ');'.
	1
		to: litArray size
		do: [:i | 
			| x y | 
			x := litArray at: i.
					y := self literal: x.
					initializations write: 'Prim_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/26/2006 17:14'!
visitBraceNode: aBraceNode 
	| n z e |
	e := aBraceNode elements.
	n := self serial asString.
	z := 'brace_' , n.
	body write: 'oop ' , z , '= BasicNewColon(PASS_VAT  & C_Array_TypeObj, ' , e size asString , ');'.
	body write: 'assert(' , z , ');'.
	1
		to: e size
		do: [:i | 
			| y |
			y := (e at: i) acceptVisitor: self.
			body write: 'Prim_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 2/16/2006 00:26'!
enterScope: aScope 
	"aScope is a BlockNode or a MethodNode (at the top level)"
	"***get the name of the previous context from the contextStack. 000
	means none."
	| captures vars n argNames lastN |
	contextStack size > 0
		ifTrue: [lastN := contextStack last]
		ifFalse: [lastN := '000'].
	"***"
	body write: '// LastN=' , lastN , ' ... Entering Scope:'.
	self comment: aScope.
	"*** Look at args & temp vars"
	argNames := aScope arguments
				collect: [:a | a name].
	blockStack addLast: aScope.
	vars := aScope arguments union: aScope temporaries.
	captures := vars
				select: [:t | firstPass testCapturedVariable: t name inScope: aScope].
	captureStack
		addLast: (captures
				collect: [:t | t name]).
	self comment: 'captureStack: ' , captureStack asString.
	self comment: 'contextStack: ' , contextStack asString.
	self comment: 'blockStack: ' , blockStack size asString.
	"-" 
		captures do: [:v | self comment: '!!!!!!!! CAPTURED: ' , v asString ].
	"-"
	"==="
	aScope temporaries
		do: [:t | (captures includes: t)
				ifFalse: [body write: 'oop v_' , t name , '= OopNil; /* define temp */']].
	"==="
	captures size > 0
		ifTrue: [n := self serial asString.
			declarations write: 'struct context_' , n , ' : public Object {'.
			contextStack size > 0
				ifTrue: [declarations write: 'oop octx_' , lastN , ';'].
			captures
				do: [:v | declarations write: 'oop v_' , v name , ';'].
			declarations write: '}'.
			declarations write: ';'.
			body write: 'oop octx_' , n , '= BasicNewColon(PASS_VAT  &C_Array_TypeObj, ' , (captures size + 1) asString , ' );'.
			body write: 'context_' , n , ' * ctx_' , n , '= (context_' , n , '*) OopToHeader( octx_' , n , ');'.
			contextStack size > 0
				ifTrue: [lastN := contextStack last.
					body write: 'ctx_' , n , '->octx_' , lastN , '= octx_' , lastN , ';'].
			captures
				do: [:v | (argNames includes: v name)
						ifTrue: [body write: 'ctx_' , n , '->v_' , v name , ' = v_' , v name , ';']
						ifFalse: [body write: 'ctx_' , n , '->v_' , v name , ' = ' , 'OopNil;']].
			contextStack addLast: n.
			body write: '// pushed to ' , contextStack asString]
		ifFalse: [body write: '// no captures, so dont push to ' , contextStack asString]! !


!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 17:36'!
ttestBraceArray
	| a b c n |
	n := 100.
	b := {1 + n. 5 + n. 9 + n}.
	c := {#value. #(2 4 6 ). {n + n. n + n + n}. nil}.
	a := {}.

	0 = a basicSize
		ifFalse: [^ false].
	3 = b basicSize
		ifFalse: [^ false].
	4 = c basicSize
		ifFalse: [^ false].

	109
			== (b basicAt: 3)
		ifFalse: [^ false].
	101
			== (b basicAt: 1)
		ifFalse: [^ false].
	nil
			== (c basicAt: 4)
		ifFalse: [^ false].

	Array == (c basicAt: 2) class
		ifFalse: [^ false].
	#value
			== (c basicAt: 1)
		ifFalse: [^ false].
	^ true
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 17:03'!
ttestFactorial
	"^ 120 = (self new factorial: 5)"
	| expected |
	expected := 1.
	1
		to: 8
		do: [:i | 
			| got |
			i > 7 ifTrue: [
				'i=' say.
				i say.
			].
			"#(1 2 3 4 5 6 7 8) collect: [:x | x factorial]"
			"#(1 2 6 24 120 720 5040 40320)"
			"expected := i factorial."
			expected := expected * i.

			i > 7 ifTrue: [
			'expected' say.
			expected say.
			].
			got := self factorial: i.

			i > 7 ifTrue: [
			'got' say.
			got say.
			].
			expected == got
				ifFalse: [^ false]].
	^ true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 12:07'!
ttestIdentityDictionary

"
	| d |


	d := IdentityDictionary new.
	d at: 10 put: 100.
	d at: 20 put: 400.
	d at: 'pie' put: 'round'.
	^ 400 == (d at: 20)
"

	^ true! !


!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/21/2006 12:30'!
addImportantClasses

	self addClassSupersAndMetas: Object.
	self addClassSupersAndMetas: CinnabarxCFunction.
	self addClassSupersAndMetas: CinnabarxClosure.
	self addClassSupersAndMetas: CinnabarxContextBase.

	self addClassSupersAndMetas: True.
	self addClassSupersAndMetas: False.
	self addClassSupersAndMetas: Character.
	self addClassSupersAndMetas: UndefinedObject.
	self addClassSupersAndMetas: IdentityDictionary.
	self addClassSupersAndMetas: TranscriptStream.
	self addClassSupersAndMetas: SmallInteger.
	self addClassSupersAndMetas: ByteString.
	self addClassSupersAndMetas: ByteSymbol.
	self addClassSupersAndMetas: Array.
! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 19:25'!
doAll

	howManyDone := 0.

	list do: [ :aClass | self doOneFirstPass: aClass ].
	list do: [ :aClass | self doOneSecondPass: aClass ].! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 19:25'!
doOneFirstPass: aClass

! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 19:26'!
doOneSecondPass: aClass

	howManyDone := howManyDone + 1
! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 17:28'!
nocomment: something 

	"-- don't write comment --"! !


!CinnabarxBigTests methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 22:23'!
closureOfSupers: aCollection 
"
self new closureOfSupers: #( IdentityDictionary )

(self new closureOfSupers: #( CinnabarTestFib CinnabarTestFruit CinnabarTestApple CinnabarTestGreenApple	Object True False Character 	UndefinedObject IdentityDictionary TranscriptStream SmallInteger ByteString ByteSymbol Array ) ) asArray sort
"

	^ self closureOfSupers: aCollection into: Set new
! !

!CinnabarxBigTests methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 22:23'!
closureOfSupers: aCollection into: aSet

	aCollection do: [ :x | | c |
		(aSet includes: x) ifFalse: [
			aSet add: x.
			c := Smalltalk at: x.
			c superclass ifNotNil: [ self closureOfSupers: { c superclass name } into: aSet. ].
		].
	].

	^ aSet.

! !

!CinnabarxBigTests methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 10:13'!
testBig
"
self new testBig
"

	| d v i t list |

	d := CinnabarxGenDeclaratons new fileName: '_gen_header.h'.
	v := CinnabarxGenVariables new fileName: '_gen_objects.h'.
	i :=  CinnabarxGenInitializations new fileName: '_gen_inits.h'.

	d addImportantClasses.
	v addImportantClasses.
	i addImportantClasses.

	list := #( Integer ).

	list := (self closureOfSupers: #( 
		CinnabarTestFib CinnabarTestFruit CinnabarTestApple CinnabarTestGreenApple
		Object True False Character DateAndTime
		Class Metaclass
		UndefinedObject IdentityDictionary TranscriptStream
		SmallInteger ByteString ByteSymbol Array
	)) asArray sort.


     list do: [ :clsName |
		Utilities informUser: (' Compiling: ', clsName, ' ') during: [

			t := CinnabarxTranslateClass new fileName: '_', clsName, '.cc'.
			t masterDecls: d masterVars: v masterInits: i.

			t translateClass: (Smalltalk at: clsName).

			t fileStream close.
		]
	].

	d doAll fileStream close.
	v doAll fileStream close.
	i doAll fileStream close.





! !


!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:17'!
doOneSecondPass: aClass

	| className superClassName clsObjName superC |
	super doOne: aClass.


	className := self tr: aClass name.
	superC := aClass superclass.
	superC
		ifNil: [ superClassName := 'Header' ]
		ifNotNil: [ superClassName := 'C_' , (self tr: superC name). ].

	self write: '#define   C_' , className , '_TypeNumber    ', (masterInits intern: aClass name).

	self write: 'struct C_' , className , ' : public ' , superClassName , ' /*' , aClass kindOfSubclass , '*/ {'.

		(aClass instanceVariablesString findTokens: ' ')
			do: [:var | self write: 'oop f_' , var , ';'].

		(extraFields at: aClass ifAbsent: [#()]) 
				do: [ :x | self write: 'oop ', x, ';' ].
				
	self write: '/*' , aClass instSize asString , '*/ }'.
	self write: ';'.


	"--- be curious about big class objects ---"
	(('*$32$class' match: className)
			and: [11 ~= aClass instSize])
		ifTrue: [self write: '/*EXTRA CLASS VAR NAMES: ' , aClass instVarNames asString , '*/'].



	clsObjName := 'C_' , className , '_ClsObj'.


	(className endsWith: '$32$class') ifTrue: [
		self write: 'extern struct C_Metaclass ' , clsObjName , ';'.
	] ifFalse: [
		self write: 'extern struct C_', className, '$32$class ' , clsObjName , ';'.
	].
! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 2/28/2006 14:02'!
howManySpareTypeTableSlots

	^ 1! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 2/28/2006 15:11'!
initialize

	super initialize.

	extraFields := IdentityDictionary new.

	extraFields at: Behavior put: #( 
		#'x_name'				"--temporary--"
		#'x_typeNumber'		"index in the phone book"
		#'x_numFixedOops'		"how many fixed oop fields are in instances"
		#'x_funcMap'			"pointer to cinnabarx-specific structure (WRAPPED)"
		#'x_arrayShape'		"array shape of instances"
		#'x_senderCacheChain'	"SenderCaches to be invalidated when behavior is updated (WRAPPED)"
		#'x_debugName'			"easy way to print what class/metaclass it is"
	).

	extraFields at: CinnabarxCFunction put: #(
		#'x_entry'				"address of C function (WRAPPED)"
	).


! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:09'!
masterInits: m

	masterInits := m! !


!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 19:17'!
doAll

	self doSymbols.

	super doAll.! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:46'!
doOneFirstPass: aClass

	| className clsObjName |
	super doOneFirstPass: aClass.

	className := self tr: aClass name.

	clsObjName := 'C_' , className , '_ClsObj'.


	self write: 'TypeTable[ C_' , className , '_TypeNumber ]= & ' , clsObjName , ';'.
	self write: ''.
! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:04'!
doOneSecondPass: aClass

	| className clsObjName |
	super doOneSecondPass: aClass.


	className := self tr: aClass name.

	clsObjName := 'C_' , className , '_ClsObj'.

	self write: ''.
	self write: clsObjName , '.setTypeNumber( C_', (self tr: aClass class name), '_TypeNumber );'.

	self write: clsObjName , '.setAge( AGE_IMMORTAL );'.
	self write: clsObjName , '.setHash( C_' , className , '_TypeNumber );'.
	self write: clsObjName , '.x_typeNumber = OopFromNum( C_' , className , '_TypeNumber );'.
	self write: clsObjName , '.x_name = OopFromHeader( SymbolTable[', (self intern: aClass name), '] );'.
	aClass superclass ifNil: [		
		self write: clsObjName , '.f_superclass = OopNil;'.
	] ifNotNil: [
		self write: clsObjName , '.f_superclass = OopFromHeader(& C_' ,(self tr: aClass superclass name) , '_ClsObj);'.
	].

	aClass isVariable
		ifFalse: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_NONE);' ]
		ifTrue: [
			aClass isBits
				ifTrue: [
					aClass isBytes
						ifTrue: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_BYTES);']
			 			ifFalse: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_WORDS);'].
				]
			 	ifFalse: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_OOPS);'].
		].

	self write: clsObjName , '.x_numFixedOops = OopFromNum((sizeof(C_',className,')-sizeof(Header))/sizeof(word));'.

	"<<self write: '// ' , aClass allInstVarNames asString.>>"

	self write: ''.
! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:37'!
doSymbols

	symDict keys asArray sort do: [ :s |

		self write: 'InternSymbolAt( "', (self escapeStringForC: s), '", ', (symDict at: s),' );'.

	].
 
	self write: 'NextClassySymbol = ', nextClassyNum asString, ' ;'.
	self write: 'NextTackySymbol = ', nextTackyNum asString, ' ;'.
! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 19:54'!
initialize

	symDict := Dictionary new.

	nextClassyNum := 0.

	nextTackyNum := 128 * 256.  " 2 ^ 15 "

	self intern: #SmallInteger.	"must be 0"
	self intern: #ByteSymbol.	"must be 1"

	super initialize.! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 19:31'!
intern: sym


	^ symDict at: sym ifAbsentPut: [

		( (sym size >0) and: [$A <= sym first] and: [sym first <= $Z] ) ifTrue: [

			((nextClassyNum := nextClassyNum + 1) - 1) asString

		] ifFalse: [

			((nextTackyNum := nextTackyNum + 1) - 1) asString

		]

	]! !


!CinnabarxGenVariables methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:02'!
doOneSecondPass: aClass

	| className clsObjName |
	super doOne: aClass.


	className := self tr: aClass name.
	clsObjName := 'C_' , className , '_ClsObj'.

	(className endsWith: '$32$class') ifTrue: [
		"cannot use ClassDescription of Metaclass yet (due to category abuse)"
		self write: 'struct C_Metaclass ' , clsObjName , ';'.
	] ifFalse: [
		self write: 'struct C_', className, '$32$class ' , clsObjName , ';'.
	].
! !


!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 11:46'!
aboutUnknownISSUES

"<<

Object decompile: #caseOf:
  the printing of the decompile is WRONG:  (* 
   caseOf: t1 
	^ self caseOf: t1
*)
   The message-send (really to #caseOf:otherwise:) is special: 14.
DOES NOT SEEM TO BE ANY ACTUAL SENDERS OF #caseOf: NOR OF #caseOf:otherwise:

MessageNode class initialize
(*
    	MacroSelectors _ 
		#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:
			and: or:
			whileFalse: whileTrue: whileFalse whileTrue
			to:do: to:by:do:
			caseOf: caseOf:otherwise:
			ifNil: ifNotNil:  ifNil:ifNotNil: ifNotNil:ifNil:).
... and more ... *)

--------------------------------------------------------

Smalltalk keys select: [ :k |  (Smalltalk at: k) isBehavior not ] 
   an IdentitySet(#Undeclared #Transcript #Smalltalk #ScheduledControllers #WonderlandConstants #Sensor #ActiveEvent #References #SourceFiles #ActiveHand #SystemOrganization #World #ScriptingSystem #Processor #ImageImports #ActiveWorld #Display #TextConstants #CustomEventsRegistry)
----------------------------------------------------------

>>"! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 17:30'!
enterScope: aScope 
	"aScope is a BlockNode or a MethodNode (at the top level)"
	"***get the name of the previous context from the contextStack. 000
	means none."
	| captures vars n argNames lastN |
	contextStack size > 0
		ifTrue: [lastN := contextStack last]
		ifFalse: [lastN := '000'].
	"***"
	body nocomment: 'LastN=' , lastN , ' ... Entering Scope:'.
	body comment: aScope.
	"*** Look at args & temp vars"
	argNames := aScope arguments
				collect: [:a | a name].
	blockStack addLast: aScope.
	vars := aScope arguments union: aScope temporaries.
	captures := vars
				select: [:t | firstPass testCapturedVariable: t name inScope: aScope].
	captureStack
		addLast: (captures
				collect: [:t | t name]).
	body nocomment: 'captureStack: ' , captureStack asString.
	body nocomment: 'contextStack: ' , contextStack asString.
	body nocomment: 'blockStack: ' , blockStack size asString.
	"-" 
		captures do: [:v | body comment: '!!!!!!!! CAPTURED: ' , v asString ].
	"-"
	"==="
	aScope temporaries
		do: [:t | (captures includes: t)
				ifFalse: [body write: 'oop v_' , t name , '= OopNil; /* define temp */']].
	"==="
	captures size > 0
		ifTrue: [n := self serial asString.
			myDecls write: 'struct context_' , n , ' : public C_CinnabarxContextBase {'.
			contextStack size > 0
				ifTrue: [myDecls write: 'oop octx_' , lastN , ';'].
			captures
				do: [:v | myDecls write: 'oop v_' , v name , ';'].
			myDecls write: '}'.
			myDecls write: ';'.
			body write: 'oop octx_' , n , '= BasicNewColon(PASS_VAT  &C_Array_ClsObj, ' , (captures size + 1) asString , ' );'.
			body write: 'context_' , n , ' * ctx_' , n , '= (context_' , n , '*) OopToHeader( octx_' , n , ');'.
			contextStack size > 0
				ifTrue: [lastN := contextStack last.
					body write: 'ctx_' , n , '->octx_' , lastN , '= octx_' , lastN , ';'].
			captures
				do: [:v | (argNames includes: v name)
						ifTrue: [body write: 'ctx_' , n , '->v_' , v name , ' = v_' , v name , ';']
						ifFalse: [body write: 'ctx_' , n , '->v_' , v name , ' = ' , 'OopNil;']
				].
			contextStack addLast: n.
			body nocomment: 'pushed to ' , contextStack asString
		]
		ifFalse: [body nocomment: 'no captures, so dont push to ' , contextStack asString]! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 17:30'!
exitScope: aScope 
	"aScope is a BlockNode or a MethodNode (at the top level)"
	| popped vars captures |
	0.
	0.
	vars := aScope arguments union: aScope temporaries.
	captures := vars
				select: [:t | firstPass testCapturedVariable: t name inScope: aScope].
	0.
	0.
	captures size > 0
		ifTrue: [body nocomment: 'exitScope: removeLast from ' , contextStack asString.
			contextStack removeLast]
		ifFalse: [body nocomment: 'exitScope: no captures, so dont removeLast from ' , contextStack asString].
	0.
	0.
	captureStack removeLast.
	popped := blockStack removeLast.
	"make sure we popped the right scope"
	self assert: popped == aScope.
	"==="
	body nocomment: 'Exiting Scope: ', aScope asString.
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 11:26'!
flattenBlockNode: aBlockNode 
	| n z i numStatements |

	aBlockNode class == BlockNode ifFalse: [ ^ self flattenNonBlockNode: aBlockNode ]. 


	n := self serial asString.

	(firstPass blockIsFlat: aBlockNode)
		ifTrue: [self enterScope: aBlockNode. z := 'flat_' , n.  ]
		ifFalse: [ z := 'unflat_' , n. ].

	body write: 'oop ' , z , '= OopNil;'.

	body write: '/*(',n, ')*/ {'.
	i := 1.
	numStatements := aBlockNode statements size.
	aBlockNode statements
		do: [:aStmt | 
			| stmtResult | 
			stmtResult := aStmt acceptVisitor: self.

			"only on the last statement do we assign z the stmtResult"
			i = numStatements
				ifTrue: [body write: z , '= ' , stmtResult asString , ';'].

			i := i + 1.
	].
	body write: '/*(',n, ')*/  }'.

	(firstPass blockIsFlat: aBlockNode)
		ifTrue: [self exitScope: aBlockNode].
	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 22:25'!
flattenNonBlockNode: aNode
	| msg |

	body comment: '(*flattenNonBlockNode:*) ', aNode asString. 

	"-- create a synthetic MessageNode to send #value to the node. --"

	msg := MessageNode new.

	msg receiver: aNode.
	msg selector: ( SelectorNode new key: #value; yourself ).
	msg arguments: #().

	^ msg acceptVisitor: self.	

! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:59'!
generateMethodInstalls

	" --- install methods for theClass itself "

	theClass methodDict keys size = 0 ifTrue: [
		self write: 'InsertNoFunctions(cls);'
	] ifFalse: [
		theClass methodDict keys asArray sort do: [ :k |  | kk |  kk := self tr: k.

			self write: 'InsertFunction( cls, SymbolTable[',(masterInits intern: k), '] , (FUNC*) Func_', theClass name, '_', kk, ');'.

		].
	].

	" --- install methods for the metaclass "
	theClass class methodDict keys size = 0 ifTrue: [
		self write: 'InsertNoFunctions(superCls);'
	] ifFalse: [
		theClass class methodDict keys asArray sort do: [ :k |  | kk |  kk := self tr: k.

			self write: 'InsertFunction( superCls, SymbolTable[',(masterInits intern: k), '] , (FUNC*) Func_', theClass name, '$32$class_', kk, ');'.

		].
	].
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 18:37'!
initialize

	super initialize.

	captureStack := OrderedCollection new.
	saveStack := OrderedCollection new.
	blockStack := OrderedCollection new.
	contextStack := OrderedCollection new.

	senderCacheArraySize := 0.
	nextSerialNumber := 0.
	myDecls := CinnabarxBase new fileStreamInMemory.
	myInits := CinnabarxBase new fileStreamInMemory.
	body := CinnabarxBase new fileStreamInMemory.

	"Make a table for special message cases"
	specialCases := Dictionary new.

	specialCases 
		at: #'==' put: #messageEQEQ: ;
		at: #'~~' put: #messageNENE: ;
		
		at: #= put: #messageEQ: ;
		at: #'~=' put: #messageNE: ;
		at: #< put: #messageLT: ;
		at: #> put: #messageGT: ;
		at: #'<=' put: #messageLE: ;	
		at: #'>=' put: #messageGE: ;

		 at: #+ put: #messageAdd: ;
		 at: #- put: #messageSub: ;
		 at: #* put: #messageMul: ;
		
		at: #bitAnd put: #messageBitAnd: ;
		
		at: #bitOr put: #messageBitOr: ;
		
		at: #bitXor put: #messageBitXor: ;
		
		at: #bitShift: put: #messageBitShift: ;
"<<
		at: #basicNew put: #messageBasicNew: ;
		
		at: #basicNew: put: #messageBasicNewColon: ;
>>"
		at: #say put: #messageSay: ;
		
		at: #error: put: #messageErrorColon: .

	"*** both to:by:do: and to:do: are handled by #specialForLoop:  ***"
	specialCases
		at: #to:by:do: put: #specialForLoop:  ;
		
		at: #to:do: put: #specialForLoop: .! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/27/2006 09:43'!
literalArray: litArray 
	| n z |
	n := self serial asString.
	z := 'litArray_' , n.

	myDecls write: 'static oop ' , z , ';'.

	myInits write: z , '= BasicNewColon(PASS_VAT  & C_Array_ClsObj, ' , litArray size asString , ');'.
	myInits write: 'assert(' , z , ');'.

	1 to: litArray size do: [:i | 

			myInits write: 
					'Prim_BasicAtPut(PASS_VAT  ' , 
					z , 
					',  NULL, OopFromNum(' , i asString , '), ' , 
					(self literal: (litArray at: i)) , 
					');'

		].

	^ z
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 22:40'!
literalByteSymbol: lit 
	| n z |
	n := self serial asString.
	z := 'sym_' , n.

	" --- TODO --- collaps these into single instance of each symbol --- "

	myDecls write: 'static oop ' , z , ';'.

	myInits write: z , '= OopFromHeader( InternSymbol( "', (self escapeStringForC: lit) , '") );'.
	myInits write: 'assert(' , z , ');'.

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:09'!
masterDecls: d masterVars: v masterInits: i

	masterDecls := d.
	masterVars := v.
	masterInits := i.

	d masterInits: i.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 11:22'!
specialCaseOf: aMessageNode
	
	^ self unimplemented: 'Unsupported #caseOf:... Message Node (may not print correctly) :', aMessageNode asString
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/24/2006 17:19'!
specialForLoop: aMessageNode 
	| n rcvr argTo argBy block |


	body comment: 'Special For Loop...'.

	n := self serial asString.
	"---"
	rcvr := aMessageNode receiver acceptVisitor: self.

	(aMessageNode arguments at: 7 ifAbsent: [nil] ) ifNotNil: [
		"These have an AssignmentNode for the *LimiT temporary at 7"
		body comment: 
			'(*',aMessageNode arguments first asString,'*) ', 
					(aMessageNode arguments at: 7) asString.
		argTo := (aMessageNode arguments at: 7) "(AssignmentNode)" value acceptVisitor: self.
	] ifNil: [
		argTo := aMessageNode arguments first acceptVisitor: self.
	].
	argBy := aMessageNode arguments second acceptVisitor: self.

( argTo asString endsWith: 'LimiT' ) ifTrue: [ self break ].

	"--- if these are known constants, this will vanish by C++ optimizer:"
	body write: 'if (!!(1&(word)(' , rcvr , ')&(word)(' , argTo , ')&(word)(' , argBy , '))) {'.
	body write: 'SetVatErrorString(PASS_VAT  "to:by:do: requires SmallIntegers");'.
	body write: 'goto ERROR;'.
	body write: '}'.
	"---"
	body write: 'num i_' , n , ' = OopToNum(' , rcvr , ');'.
	body write: 'num to_' , n , ' = OopToNum(' , argTo , ');'.
	body write: 'num by_' , n , ' = OopToNum(' , argBy , ');'.
	"--- if by: is known constant, this will simplify by -O:"
	body write: 'for ( ; (by_' , n , '>0) ? (i_' , n , '<=to_' , n , ') : (i_' , n , '>=to_' , n , ') ; i_' , n , '+=by_' , n , ') {'.
	"--- expand the do: block"
	block := aMessageNode arguments third.
	body write: 'oop v_' , block arguments first name , ' = OopFromNum(i_' , n , ');'.
	self flattenBlockNode: block.
	"---"
	body write: '}'.
	^ 'OopNil'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 18:49'!
translateClass: aClass

	theClass := aClass.

	self addClassToMasters: aClass.

	self write: '#include "cinnabar.h" '.
	self write: 'static SenderCache *Cache;'.

	self translateMethodsOf: aClass.
	self translateMethodsOf: aClass class.

	self write: 'extern "C" void Init_', aClass name, ' (PARM_VAT_ONLY) {'.
	self write: 'Type* cls= & C_', aClass name, '_ClsObj;'.
	self write: 'Type* superCls= & C_', aClass name, '$32$class_ClsObj;'.

	self write: 'Cache= (SenderCache*) malloc( ',senderCacheArraySize asString,' * sizeof(SenderCache) );'.
	self write: 'assert(Cache);'.
	self write: 'memset( Cache, 0, ',senderCacheArraySize asString,' * sizeof(SenderCache) );'.  

	self generateMethodInstalls.
	self fileStream nextPutAll: myInits fileStream contents.

	self write: '}'.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 09:45'!
translateMethod

|  selector bNode argVars funcName cc mm |

	selector := method selector asString.
	cc := (self tr: theClass name).
	mm := (self tr: selector).
	funcName := 'Func_', cc, '_', mm.

	firstPass := CinnabarFirstPass new
				visitMethodNode: method
				forClass: theClass
				for: self.
	"*** firstPass inspect. ***"

	bNode := method block.
	argVars := method arguments
				collect: [:var | var acceptVisitor: self].
	body write: 'oop ' , funcName , '(PARM_VAT   oop v_self, Symbol* selector'
				, (self declareParameters: argVars) , ') {'.


	( method primitive > 0 ) ifTrue: [
	  (256 <= method primitive & (method primitive <= 519)) ifTrue: [
		"range 256..519 (really to 519????) are optional and of no benefit to cinnabar" 
		body comment: 'Ignoring Optional Primitive ', method primitive asString.
	  ] ifFalse: [
		body write: 'oop primout= Primitive', method primitive asString,
			'((PASS_VAT  v_self, selector',
			(argVars inject: '' into: [ :aa :a | aa, ', ', a ]),
			'));'.
		body write: 'if (primout) return primout;'.
		body write: 'fprintf(stderr, "******  Primitive Failed  --  ',
				method primitive asString,
				'  --  %s\n", Chars(selector) );'.
	  ].
	].
	body write: '{'.

	"============ trying enterScope ===================="
	
		self enterScope: method.

	"======================================================="
	"this will be wrong for methods on num/SmallInteger"
	theClass == SmallInteger
		ifFalse: [ body write: ' C_' , cc , '* self= (C_' , cc , '*) OopToHeader(v_self);'].

	self flattenBlockNode: bNode.


	body write: '/*END*/ return v_self;'.
	body write: '}'.
	( body fileStream contents findString: 'ERROR') > 0 ifTrue: [ "if the test slows things down, always generate:"
		body write: ' ERROR:'.
		body write: '  AddVatErrorString(PASS_VAT  "in ' , theClass name , '>>' , (self escapeStringForC: selector) , ' ...");'.
		body write: '   return (oop)0;'.
	].
	body write: '}'.

	body write: 'Function F_' , funcName , ';'.
	"==============================="
	self exitScope: method.
	"======================================================="
	myInits write: 'F_' , funcName , '.x_entry = OopWrapPointer( (void*)' , funcName , ');'.
	myInits write: 'F_' , funcName , '.f_name = Str(PASS_VAT "' , theClass name , '>>' , (self escapeStringForC: selector), '");'.
	self resetFunction.

! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 12:03'!
translateMethodsOf: theClassOrItsClass

	| saveTheClass useDecompiler |

	useDecompiler := true.

	saveTheClass := theClass.  "--- only changes when doing metaclass. ---" 
	theClass := theClassOrItsClass.

	theClass methodDict keys asArray sort do: [ :selector | 

		method := useDecompiler ifTrue: [  
				theClass decompile: selector.
		] ifFalse: [
				Parser new parse: (theClass sourceMethodAt: selector) class: theClass.
		].
		
		self translateMethod.

	].

	theClass := saveTheClass.     "--- restore the class ---"
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 22:31'!
unimplemented: x 

	body write: 'SetVatErrorString(PASS_VAT  "UNIMPLEMENTED: ' , (self escapeStringForC: x asString), '");'.
	body write: 'goto ERROR;'.
	^ 'OopNOTREACHED'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/28/2006 17:22'!
visitBlockNode: aBlockNode 
	"push the blockNode & recurse"
	"=================== try enterScope ========================"
	| lastN n z funcName argVars result summary prev |
	n := self serial asString.
	z := 'closure_' , n.
	lastN := contextStack size > 0
				ifTrue: [contextStack last]
				ifFalse: ['000'].
	funcName := 'block_' , n.
	argVars := aBlockNode arguments
				collect: [:v | 'v_' , v name].
	"========================================================"
	self pushFunction.
	"=============================="
	summary := self
				escapeStringForC: (self cleanString: aBlockNode asString max: 80).
	body write: ''.
	body write: 'static char Name_' , funcName , '[] = "[] in ' , theClass name , '>>' , method selector , '  /*' , funcName , '*/  ' , summary , '";'.
	body write: 'static Function Obj_' , funcName , ';'.
	body write: ''.
	myInits write: 'Obj_' , funcName , ' . x_entry = OopWrapPointer( (void*)' , funcName , ');'.
	myInits write: 'Obj_' , funcName , ' . f_name = Str(PASS_VAT  Name_' , funcName , ');'.
	myInits write: 'Obj_' , funcName , ' . f_numArgs = OopFromNum(' , argVars size asString , ');'.
	myInits write: 'Obj_' , funcName , ' . setTypeNumber( Func_TypeNumber );'.
	"=============== generate block function ================="
	body write: 'oop ' , funcName , '(PARM_VAT'.
	body write: '   Closure* closure '.
	body
		write: (self declareParameters: argVars).
	body write: ') {'.
	body write: 'oop v_self= closure->f_myself;'.
	body write: 'oop octx_' , lastN , '= closure->f_context;'.
	body write: '///===contextStack=== ' , contextStack asString.
	contextStack size > 0
		ifTrue: [body write: 'context_' , lastN , ' * ctx_' , lastN , ' = (context_' , lastN , '*) OopToHeader( octx_' , lastN , ' );'.
			prev := 'ctx_' , lastN].
	"this will be wrong for methods on num/SmallInteger"
	theClass == SmallInteger
		ifFalse: [body write: 'C_' , (self tr: theClass name) , '* self= (C_' , (self tr: theClass name) , '*) OopToHeader(v_self);'].
	contextStack size - 1
		to: 1
		by: -1
		do: [:i | 
			| nn | 
			nn := (contextStack at: i) asString.
			body write: 'context_' , nn , ' * ctx_' , nn , ' = (context_' , nn , '*) OopToHeader( ' , prev , '->octx_' , nn , ' );'.
			prev := 'ctx_' , nn].

	self enterScope: aBlockNode.
	result := self flattenBlockNode: aBlockNode.
	self exitScope: aBlockNode.
	body write: '/*END*/ return ' , result , ';'.
	body write: 'ERROR: AddVatErrorString(PASS_VAT  Name_' , funcName , ' );'.
	body write: 'return OopGOTO;'.
	body write: '}'.
	"=============================="
	self popFunction.
	"=============================================================="
	body write: 'oop o' , z , '= BasicNew(PASS_VAT  &ClosureType);'.
	body write: 'Closure* ' , z , '= (Closure*) OopToHeader( o' , z , ');'.
	body write: z , '->f_function= OopFromHeader( & Obj_' , funcName , ' );'.
	contextStack size > 0
		ifTrue: [body write: z , '->f_context= octx_' , contextStack last , ';']
		ifFalse: [body write: z , '->f_context= 0;'].
	body write: z , '->f_myself= v_self;'.
	^ 'o' , z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/27/2006 09:43'!
visitBraceNode: aBraceNode 
	| n z e |
	e := aBraceNode elements.
	n := self serial asString.
	z := 'brace_' , n.
	body write: 'oop ' , z , '= BasicNewColon(PASS_VAT  & C_Array_ClsObj, ' , e size asString , ');'.
	body write: 'assert(' , z , ');'.
	1
		to: e size
		do: [:i | 
			| y |
			y := (e at: i) acceptVisitor: self.
			body write: 'Prim_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 19:49'!
visitMessageNode: aMessageNode 
	| n z msgSelector msgReceiver argList funcType cacheNum symtab |

"<< These are the values of 'special' -- MessageNode::MacroEmitters --
 #( 1 #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: 7 #emitWhile:on:value: #emitWhile:on:value: #emitWhile:on:value: #emitWhile:on:value: 11 #emitToDo:on:value: #emitToDo:on:value: 13 #emitCase:on:value: #emitCase:on:value: 15 #emitIfNil:on:value: #emitIfNil:on:value: 17 #emitIf:on:value: #emitIf:on:value: 19)
>>"

	body comment: aMessageNode.
	msgSelector := aMessageNode selector acceptVisitor: self.
	"*** Check to see if the message is a special case before you go any
	further "

	(aMessageNode special) ifNotNil: [
	  (aMessageNode special > 0) ifTrue: [
		body comment: 'SPECIAL TYPE ', aMessageNode special asString, ' #', msgSelector.
		(aMessageNode special < 7) ifTrue: [ ^ self specialConditional: aMessageNode ].
		(aMessageNode special < 11) ifTrue: [ ^ self specialWhileLoop: aMessageNode ].
		(aMessageNode special < 13) ifTrue: [ ^ self specialForLoop: aMessageNode ].
		(aMessageNode special < 15) ifTrue: [ ^ self specialCaseOf: aMessageNode ].
		(aMessageNode special < 19) ifTrue: [ ^ self specialConditional: aMessageNode ].
		^ self unimplemented: 'Special Message Type ', aMessageNode special asString.
	  ]
	].

	(specialCases includesKey: msgSelector)
		ifTrue: [^ self
				perform: (specialCases at: msgSelector)
				with: aMessageNode].


	"*** Normal messages continue here."
	n := self serial asString.
	z := 'send_' , n.

	symtab := 'SymbolTable[' , (masterInits intern: msgSelector) , ']'.	
	cacheNum := senderCacheArraySize asString.
	senderCacheArraySize := senderCacheArraySize + 1.

	body write: 'oop ' , z , '= OopNil;'.
	body write: '{'.
	msgReceiver := aMessageNode receiver acceptVisitor: self.

	argList := self passArgumentVariables: aMessageNode arguments.
	( aMessageNode receiver class == VariableNode 
		and: [ aMessageNode receiver name = 'super' ]
	) ifTrue: [
		"--- send to super --- based on static superclass"
		body write: 'word typeNumber= C_', (self tr: theClass superclass name), '_TypeNumber;'.
		body comment: 'Sending To Super...'.
	] ifFalse: [
		"--- normal send --- based on runtime type"
		body write: 'word typeNumber= OopToTypeNumber(' , msgReceiver , ');'.
	].
	body write: 'BIND_CACHE( Cache[' , cacheNum, '], typeNumber, ', symtab,' );   /* ' , msgSelector , ' */'.
	funcType := 'FUNC' , aMessageNode arguments size asString , '*'.
	body write: funcType , ' f= (' , funcType , ') Cache[' , cacheNum, '].func;'.
	body write: z , '=  f(PASS_VAT  ' , msgReceiver , ', ', symtab , argList , ');'.
	body write: 'if (!!' , z , ') goto ERROR;'.
	body write: '}'.
	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 11:58'!
visitVariableNode: aVariableNode 
	| var |
	var := aVariableNode name.

	"-- compiler uses LiteralVariableNode, but decompiler just uses VariableNode, for these: --"
	( $A <= var first and: [ var first <= $Z ] ) ifTrue: [
		^ self visitLiteralVariableNode: aVariableNode
	].
 
	"-- check first for reserved names --"
	var = 'true'
		ifTrue: [^ 'OopTrue'].
	var = 'false'
		ifTrue: [^ 'OopFalse'].
	var = 'nil'
		ifTrue: [^ 'OopNil'].
	var = 'self'
		ifTrue: [^ 'v_self'].
	var = 'super'
		ifTrue: [^ 'v_self'   "-- for super, the object is self -- but the dispatch is different --" ].
	var = 'thisContext'
		ifTrue: [^ self unimplemented: 'thisContext' ].
	var = 'Smalltalk'
		ifTrue: [^ self unimplemented: 'Smalltalk' ].

	^ 'self->f_' , var , '/*var*/'! !


!ClassHacks methodsFor: 'as yet unclassified' stamp: 'strick 2/24/2006 17:09'!
questions

	( Metaclass allInstances collect: [ :m | m theNonMetaClass instVarNames ] )

	CinnabarTestFib decompile: #fib: .


	( Metaclass allInstances collect: [ :m | m soleInstance] ) select: [ :c | (c theNonMetaClass instVarNames size > 0) and: [c isVariable] ] . 

	#(PseudoContext BlockContext MethodContext WeakMessageSend SparseLargeTable B3DSimpleMesh B3DSimpleMeshFace)

! !

CinnabarxBase subclass: #CinnabarxTranslateClass
	instanceVariableNames: 'nextSerialNumber myDecls myInits body specialCases firstPass blockStack method contextStack saveStack theClass captureStack masterDecls masterVars masterInits senderCacheArraySize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxGenVariables removeSelector: #doOne:!
CinnabarxGenInitializations removeSelector: #doOne:!
CinnabarxBase subclass: #CinnabarxGenInitializations
	instanceVariableNames: 'symDict nextClassyNum nextTackyNum'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxGenDeclaratons removeSelector: #doOne:!
CinnabarxBase subclass: #CinnabarxGenDeclaratons
	instanceVariableNames: 'extraFields masterInits'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxBigTests removeSelector: #ttestIdentityDictionary!