'From Squeak3.8 of ''5 May 2005'' [latest update: #6665] on 15 March 2006 at 9:49:18 pm'!
Object subclass: #CinnabarTestCollections
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
Smalltalk renameClassNamed: #CinnabarFirstPass as: #CinnabarxFirstPass!
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: #CinnabarxTestNextIncrModel
	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/15/2006 21:28'!
ttest100factorial

	| z |
	z := 1.
	1 to: 20 do: [ :i | z := z * i ].

	2432902008176640000 = z  ifFalse: [^false].

	^  2432902008176640000 = ( 20 factorial )
! !

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/15/2006 08:36'!
ttest60000000

	^  16r60000000 = (16r30000000 + 16r30000000) 
! !

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/13/2006 08:02'!
ttestIdentityDictionary

	| d |

	d := IdentityDictionary new.
	d at: 10 put: 100.
	d at: 20 put: 400.
	d at: 'pie' put: 'round'.
	^ 400 == (d at: 20) and: [100 == (d at: 10)] and: [ 42 == (d at: 23 ifAbsent: [39 + d size])]
! !

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/12/2006 22:14'!
ttestNonSmallSum

	^  LargePositiveInteger == (16r30000000 + 16r30000000) class
! !


!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/13/2006 08:08'!
largeArrayOfClasses

"
  self new largeArrayOfClasses
"


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

! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/13/2006 08:05'!
mediumArrayOfClasses

"
	self new 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/13/2006 08:23'!
doOneClass: aClass

	| className clsObjName |
	super doOneClass: aClass.


	className := self tr: aClass name.

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

	self write: ''.
	self write: 'ResetObject( & ',clsObjName,' );'.
	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 , '.f_format = OopFromNum( ',aClass format asString,' );'.
	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.

! !


!CinnabarxTestNextIncrModel methodsFor: 'as yet unclassified' stamp: 'strick 3/13/2006 08:25'!
testDoTranslate

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.

	f translateClassesIncr:  #( CinnabarTestCollections Association LookupKey ReadOnlyVariableBinding "ByteString String" ).


! !


!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/15/2006 09:03'!
literalArray: litArray 

	"--- This has been made to work for any array type with no fixed slots, by using the litArray's class name.
	The main danger is circular pointers or pointers to everything getting in here.
	Hope that doesn't happen. ---"

	| n z |

	litArray class allInstVarNames size > 0 ifTrue: [ 
		^ self unimplemented: 'LiteralArray with instance vars: ', litArray class name.
	].

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

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

	"BUG: expecting the litArray class to be precompiled in the foundation"
	myInits write: z , '= BasicNewColon(PASS_VAT  & C_',litArray class name,'_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/15/2006 08:59'!
literal: x 
	x class == SmallInteger
		ifTrue: [^ 'OopFromNum(' , x asString , ')'].
	x class == Character
		ifTrue: [^ 'OopFromHeader(&CharInstances[' , x codePoint asString , '])'].
	x class == Array
		ifTrue: [^ self literalArray: x].
	x class == ByteString
		ifTrue: [^ self literalByteString: x].
	x class == ByteSymbol
		ifTrue: [^ self literalByteSymbol: x].

	"any array of bytes"
	(x class isVariable and: [ x class isBytes ] ) ifTrue: [^ self literalArray: x].
	"any array of words"
	(x class isVariable and: [ x class isWords ] ) ifTrue: [^ self literalArray: x].

	^ self unimplemented: 
		'Literal(* ',  x class asString, ' : ' , (self escapeStringForC: x asString), ' *)'.
! !

!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/15/2006 09:22'!
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 := CinnabarxFirstPass 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: 'ReportPrimitiveFailed(',
				method primitive asString, ' , "', funcName, '" );'.
		body write: '#else'.
		body write: 'ReportPrimitiveMissing(',
				method primitive asString, ' , "', funcName, '" );'.
		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/12/2006 21:50'!
visitLiteralVariableNode: aNode 

	| obj |
	obj := aNode key value.
	obj
		ifKindOf: Class
		thenDo: [:cls | 

				| n z |
				n := self serial asString.
				z := 'cls_' , n, '_', cls name.
	body write: '#ifdef C_',cls name,'_TypeNumber'.
	body write: 'oop ', z,'= OopFromHeader(&C_' , cls name , '_ClsObj);'.
	body write: '#else'.
	body write: 'Type* ', z,'_typePtr= TypeTable[ OopToHeader(', (self literalByteSymbol: cls name), ') ->hash() ];'.
	body write: 'if ( !! ', z, '_typePtr ) {'.
	self unimplemented: 'Missing From TypeTable: ', cls name.
	body write: '}'.
	body write: 'oop ', z,'= OopFromHeader( ',z,'_typePtr );'.
	body write: '#endif'.

			self addClassToFoundation: cls.
			^ z
		].

	(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: #literalArrayOfBytes:!
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:!
CinnabarTestFib removeSelector: #ttestNonSmallSum!
Smalltalk removeClassNamed: #CinnabarCodeStream!
Smalltalk removeClassNamed: #CinnabarGenClasses!
Smalltalk removeClassNamed: #CinnabarGenMethods!
Smalltalk removeClassNamed: #CinnabarUnitTests!