'From Squeak3.8 of ''5 May 2005'' [latest update: #6665] on 9 March 2006 at 5:00:33 pm'!
Object subclass: #CinnabarTestCollections
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
Object subclass: #CinnabarxFoundation
	instanceVariableNames: 'version decls vars inits model extraFields'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxBase subclass: #CinnabarxGenDeclaratons
	instanceVariableNames: 'extraFields masterInits foundation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxBase subclass: #CinnabarxGenInitializations
	instanceVariableNames: 'symDict nextClassyNum nextTackyNum foundation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxBase subclass: #CinnabarxGenVariables
	instanceVariableNames: 'foundation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
TestCase subclass: #CinnabarxTestLargeIncrModel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
TestCase subclass: #CinnabarxTestLargeModel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
TestCase subclass: #CinnabarxTestMediumModel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
TestCase subclass: #CinnabarxTestSmallIncrModel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
TestCase subclass: #CinnabarxTestSmallModel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxBase subclass: #CinnabarxTranslateClass
	instanceVariableNames: 'nextSerialNumber myDecls myInits body specialCases firstPass blockStack method contextStack saveStack theClass captureStack masterDecls masterVars masterInits senderCacheArraySize foundation specialOperations '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/7/2006 23:32'!
ttestIdentityDictionary

	| d |

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


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

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 13:31'!
ttestWhileTrueColonUnflat

	| i z a b |

	i := z := 0.

	a := [ i <= 10 ].

	b := [ z := z + i.   i := i + 1.  ]. 

	a whileTrue: b.

	^ z == 55! !


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

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 11:34'!
doAll

	howManyDone := 0.

	list do: [ :aClass | self doOneClass: aClass ].! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 11:32'!
doOneClass: aClass

	howManyDone := howManyDone + 1
! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 3/9/2006 08:56'!
generateClassDefinition: aClass useIfdef: useIfdef

	| className superClassName clsObjName superC fdn metatype |


	self write: ''.
	self comment: aClass name.
	self write: ''.

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

	(className endsWith: '$32$class') ifTrue: [
		metatype := 'struct C_Metaclass'.
	] ifFalse: [
		metatype := 'struct C_', className, '$32$class'.
	].

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

	useIfdef ifTrue: [
		self write: '#ifndef  C_' , className , '_TypeNumber'.
		self write: 'static word  C_' , className , '_TypeNumber;'.

		self myInits write: '#ifndef  C_' , className , '_TypeNumber'.
		self myInits write: 'C_' , className , '_TypeNumber = InternSymbol("', (self escapeStringForC: aClass name), '")->hash();'.
		self myInits write: clsObjName,'Ptr = (',metatype,'*) RuntimeCreateClass(PASS_VAT  C_',className,'_TypeNumber, sizeof(C_',className,'), &C_',(self tr: superC name),'_ClsObj, &C_',(self tr: aClass class name),'_ClsObj );'.
		self myInits write: '#endif'.

		fdn := nil.
	] ifFalse: [
		fdn := self foundation.
		self write: '#define   C_' , className , '_TypeNumber    ', (fdn intern: aClass name).
	].

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

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

		fdn ifNotNil: [
			(fdn 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 , '*/'].

	useIfdef ifTrue: [
		self write: 'static ',metatype,'* ' , clsObjName , 'Ptr;'.

		self write: '#define   ',clsObjName, '   (*',clsObjName,'Ptr)'.

		self write: '#endif'.
	] ifFalse: [

		self write: 'extern  ',metatype,'  ',clsObjName,';'.

	].
! !


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





! !


!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:40'!
addClassToFoundation: aClass

	#incr == model ifFalse: [
		decls addClassSupersAndMetas: aClass.
		vars addClassSupersAndMetas: aClass.
		inits addClassSupersAndMetas: aClass.
	].! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:59'!
closureOfSubs: aCollection 
"
self new closureOfSubs: #( Set )
"

	^ self closureOfSubs: aCollection into: Set new
! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:21'!
closureOfSubs: aCollection into: aSet

	aCollection do: [ :x | | c |
		(aSet includes: x) ifFalse: [
			c := Smalltalk at: x ifAbsent: [ nil ].
			c ifNotNil: [
				c class == Metaclass ifFalse: [
					aSet add: x.
					c subclasses do: [ :sub | self closureOfSubs: { sub name } into: aSet. ].
				].
			].
		].
	].

	^ aSet.

! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:05'!
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
! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:13'!
closureOfSupers: aCollection into: aSet

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

	^ aSet.

! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 13:02'!
extraFields

	^ extraFields! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/7/2006 23:40'!
initialize

	super initialize.

	version := DateAndTime now asSeconds.

	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)"
	).


! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:40'!
intern: aSymbol

	^ inits intern: aSymbol! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:15'!
largeArrayOfClasses

"
  self new largeArrayOfClasses
"


	^ (self closureOfSupers: 
		( self closureOfSubs: 
			#( 
				UndefinedObject True False Integer Character DateAndTime
				Behavior Set Array
	))) asArray sort.

! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:11'!
mediumArrayOfClasses

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

! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:17'!
model

	^model! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:15'!
model: aModelSymbol

	model := aModelSymbol! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 13:26'!
smallArrayOfClasses

	^ #( 
		CinnabarTestFib CinnabarTestFruit CinnabarTestApple CinnabarTestGreenApple
	) asArray sort.

! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/9/2006 07:34'!
translateClassesIncr: list

	self model: #incr.

	decls := nil.
	vars := nil.
	inits := nil.

     list do: [ :clsName |
		Utilities informUser: ('Cinnabarx Translating Class:  ', clsName, '  (incr)') during: [
			| t |

			t := CinnabarxTranslateClass new. 
			t fileName: '__', clsName, '.cc'.
			t foundation: self.

			t translateClass: (Smalltalk at: clsName).

			t fileStream close.
		]
	].






! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:56'!
translateClasses: list

	decls := CinnabarxGenDeclaratons new fileName: '_gen_header.h'.
	vars := CinnabarxGenVariables new fileName: '_gen_objects.h'.
	inits :=  CinnabarxGenInitializations new fileName: '_gen_inits.h'.

	decls foundation: self.
	vars foundation: self.
	inits foundation: self.

	decls addImportantClasses.
	vars addImportantClasses.
	inits addImportantClasses.

     list do: [ :clsName |
		Utilities informUser: (' Cinnabarx Translating Class:  ', clsName, '  ') during: [
			| t |

			t := CinnabarxTranslateClass new. 
			t fileName: '_', clsName, '.cc'.
			t foundation: self.

			t translateClass: (Smalltalk at: clsName).

			t fileStream close.
		]
	].

	decls doAll fileStream close.
	vars doAll fileStream close.
	inits doAll fileStream close.





! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/7/2006 23:40'!
version

	^ version! !


!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 3/7/2006 23:44'!
doAll

	self write: '#define CIN_FOUNDATION_VERSION ', foundation version asString.

	super doAll.
! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:44'!
doOneClass: aClass

	super doOneClass: aClass.

	self generateClassDefinition: aClass useIfdef: false.
! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:46'!
foundation

	^ foundation! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:31'!
foundation: f

	foundation := f! !


!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 11:41'!
doAll

	self doSymbols.

	list do: [ :aClass | self doInitializeClassBeforeDoingClasses: aClass ].

	super doAll.! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 11:37'!
doInitializeClassBeforeDoingClasses: aClass

	| className clsObjName |

	"we need to define class object and install in TypeTable before the #doOneClass: are called." 

	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/6/2006 11:38'!
doOneClass: aClass

	| className clsObjName |
	super doOneClass: 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/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, ' ;'.
! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:37'!
foundation: f

	foundation := f! !


!CinnabarxGenVariables methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 11:38'!
doOneClass: aClass

	| className clsObjName |
	super doOneClass: 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 , ';'.
	].
! !

!CinnabarxGenVariables methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:38'!
foundation: f

	foundation := f! !


!CinnabarxTestLargeIncrModel methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:27'!
testDoTranslate

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.

	f translateClassesIncr:  f smallArrayOfClasses.


! !


!CinnabarxTestLargeModel methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:22'!
testDoTranslate

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.
	f model: #large.
	f translateClasses: f largeArrayOfClasses.

! !


!CinnabarxTestMediumModel methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:59'!
testDoTranslate

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.
	f model: #medium.
	f translateClasses: f mediumArrayOfClasses.

! !


!CinnabarxTestSmallIncrModel methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:52'!
testDoTranslate

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.

	f translateClassesIncr: #( CinnabarTestFib ).

! !


!CinnabarxTestSmallModel methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:38'!
testDoTranslate

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.
	f model: #small.
	f translateClasses: f smallArrayOfClasses.
	f translateClassesIncr: #( CinnabarTestFib ).

! !


!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:24'!
addClassToFoundation: aClass

	foundation addClassToFoundation: aClass

! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:20'!
foundation

	^ foundation! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 13:10'!
foundation: aCinnabarxFoundation

	foundation := aCinnabarxFoundation.

	#small == foundation model   ifTrue: [

		specialCases
			at: #basicNew put: #messageBasicNew: ;
			at: #basicNew: put: #messageBasicNewColon: .
	].! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 21:55'!
generateClassDefinitionRecursively: aClass

	aClass superclass ifNotNil: [
		self generateClassDefinitionRecursively: aClass superclass
	].

	self generateClassDefinition: aClass useIfdef: true.


! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:42'!
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: '{'.
			#incr == foundation model ifTrue: [
				self write: 'Symbol* s= InternSymbol( "', (self escapeStringForC: k), '" );'.
			] ifFalse: [
				self write: 'Symbol* s= SymbolTable[', (foundation intern: k), '];'.
			]. 

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

			self write: '}'.
		].
	].

	" --- 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: '{'.
			#incr == foundation model ifTrue: [
				self write: 'Symbol* s= InternSymbol( "', (self escapeStringForC: k), '" );'.
			] ifFalse: [
				self write: 'Symbol* s= SymbolTable[', (foundation intern: k), '];'.
			]. 


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

			self write: '}'.
		].
	].
