'From Squeak3.8 of ''5 May 2005'' [latest update: #6665] on 27 February 2006 at 10:52:13 am'!

!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!


!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 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! !


!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.
! !


!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 2/27/2006 10:39'!
doOne: aClass

	| n 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). ].


	"--- must skip howManySpareTypeTableSlots ---"
	n := (howManyDone + self howManySpareTypeTableSlots) asString.  

	SmallInteger == aClass  ifTrue: [
		self write: '#define   C_' , className , '_TypeIndex    0 /*SmallInteger must be number 0*/'.
	] ifFalse: [
		self write: '#define   C_' , className , '_TypeIndex    ' , n.
	].

	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/26/2006 22:11'!
initialize

	super initialize.

	extraFields := IdentityDictionary new.

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

	extraFields at: Symbol put: #(
		#'x_arrayIndex'			"its index in SymbolTable"
		#'x_left'				"for binary tree (unused yet)"
		#'x_right'				"ibid"
	).

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


! !


!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 2/27/2006 10:29'!
doOne: aClass

	| className clsObjName f |
	super doOne: aClass.


	className := self tr: aClass name.

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

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

	self write: clsObjName , '.setTypeIndex( C_', (self tr: aClass class name), '_TypeIndex );'.

	self write: clsObjName , '.setFlags( Header::ETERNAL | Header::SHARED );'.
	self write: clsObjName , '.setHash( C_' , className , '_TypeIndex );'.
	self write: clsObjName , '.x_phoneNumber = OopFromNum( C_' , className , '_TypeIndex );'.
	self write: clsObjName , '.x_name = OopFromHeader( InternSymbol("' , className , '"));'.
	aClass superclass ifNil: [		
		self write: clsObjName , '.f_superclass = OopNil;'.
	] ifNotNil: [
		self write: clsObjName , '.f_superclass = OopFromHeader(& C_' ,(self tr: aClass superclass name) , '_ClsObj);'.
	].

	f := '0'.
	aClass isBits
		ifTrue: [ f := f, '|Header::BITS'].
	aClass isBytes
		ifTrue: [ f := f, '|Header::BYTES'].
	aClass isVariable
		ifTrue: [ f := f, '|Header::INDEXED'.
			self assert: aClass instSize < 8.
			aClass instSize > 0
				ifTrue: [ f := f, '|Header::FIXED_8']
		].
	
	self write: clsObjName , '.x_instanceFlags= OopFromNum( ', f, ' );'.

	self write: clsObjName , '.x_numFixedOops = OopFromNum(' , aClass instSize asString , ');'.
	"self write: '// ' , aClass allInstVarNames asString."
	self write: ''.

"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<  These look like they were for the SUPER, but we do those on their own <<<<<<<<<<<<<<<<<<<
	(className endsWith: '$class') ifTrue: [
		self write: clsObjName , '.setTypeIndex( C_Metaclass_TypeIndex );'.
	] ifFalse: [
		self write: clsObjName , '.setTypeIndex( C_',className,'$32$class_TypeIndex );'.
	].
	self write: clsObjName , '.setFlags( Header::ETERNAL | Header::SHARED );'.
	self write: clsObjName , '.setHash(C_' , className , '_TypeIndex);'.
	--we use the unused 'category' field to point back to the Type.--
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"

	self write: ''.
	self write: ''.
	self write: ''.! !


!CinnabarxGenVariables methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 21:47'!
doOne: 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 2/27/2006 09:42'!
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:'.
	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 comment: 'captureStack: ' , captureStack asString.
	body comment: 'contextStack: ' , contextStack asString.
	body comment: '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 write: '// pushed to ' , contextStack asString
		]
		ifFalse: [body write: '// no captures, so dont push to ' , contextStack 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 2/26/2006 11:33'!
flattenNonBlockNode: aNode
	| msg |

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

	"-- 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 2/27/2006 09:33'!
generateMethodInstalls

	" --- install methods for theClass itself "

	theClass methodDict keys asArray sort do: [ :k |  | kk |  kk := self tr: k.

		self write: 'InsertFunction( cls, InternSymbol("', k, '"),'.
		self write: '  (FUNC*) Func_', theClass name, '_', kk, ');'.

	].

	" --- install methods for the metaclass "

	theClass class methodDict keys asArray sort do: [ :k |  | kk |  kk := self tr: k.

		self write: 'InsertFunction( superCls, InternSymbol("', k, '"),'.
		self write: '  (FUNC*) Func_', theClass name, '$32$class_', kk, ');'.

	].

! !

!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 2/27/2006 09:35'!
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 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 2/27/2006 09:31'!
translateClass: aClass

	theClass := aClass.

	self addClassToMasters: aClass.

	self write: '#include "cinnabar.h" '.
	self translateMethodsOf: aClass.
	self translateMethodsOf: aClass class.

"
	self fileStream nextPutAll: myDecls fileStream contents.
	self fileStream nextPutAll: body fileStream contents.
"
	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 generateMethodInstalls.
	self fileStream nextPutAll: myInits fileStream contents.

	self write: '}'.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/27/2006 09:41'!
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: [
		"self unimplemented: 'Primitive Method ', 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,
				'  --  %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 write: ' ERROR:'.
	body write: '  AddVatErrorString(PASS_VAT  "in ' , theClass name , '>>' , 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 , '>>' , 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 2/27/2006 09:45'!
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 , ' . setTypeIndex( Func_TypeIndex );'.
	"=============== 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 2/27/2006 09:38'!
visitMessageNode: aMessageNode 
	| n z msgSelector msgReceiver argList funcType |

"<< 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.
	myDecls write: 'static SenderCache cache' , n , ';'.
	myDecls write: 'static Symbol* selector' , n , ';'.
	myInits write: 'InsertSenderCache( &cache' , n , ' );';
		 write: 'selector' , n , ' = InternSymbol("' , msgSelector , '"); '.
	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 typeIndex= C_', (self tr: theClass superclass name), '_TypeIndex;'.
		body comment: 'Sending To Super...'.
	] ifFalse: [
		"--- normal send --- based on runtime type"
		body write: 'word typeIndex= OopToTypeIndex(' , msgReceiver , ');'.
	].
	body write: 'BIND_CACHE( cache' , n , ', typeIndex, selector' , n , ' );   /* ' , msgSelector , ' */'.
	funcType := 'FUNC' , aMessageNode arguments size asString , '*'.
	body write: funcType , ' f= (' , funcType , ')cache' , n , '.func;'.
	body write: z , '=  f(PASS_VAT  ' , msgReceiver , ', selector' , n , 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)

! !