'From Squeak3.8 of ''5 May 2005'' [latest update: #6665] on 5 March 2006 at 9:16:45 pm'!
CinnabarxBase subclass: #CinnabarxTranslateClass
	instanceVariableNames: 'nextSerialNumber myDecls myInits body specialCases firstPass blockStack method contextStack saveStack theClass captureStack masterDecls masterVars masterInits senderCacheArraySize specialOperations '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!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 3/5/2006 20:08'!
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: Float.
	self addClassSupersAndMetas: ByteString.
	self addClassSupersAndMetas: ByteSymbol.
	self addClassSupersAndMetas: Array.
! !


!CinnabarxBigTests methodsFor: 'as yet unclassified' stamp: 'strick 3/4/2006 22:58'!
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: (' Cinnabarx Translating Class:  ', 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.





! !


!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/3/2006 12:14'!
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, ' ;'.
! !


!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/5/2006 21:03'!
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.
	specialOperations := Dictionary new.

	specialOperations
		at: #'==' put: 'Prim_EQEQ' ;
		at: #'~~' put: 'Prim_NENE' .

	specialOperations
		at: #= put: 'Prim_7_Equal' ;
		at: #'~=' put: 'Prim_8_NotEqual' ;
		at: #< put: 'Prim_3_LessThan' ;
		at: #> put: 'Prim_4_GreaterThan' ;
		at: #'<=' put: 'Prim_5_LessOrEqual' ;	
		at: #'>=' put: 'Prim_6_GreaterOrEqual' ;

		 at: #+ put: 'Prim_1_Add' ;
		 at: #- put: 'Prim_2_Subtract' ;
		 at: #* put: 'Prim_9_Multiply' ;
		 at: #/ put: 'Prim_10_Divide' ;
		 at: #'//' put: 'Prim_12_Div' ;
		 at: #\\ put: 'Prim_11_Mod' ;
		 at: #quo: put: 'Prim_13_Quo' ;

		at: #bitAnd put: 'Prim_14_BitAnd' ;		
		at: #bitOr put: 'Prim_15_BitOr' ;
		at: #bitXor put: 'Prim_16_BitXor' ;
		at: #bitShift: put: 'Prim_17_BitShift' .

"<<
		at: #basicNew put: #messageBasicNew: ;
		at: #basicNew: put: #messageBasicNewColon: ;
>>"

	specialCases
		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 3/5/2006 13:00'!
message: aMessageNode binOp: aFuncName

	| n z rcvr arg1 |

	n := self serial asString.
	z := 'binop_',n.

	aMessageNode arguments size == 1 
	ifTrue: [

		rcvr := aMessageNode receiver acceptVisitor: self.
		arg1 := (aMessageNode arguments at:1) acceptVisitor: self.

		body write: 'oop ',z,'= ',aFuncName,'(PASS_VAT  ',rcvr,', (Symbol*)NULL, ',arg1,' );'.

		"----DONT----body write: 'if ( !! ',z,' ) goto ERROR;'."

	] ifFalse: [ 

		self error: 'Not a binop'

	].

	^ z
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/4/2006 21:35'!
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: '#ifdef Primitive', method primitive asString.
		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, ' -- ', funcName, '\n" );'.
		body write: '#else'.
		body write: 'fprintf(stderr, "** Primitive Missing -- ',
				method primitive asString, ' -- ', funcName, '\n" );'.
		body write: '#endif'.
	  ].
	].
	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 3/5/2006 12:58'!
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 ~~ nil and: [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.



	(specialOperations includesKey: msgSelector)
		ifTrue: [ | tmp |
			"tmp := self	perform: (specialOperations at: msgSelector) with: aMessageNode."
			tmp := self message: aMessageNode binOp: (specialOperations at: msgSelector).
			body write: 'oop ', z, '= ', tmp, ';'.
			body write: 'if ( !! ', z, ' ) // slow'.
		] ifFalse: [
			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! !


!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 3/5/2006 12:02'!
testGenDeclarations

	| b result |
	b := CinnabarxGenDeclaratons new fileStreamInMemory.

	b addImportantClasses.
	b masterInits: CinnabarxGenInitializations new.

	b doAll.

	"result to complex to check in Unit Test -- so check size & make sure no exceptions"
	result := b fileStream contents.
	result size.

! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 3/5/2006 12:00'!
testGenDeclarationsToFile

	| b |
	b := CinnabarxGenDeclaratons new fileName: '_gen_header.tmp'.

	b addImportantClasses.
	b masterInits: CinnabarxGenInitializations new.

	b doAll.

	b close.

! !

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