! !

!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/6/2006 13:25'!
messageBasicNewColon: aMessageNode 

	| n z rcvr arg1 |

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

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

	body write: 'oop ' , z , '= Prim_BasicNewColon(PASS_VAT  ' , rcvr ,' ,NULL, ', arg1, ' );'.
	body write: 'if ( !! ' , z , ' ) goto ERROR;'.

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 13:25'!
messageBasicNew: aMessageNode 

	| n z rcvr |

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

	rcvr := aMessageNode receiver acceptVisitor: self.

	body write: 'oop ' , z , '= Prim_BasicNew(PASS_VAT  ' , rcvr , ' , NULL );'.
	body write: 'if ( !! ' , z , ' ) goto ERROR;'.

	^ z! !

!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/8/2006 22:01'!
myInits

	^ myInits! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/9/2006 08:24'!
translateClass: aClass

	theClass := aClass.

	self addClassToFoundation: aClass.

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

	"-- make metaclass first -- it will be needed for class, if created at Runtime --"
	self generateClassDefinitionRecursively: aClass class.
	self generateClassDefinitionRecursively: aClass.

	self translateMethodsOf: aClass.
	self translateMethodsOf: aClass class.

	self write: 'extern "C" void Init_', aClass name, ' (PARM_VAT_ONLY) {'.

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

	self fileStream nextPutAll: myInits fileStream contents.

	self write: 'Type* cls= & C_', aClass name, '_ClsObj;'.
	self write: 'Type* superCls= & C_', aClass name, '$32$class_ClsObj;'.

	self generateMethodInstalls.
	self write: '}'.! !

!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/6/2006 11:07'!
visitBlockNode: aBlockNode 
	"<< Push the blockNode & recurse.
	This is what is called when we do NOT flatten a Block, as we do for #ifTrue:ifFalse:
	and other frequent flattenable methods.  
	See #flattenBlockNode for the flattened version.
	>>"
	"=================== 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: 'static 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 3/9/2006 16:45'!
visitLiteralVariableNode: aNode 

	| obj |
	obj := aNode key value.
	obj
		ifKindOf: Class
		thenDo: [:cls | 
			self addClassToFoundation: cls.
			^ 'OopFromHeader(&C_' , cls name , '_ClsObj)'
		].

	(aNode key key = #Smalltalk) ifTrue: [ ^ 'OopSmalltalk' ].
	(aNode key key = #Transcript) ifTrue: [ 	^ 'OopTranscript' ].

	^self unimplemented: 'Some kind of LiteralVariableNode: ', aNode asString

			! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:36'!
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.

	#incr == foundation model ifTrue: [
		myDecls write: 'static Symbol* sym_',n,';'.
		myInits write: 'sym_',n,'= InternSymbol( "', (self escapeStringForC: msgSelector), '" );'.
		symtab := 'sym_',n.
	] ifFalse: [
		symtab := 'SymbolTable[' , (foundation 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/7/2006 23:42'!
testGenDeclarations

	| b result |
	b := CinnabarxGenDeclaratons new fileStreamInMemory.

	b addImportantClasses.

	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/7/2006 23:42'!
testGenDeclarationsToFile

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

	b addImportantClasses.

	b doAll.

	b close.

! !

CinnabarxTranslateClass removeSelector: #addClassToMasters:!
CinnabarxTranslateClass removeSelector: #masterDecls:masterVars:masterInits:!
CinnabarxTranslateClass removeSelector: #translateClassIncr:!
CinnabarxBase subclass: #CinnabarxTranslateClass
	instanceVariableNames: 'nextSerialNumber myDecls myInits body specialCases firstPass blockStack method contextStack saveStack theClass captureStack senderCacheArraySize specialOperations foundation'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxGenVariables removeSelector: #doOneSecondPass:!
CinnabarxBase subclass: #CinnabarxGenVariables
	instanceVariableNames: 'foundation'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxGenInitializations removeSelector: #doOneFirstPass:!
CinnabarxGenInitializations removeSelector: #doOneSecondPass:!
CinnabarxBase subclass: #CinnabarxGenInitializations
	instanceVariableNames: 'symDict nextClassyNum nextTackyNum foundation'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxGenDeclaratons removeSelector: #doOneSecondPass:!
CinnabarxGenDeclaratons removeSelector: #howManySpareTypeTableSlots!
CinnabarxGenDeclaratons removeSelector: #initialize!
CinnabarxGenDeclaratons removeSelector: #masterInits:!
CinnabarxBase subclass: #CinnabarxGenDeclaratons
	instanceVariableNames: 'foundation'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
CinnabarxFoundation removeSelector: #testBig!
CinnabarxBase removeSelector: #checkClassDefinition:useIfdef:!
CinnabarxBase removeSelector: #doOneFirstPass:!
CinnabarxBase removeSelector: #doOneSecondPass:!
CinnabarxBase removeSelector: #doOne:!