WriteStream subclass: #CinnabarCodeStream
	instanceVariableNames: 'depth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!CinnabarCodeStream commentStamp: '<historical>' prior: 0!
CinnabarCodeStream is a WriteStream buffer for writing C++ code for Cinnabar with nice indentation.

Use #write: to append a line.  If the line ends in '{' or '}' then the indentation will be adjusted
accordingly.

The #saveToUnixFile: method will convert squeak CR to unix LF line terminators.
!


!CinnabarCodeStream methodsFor: 'as yet unclassified' stamp: 'strick 12/18/2005 10:29'!
contentsForUnix
	^ self contents
		copyReplaceAll: String cr
		with: String lf
		asTokens: false
! !

!CinnabarCodeStream methodsFor: 'as yet unclassified' stamp: 'Ryan 12/13/2005 11:55'!
initialize

	depth := 0.! !

!CinnabarCodeStream methodsFor: 'as yet unclassified' stamp: 'strick 12/19/2005 21:15'!
saveToUnixFile: filename 
	| fileStream |
	fileStream := StandardFileStream forceNewFileNamed: filename.
	[fileStream nextPutAll: "self contents"
	self contentsForUnix]
		ensure: [fileStream close]! !

!CinnabarCodeStream methodsFor: 'as yet unclassified' stamp: 'strick 12/19/2005 21:13'!
write: aString 
	"a Pretty-Writer for generating C code -- writes one line. 
	* The last character in the string can be ${ or $} to guide nesting.
	"
	"set tail to last char, or to something bogus like $ if empty"
	| n tail |
	n := aString size.
	n > 0
		ifTrue: [tail := aString at: n]
		ifFalse: [tail := $$].
	$} = tail
		ifTrue: [depth := depth - 1].
	""
	self assert: depth >= 0.
	""
	1
		to: depth
		do: [:i | self nextPutAll: '    '].
	self nextPutAll: aString;
		 nextPut: Character lf.
	${ = tail
		ifTrue: [depth := depth + 1]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CinnabarCodeStream class
	instanceVariableNames: ''!

!CinnabarCodeStream class methodsFor: 'as yet unclassified' stamp: 'strick 12/16/2005 00:50'!
new

	^ (CinnabarCodeStream with: String new) initialize.! !


Object subclass: #CinnabarFirstPass
	instanceVariableNames: 'blockParents blockStack method class blockIsFlat specialFlatCases captures generator selfIsCaptured'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 16:56'!
howManyArgsForSelector: aString 
	^ aString first isAlphaNumeric
		ifTrue: [aString
				inject: 0
				into: [:z :c | c = $:
						ifTrue: [z + 1]
						ifFalse: [z]]]
		ifFalse: ["binary operators have one receiver and 1 argumnet"
			1]! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 21:35'!
initialize
	blockParents := Dictionary new.
	blockStack := OrderedCollection new.
	blockIsFlat := Dictionary new.
	"captures : aScope -> aDictionary : aString -> true"
	captures := IdentityDictionary new.
	specialFlatCases := IdentitySet new.
	specialFlatCases 
		 add: #ifTrue:;
		 add: #ifFalse:;
		 add: #ifNil:;
		 add: #ifNotNil:;
		 add: #ifTrue:ifFalse:;
		 add: #ifFalse:ifTrue:;
		 add: #ifNil:ifNotNil:;
		 add: #ifNotNil:ifNil:;
		 add: #to:by:do:;
		 add: #to:do: ;
	 	 add: #whileFalse ;
		 add: #whileTrue .
! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 16:49'!
rememberCapturedVariable: aString inScope: aScope 
	"what's the standard, normal way of implementing a double-dictionary?"
	| d |
	"Transcript cr show: '// rememberCapturedVariable: ' , aString , ' inScope: ' , aScope asString."
	self
		assert: (aString class == ByteString
				or: [aString class == ByteSymbol]).
	d := captures
				at: aScope
				ifAbsent: [captures at: aScope put: Dictionary new.
					captures at: aScope].
	d at: aString put: true! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 16:48'!
testCapturedVariable: aString inScope: aScope 
	| d |
	"Transcript cr show: '// testCapturedVariable: ' , aString , ' inScope: ' , aScope asString."
	d := captures
				at: aScope
				ifAbsent: [^ false].
	^ d
		at: aString
		ifAbsent: [^ false]! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 14:35'!
visitAssignmentNode: anAssignmentNode 
	anAssignmentNode variable acceptVisitor: self.
	anAssignmentNode value acceptVisitor: self! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 02:18'!
visitBlockNode: aBlockNode 


	| shouldBeTheBlockNode |

	"is this Flat? We should put this in visitMessageNode"
	"blockIsFlat at: aBlockNode put: false."

" (blockIsFlat at: aBlockNode ifAbsent: [false]) ifTrue: [ self break ]."
	(blockIsFlat at: aBlockNode ifAbsent: [false]) ifTrue: [
		"self break" "----------- will need to push our args & temps up higher"
	].

	"remember this node's parent"
	blockParents at: aBlockNode put: (
		blockStack size > 0 ifTrue: [blockStack last] 
	).

	"push the blockNode & recurse "
	blockStack addLast: (blockStack size == 0 ifTrue: [method] ifFalse: [aBlockNode]).

	aBlockNode statements do: [ :aNode | 
		aNode acceptVisitor: self
	].

	"pop ourself back off "
	shouldBeTheBlockNode := blockStack removeLast.

	blockStack size == 0 ifTrue: [
		self assert: (shouldBeTheBlockNode==method) .
	] ifFalse: [
		self assert: (shouldBeTheBlockNode==aBlockNode) .
	]

! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 17:06'!
visitBraceNode: aBraceNode 
	aBraceNode elements
		do: [:aNode | aNode acceptVisitor: self]! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 01:45'!
visitCascadeNode: aCascadeNode 

	aCascadeNode receiver acceptVisitor: self.

	aCascadeNode messages
		do: [:m | "
			--- Create a temporary MessageNode, so we can set its receiver
			correctly. Necessary because the receiver in the Cascade's
			MessageNodes is nil.
			The result of the last message in the cascade is our result. ---
			"
			self visitMessageNode: (MessageNode new 
							receiver: aCascadeNode receiver;
							 selector: m selector;
							 arguments: m arguments)].! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/29/2005 02:35'!
visitLiteralNode: aLiteralNode 

	nil.! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/29/2005 02:45'!
visitLiteralVariableNode: aLiteralVariableNode 

	nil.! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 21:37'!
visitMessageNode: aMessageNode 
	| selector n |
	selector := aMessageNode selector.
	"Usually selector is SelectorNode, but occasionally is just a ByteSymbol."
	selector class == SelectorNode
		ifTrue: ["convert Node to Symbol"
			selector := selector key].
	"are any args a block to be flattened? only for specialFlatCases."
	(specialFlatCases includes: selector)
		ifTrue: [
				aMessageNode receiver class == BlockNode
						ifTrue: [ blockIsFlat at: aMessageNode receiver put: true ].
				aMessageNode arguments
					do: [:arg | arg class == BlockNode
						ifTrue: [ blockIsFlat at: arg put: true]
					]
		].
	aMessageNode receiver acceptVisitor: self.

	n := (self howManyArgsForSelector: selector).
	aMessageNode special ifNotNil: [
		(0 < aMessageNode special) & (aMessageNode special < 11) ifTrue: [ n := 2 ].
	].
	n > aMessageNode arguments size ifTrue: [ n := aMessageNode arguments size ].

	1 to: n
		do: [:i | 
			| node | 
			node := aMessageNode arguments at: i.
			node
				ifNotNil: [node acceptVisitor: self]]
! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 18:01'!
visitMethodNode: aMethodNode forClass: aClass for: aGen 

	"generator needed for serial"
	generator := aGen.
	method := aMethodNode.
	class := aClass.
	aMethodNode block acceptVisitor: self! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/29/2005 02:33'!
visitParseNode: aParseNode

	self error: 'FirstPass: Visiting unimplemented node type ', aParseNode asString
! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 12/29/2005 02:30'!
visitReturnNode: aReturnNode

	aReturnNode expr acceptVisitor: self
! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 02:19'!
visitTempVariableNode: v 
	v name = 's' & false " & (method selector = #primitiveError:)"
		ifTrue: [self break].
	blockStack size
		to: 1
		by: -1
		do: [:i | 
			| b | 
			b := blockStack at: i.
			b arguments
				do: [:arg | "arg name = v name" arg == v
						ifTrue: [^ self]].
			b temporaries
				ifNotNil: [b temporaries
						do: [:arg | "arg name = v name" arg == v
								ifTrue: [^ self]]].
			(blockIsFlat keys includes: b)
				ifFalse: ["We did not find it in the bottom scope or any flat scopes
					that merge with it -- so we now continue climbing up
					into separate scopes looking for the scope in which to
					mark the variable as captured."
					i - 1
						to: 1
						by: -1
						do: [:ii | 
							| bb | 
							"use ii and bb in this inner loop. This inner loop
							will not return back to the outer loop -- it will
							remember the capture, and answer self."
							bb := blockStack at: ii.
							bb arguments
								do: [:arg | "arg name = v name" arg == v
										ifTrue: [self rememberCapturedVariable: v name inScope: bb.
											^ self]].
							bb temporaries
								ifNotNil: [bb temporaries
										do: [:arg | "arg name = v name" arg == v
												ifTrue: [self rememberCapturedVariable: v name inScope: bb.
													^ self]]].
							blockIsFlat keys includes: bb].
					"special case for weird loop termination *LimiT vars"
					(v name endsWith: 'LimiT')
						ifTrue: [^ nil].
					self assert: nil == 'Should not be reached']]! !

!CinnabarFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 1/1/2006 17:50'!
visitVariableNode: aVariableNode 

	nil.! !


!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 1/2/2006 18:18'!
blockIsFlat: anObject

	^ blockIsFlat at: anObject ifAbsent: [^false]! !

!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 03:19'!
blockParents
	"Answer the value of blockParents"

	^ blockParents! !

!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 03:19'!
blockParents: anObject
	"Set the value of blockParents"

	blockParents _ anObject! !

!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 03:19'!
blockStack
	"Answer the value of blockStack"

	^ blockStack! !

!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 03:19'!
blockStack: anObject
	"Set the value of blockStack"

	blockStack _ anObject! !

!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 20:26'!
class: anObject
	"Set the value of class"

	class _ anObject! !

!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 03:19'!
method
	"Answer the value of method"

	^ method! !

!CinnabarFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 03:19'!
method: anObject
	"Set the value of method"

	method _ anObject! !


Object subclass: #CinnabarGenClasses
	instanceVariableNames: 'done headerCode instanceCode initCode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!CinnabarGenClasses commentStamp: 'strick 2/13/2006 02:11' prior: 0!
CinnabarGenClasses translates Smalltalk classes into C++ header files, to run on the Cinnabar Virtual Machine.

Try it thus:

   	CinnabarGenClasses new run

(CinnabarGenMethods translates the method definitions)

 !


!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 12/19/2005 20:45'!
addCategoryAndSubclasses: aCategoryName 
	(SystemOrganization listAtCategoryNamed: aCategoryName)
		do: [:eachClass | self addClassAndSubclasses: (Smalltalk at: eachClass)]! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 2/12/2006 19:25'!
addCategoryMatchAndSubclasses: aCategoryPattern

	SystemOrganization categories 
		select: [ :eachCategory | aCategoryPattern match: eachCategory ]
		thenDo: [ :selectedCategory |
			(SystemOrganization listAtCategoryNamed: selectedCategory)
				do: [:eachClass | self
						addClassAndSubclasses: (Smalltalk at: eachClass)]
				]! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 12/19/2005 21:03'!
addCategoryPattern: aCategoryPattern 
	SystemOrganization categories
		select: [:eachCategory | aCategoryPattern match: eachCategory]
		thenDo: [:selectedCategory | (SystemOrganization listAtCategoryNamed: selectedCategory)
				do: [:eachClass | self
						addClass: (Smalltalk at: eachClass)]]! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 12/18/2005 11:14'!
addClassAndSubclasses: aClass 
	self addClass: aClass.
	aClass subclasses do: [ :sub | self addClassAndSubclasses: sub ]
! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 16:50'!
addClass: aClass 
	"*** quick recursion stopper ***"
	| superC className superClassName clsObjName n typeObjName |
	(done includes: aClass)
		ifTrue: [^ self].
	"
	*** recurse for superclasses ***
	"
	className := self translateSpacesToDollars: aClass name.
	superC := aClass superclass.
	superC
		ifNil: [superClassName := 'Header']
		ifNotNil: [superClassName := 'C_'
						, (self translateSpacesToDollars: superC name).
			self addClass: superC].
	"*** another recursion stopper (because supers have metas) ***"
	(done includes: aClass)
		ifTrue: [^ self].
	"*** about to emit aClass, so mark it done. ***"
	done add: aClass.
	"
	*** struct defintion ***
	"
	n := done size asString.
	headerCode write: '#define   C_' , className , '_TypeIndex    ' , n.
	headerCode write: 'struct C_' , className , ' : public ' , superClassName , ' /*' , aClass kindOfSubclass , '*/ {'.
	(aClass instanceVariablesString findTokens: ' ')
		do: [:var | headerCode write: 'oop  f_' , var , ';'].
	headerCode write: '/*' , aClass instSize asString , '*/ }'.
	headerCode write: ';'.
	"curious"
	(('*$class' match: className)
			and: [11 ~= aClass instSize])
		ifTrue: [headerCode write: '/*EXTRA CLASS VAR NAMES: ' , aClass instVarNames asString , '*/'].
	""
	clsObjName := 'C_' , className , '_ClsObj'.
	typeObjName := 'C_' , className , '_TypeObj'.
	headerCode write: 'extern Type ' , typeObjName , ';'.
	(className endsWith: '$class') ifTrue: [
		"cannot use ClassDescription of Metaclass yet (due to category abuse)"
		headerCode write: 'extern struct /*C_Metaclass*/C_Class ' , clsObjName , ';'.
	] ifFalse: [
		headerCode write: 'extern struct C_', className, '$class ' , clsObjName , ';'.
	].
	"
	*** instance object ***
	"
	instanceCode write: 'Type ' , typeObjName , ';'.
	(className endsWith: '$class') ifTrue: [
		"cannot use ClassDescription of Metaclass yet (due to category abuse)"
		instanceCode write: 'struct /*C_Metaclass*/C_Class ' , clsObjName , ';'.
	] ifFalse: [
		instanceCode write: 'struct C_', className, '$class ' , clsObjName , ';'.
	].
	"
	*** initialization code ***
	"
	initCode write: 'TypeTable[' , n , ']= & ' , typeObjName , ';'.
	initCode write: ''.
	"following is WRONG -- TODO make a TypeIndex for Type"
	initCode write: typeObjName , '.setTypeIndex( Type_TypeIndex );'.
	initCode write: typeObjName , '.setFlags( Header::ETERNAL | Header::SHARED );'.
	initCode write: typeObjName , '.setHash( ' , n , ' );'.
	initCode write: typeObjName , '.typeTableIndex = ' , n , ';'.
	initCode write: typeObjName , '.name = "' , className , '";'.
	initCode write: typeObjName , '.superType = & ' , superClassName , '_TypeObj ;'.
	initCode write: typeObjName , '.thisClass = & ' , clsObjName , ';'.
	aClass isBits
		ifTrue: [initCode write: typeObjName , '.instanceFlags  |=  Header::BITS ;'].
	aClass isBytes
		ifTrue: [initCode write: typeObjName , '.instanceFlags  |=  Header::BYTES ;'].
	aClass isVariable
		ifTrue: [initCode write: typeObjName , '.instanceFlags  |=  Header::INDEXED ;'.
			self assert: aClass instSize < 8.
			aClass instSize > 0
				ifTrue: [initCode write: typeObjName , '.instanceFlags  |=  Header::FIXED_8 ;']].
	initCode write: typeObjName , '.fixedSize = ' , aClass instSize asString , ';'.
	"initCode write: '// ' , aClass allInstVarNames asString."
	initCode write: ''.
	(className endsWith: '$class') ifTrue: [
		"cannot use ClassDescription of Metaclass yet (due to category abuse)"
		initCode write: clsObjName , '.setTypeIndex( /*C_Metaclass_TypeIndex*/C_Class_TypeIndex );'.
	] ifFalse: [
		initCode write: clsObjName , '.setTypeIndex( C_',className,'$class_TypeIndex );'.
	].
	initCode write: clsObjName , '.setFlags( Header::ETERNAL | Header::SHARED );'.
	initCode write: clsObjName , '.setHash( ' , n , ' );'.
	"we use the unused 'category' field to point back to the Type."
	initCode write: clsObjName , '.f_category = OopFromHeader( & ' , typeObjName , ');'.
	initCode write: ''.
	initCode write: ''.
	initCode write: ''.
	"
	*** recurse for aClass's class ***
	"
	self addClass: aClass class! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 2/13/2006 02:15'!
initialize
	done := Set new.

	"reserve special slots"
	done add: #num.
	done add: #type.
	done add: #func.
	done add: #symbol.

	headerCode := CinnabarCodeStream new.
	instanceCode := CinnabarCodeStream new.
	initCode := CinnabarCodeStream new! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 17:12'!
run
	"
	CinnabarGenClasses new run.
	"
	self addCategoryPattern: 'Kernel-*';
		 addCategoryPattern: 'Collections-*'.
	CinnabarGenMethods new generateClass: CinnabarTestApple toFileName: '_CinnabarTestApple.cc' for: self.
	CinnabarGenMethods new generateClass: CinnabarTestFib toFileName: '_CinnabarTestFib.cc' for: self.
	CinnabarGenMethods new generateClass: Character toFileName: '_Character.cc' for: self.
	CinnabarGenMethods new generateClass: Set toFileName: '_Set.cc' for: self.

	CinnabarGenMethods new generateClass: ProtoObject toFileName: '_ProtoObject.cc' for: self.
true ifTrue:[
	CinnabarGenMethods new generateClass: Object toFileName: '_Object.cc' for: self.
].

	self 
		 saveGeneratedFiles.
! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 12/21/2005 01:42'!
saveGeneratedFiles
	initCode write: 'TypeTableNext=' , (done size + 1) asString, ';'.
	headerCode saveToUnixFile: '_gen_header.h'.
	instanceCode saveToUnixFile: '_gen_objects.h'.
	initCode saveToUnixFile: '_gen_inits.h'! !

!CinnabarGenClasses methodsFor: 'as yet unclassified' stamp: 'strick 12/18/2005 17:57'!
translateSpacesToDollars: aString 
	"self new translateSpacesToDollars: 'Some class'"
	^ aString
		copyReplaceAll: ' '
		with: '$'
		asTokens: false! !


Object subclass: #CinnabarGenMethods
	instanceVariableNames: 'methodNum stMethodsToCbar nextSerialNumber declarations initializations body specialCases firstPass blockStack method contextStack saveStack theClass captureStack master'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!CinnabarGenMethods commentStamp: '<historical>' prior: 0!
CinnabarGenMethods translates Smalltalk methods into C++ code, to run on the Cinnabar Virtual Machine.

(CinnabarGenClasses translates the class definitions)

 !


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

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 1/2/2006 18:20'!
flattenBlockNode: aBlockNode 
	| collection n z i csize |
	(firstPass blockIsFlat: aBlockNode)
		ifTrue: [self enterScope: aBlockNode. self comment: 'ENTER(FLAT)' ]
		ifFalse: [self comment: 'ENTER(NOT)'].
	collection := aBlockNode statements.
	n := self serial asString.
	z := 'flat_' , n.
	body write: 'oop ' , z , '= OopNil;'.
	body write: '{'.
	i := 1.
	csize := collection size.
	collection
		do: [:aNode | 
			| nodeResult | 
			nodeResult := aNode acceptVisitor: self.
			i = csize
				ifTrue: [body write: z , '= ' , nodeResult asString , ';'].
			i := i + 1].
	body write: '}'.
	self comment: 'EXIT'.
	(firstPass blockIsFlat: aBlockNode)
		ifTrue: [self exitScope: aBlockNode].
	^ z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 1/2/2006 16:50'!
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: 'Func_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 12/23/2005 21:52'!
literalByteString: lit 
	| n z |
	n := self serial asString.
	z := 'str_' , n.
	declarations write: 'static oop ' , z , ';'.
	initializations write: z , '= OopLiteralByteString(PASS_VAT  "'
			, (self escapeStringForC: lit asString) , '");'.
	initializations write: 'assert(' , z , ');'.
	^ z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 1/2/2006 15:57'!
literalByteSymbol: lit 
	| n z |
	n := self serial asString.
	z := 'sym_' , n.
	declarations write: 'static oop ' , z , ';'.
	initializations write: z , '= OopFromHeader( InternString( "'
			, (self escapeStringForC: lit) , '") );'.
	initializations write: 'assert(' , z , ');'.
	^ z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/13/2006 01:29'!
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].
	body write: 'SetVatErrorString(PASS_VAT  "Literal Type Not Implemented: ' , x class asString , ' : '
			, (self escapeStringForC: x asString) , '");'.
	body write: 'goto ERROR;'.
	^ 'OopNOTREACHED'! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 12/31/2005 21:09'!
popFunction

	declarations write: body contents.
	body := saveStack removeLast! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 12/31/2005 21:10'!
pushFunction
	saveStack addLast: body.
	body := CinnabarCodeStream new.! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 1/1/2006 17:14'!
resetFunction
	body := CinnabarCodeStream new.


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

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/13/2006 01:36'!
unimplemented: x 

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

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 1/1/2006 18:08'!
visitAssignmentNode: anAssignmentNode 
	| var val |
	self comment: anAssignmentNode.
	var := anAssignmentNode variable acceptVisitor: self.
	val := anAssignmentNode value acceptVisitor: self.
	body write: var , ' = ' , val , ';'.
	^ var! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/13/2006 03:35'!
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: ''.
	initializations write: 'Obj_' , funcName , ' . entry = (FUNC*) ' , funcName , ';'.
	initializations write: 'Obj_' , funcName , ' . name = Name_' , funcName , ';'.
	initializations write: 'Obj_' , funcName , ' . numArgs = ' , argVars size asString , ';'.
	initializations 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->self;'.
	body write: 'oop octx_' , lastN , '= closure->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 , '->function= OopFromHeader( & Obj_' , funcName , ' );'.
	contextStack size > 0
		ifTrue: [body write: z , '->context= octx_' , contextStack last , ';']
		ifFalse: [body write: z , '->context= 0;'].
	body write: z , '->self= v_self;'.
	^ 'o' , z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 1/2/2006 16:58'!
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: 'Func_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 12/23/2005 06:41'!
visitByteSymbol: aByteSymbol 
	^ aByteSymbol! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 12/23/2005 07:17'!
visitCascadeNode: aCascadeNode 
	| result |
	result := 'OopNil'.
	aCascadeNode messages
		do: [:m | "
			--- Create a temporary MessageNode, so we can set its receiver
			correctly. Necessary because the receiver in the Cascade's
			MessageNodes is nil.
			The result of the last message in the cascade is our result. ---
			"
			result := self visitMessageNode: (MessageNode new receiver: aCascadeNode receiver;
							 selector: m selector;
							 arguments: m arguments)].
	^ result! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/13/2006 01:23'!
visitLiteralNode: aLiteralNode 
	| lit |

	lit := aLiteralNode eval.

	^ self literal: lit! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/13/2006 01:37'!
visitLiteralVariableNode: aNode 

	| obj |
	obj := aNode key value.
	obj
		ifKindOf: Class
		thenDo: [:cls | 
			master addClass: 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

			! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/18/2006 21:28'!
visitMessageNode: aMessageNode 
	| n z msgSelector msgReceiver argList funcType |

"<< These are the values of 'special' -- MessageNode::MacroEmitters --
 #(#emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitWhile:on:value: #emitWhile:on:value: #emitWhile:on:value: #emitWhile:on:value: #emitToDo:on:value: #emitToDo:on:value: #emitCase:on:value: #emitCase:on:value: #emitIfNil:on:value: #emitIfNil:on:value: #emitIf:on:value: #emitIf:on:value:)
>>"
	self comment: aMessageNode.
	msgSelector := aMessageNode selector acceptVisitor: self.
	"*** Check to see if the message is a special case before you go any
	further "
	(specialCases includesKey: msgSelector)
		ifTrue: [^ self
				perform: (specialCases at: msgSelector)
				with: aMessageNode].
	"*** If special messages not handled yet, it is an error."
	aMessageNode special
		ifNotNil: [aMessageNode special > 0
				ifTrue: [body write: '//UNIMPLEMENTED: ' , msgSelector asString , ' ::SQUEAK SPECIAL CASE:: ' , aMessageNode special asString.
					self comment: '$RCVR: ' , aMessageNode receiver asString.
					aMessageNode arguments
						do: [:x | self comment: '$ARG ' , x asString].
					body write: 'SetVatErrorString(PASS_VAT  "//UNIMPLEMENTED: ' , msgSelector asString , ' ::SQUEAK SPECIAL CASE:: ' , aMessageNode special asString , '" );'.
					body write: 'goto ERROR;'.
					^ 'OopNOTREACHED']].
	"*** Normal messages continue here."
	n := self serial asString.
	z := 'send_' , n.
	declarations write: 'static SenderCache cache' , n , ';'.
	declarations write: 'static Symbol* selector' , n , ';'.
	initializations write: 'InsertSenderCache( &cache' , n , ' );';
		 write: 'selector' , n , ' = InternString("' , msgSelector , '"); '.
	body write: 'oop ' , z , '= OopNil;'.
	body write: '{'.
	msgReceiver := aMessageNode receiver acceptVisitor: self.
	""
	"body write: '// ***SEND*** ', z, ' := ',msgReceiver, ' ', msgSelector, ' ...'."
	""
	argList := self passArgumentVariables: aMessageNode arguments.
	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! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 11/28/2005 00:53'!
visitParseNode: aParseNode

	self error: 'Visiting unimplemented node type ', aParseNode asString
! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 12/17/2005 00:34'!
visitReturnNode: aReturnNode

	body write: 'return ', (aReturnNode expr acceptVisitor: self) , ';'.

	^ 'OopNOTREACHED'.! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 11/28/2005 01:54'!
visitSelectorNode: aSelectorNode

	| cCode |

	cCode := aSelectorNode key asString.

	^ cCode.! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/12/2006 20:40'!
visitTempVariableNode: aTempVariableNode 
	| var j |
	var := aTempVariableNode name.

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

	j := contextStack size.
	captureStack size
		to: 1
		by: -1
		do: [:i | (captureStack at: i) size > 0
				ifTrue: [((captureStack at: i)
							includes: var)
						ifTrue: [^ 'ctx_' , (contextStack at: j) asString , '->v_' , var , '/*level' , i asString , '*/'].
					j := j - 1]].
	^ 'v_' , var , '/*tempVar*/'! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 2/16/2006 02:40'!
visitVariableNode: aVariableNode 
	| var |
	var := aVariableNode name.
	"-- check first for reserved names --"
	var = 'true'
		ifTrue: [^ 'OopTrue'].
	var = 'false'
		ifTrue: [^ 'OopFalse'].
	var = 'nil'
		ifTrue: [^ 'OopNil'].
	var = 'self'
		ifTrue: [^ 'v_self'].
	var = 'thisContext'
		ifTrue: [^ self unimplemented: 'thisContext' ].

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


!CinnabarGenMethods methodsFor: 'as yet unclassified' stamp: 'strick 2/13/2006 03:12'!
genCbarClassDefinition: aClass 
	"
	self new genCbarClassDefinition: LiteralNode 
	"
	| cCode superC superClassNameForCxx instVars |
	cCode := ''.
	superC := aClass superclass.
	superC
		ifNil: [superClassNameForCxx := 'Header']
		ifNotNil: [superClassNameForCxx := 'C_' , (self tr: superC name).
			cCode := cCode , ' '
			"(self genCbarClassDefinition: superC)"].
	instVars := ''.
	(aClass instanceVariablesString findTokens: ' ')
		do: [:var | instVars := instVars , '   oop  f_' , var , '; '].
	cCode := cCode , '
#ifndef C_' , (self tr:  aClass name) , '_TypeIndex
struct C_' , (self tr: aClass name) , ' : public ' , superClassNameForCxx , ' { // ' , aClass kindOfSubclass , '
' , instVars , '
};
#endif
'.
	^ cCode! !

!CinnabarGenMethods methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 17:08'!
genCbarFooter: aSmallTalkClass 
	| cCode cCode2 |
	cCode2 := ''.
	cCode := '

extern "C"

void Init_' , (self tr: aSmallTalkClass name) , '()
{
	DECLARE_VAT_FROM_EXPR(NULL); // TODO: should we pass "shared vat" to Init?
 	const char* TypeSupers[] = { "ProtoObject", "Object", "' , aSmallTalkClass name , '", NULL };
	// OLD --- Type* type = FindOrDefineType( TypeSupers );
	Type* type= FindType( "',aSmallTalkClass name,'" );
	assert(type);
	Type* typeType= FindType( "',aSmallTalkClass name,'$class" );
	assert(typeType);

'.


	aSmallTalkClass methodDict keys
		do: [:methodKey | cCode2 := ' 
	{
		Symbol* sym = InternString("' , methodKey , '"); 
		type->insertFunction(sym, (FUNC*)'
						, (stMethodsToCbar at: methodKey) , '); 
	}
' , cCode2].

	"possible bug: we need separte stMethodsToCbar for class methods"

	aSmallTalkClass class methodDict keys
		do: [:methodKey | cCode2 := ' 
	{
		Symbol* sym = InternString("' , methodKey , '"); 
		typeType->insertFunction(sym, (FUNC*)'
						, (stMethodsToCbar at: methodKey) , '); 
	}
' , cCode2].


	cCode := cCode , cCode2.
	cCode := cCode , initializations contents , '
}
'.
	^ cCode! !

!CinnabarGenMethods methodsFor: 'as yet unclassified' stamp: 'strick 2/13/2006 03:41'!
genCbarFromClass: aClass 
	| cCode |
	declarations := CinnabarCodeStream new.
	cCode := ''.
	aClass methodDict keys
		do: [:methodKey | 
			methodNum := methodNum + 1.
			stMethodsToCbar at: methodKey put: 'Func_'
					, (self tr: aClass name) , '_'
					, (self convertSelectorToCbar: methodKey) , '_' , methodNum asString].
	aClass methodDict keys
		do: [:methodKey | cCode := cCode , '
'
						, (self
								genCbarFromString: (aClass sourceMethodAt: methodKey)
								class: aClass)].
	^ declarations contents , cCode
! !

!CinnabarGenMethods methodsFor: 'as yet unclassified' stamp: 'strick 12/24/2005 16:51'!
genCbarFromString: smallTalkMethodString class: aClass

	^ self generateMethod: (Parser new parse: smallTalkMethodString class: aClass)
	forClass: aClass! !

!CinnabarGenMethods methodsFor: 'as yet unclassified' stamp: 'strick 2/13/2006 03:06'!
genCbarHeader: aClass 

	^ '#include "cinnabar.h"

' , (self genCbarClassDefinition: aClass), (self genCbarClassDefinition: aClass class). 
! !

!CinnabarGenMethods methodsFor: 'as yet unclassified' stamp: 'strick 12/23/2005 08:41'!
identifier: aString 
	"
	self new identifier: 'foo bar'
	
	Optimize: just return the string if all AlphaNumeric.
	Otherwise rebuild the string.
	"
	(aString
			inject: true
			into: [:z :c | z
					and: [c isAlphaNumeric]])
		ifTrue: [^ aString].
	^ aString
		inject: ''
		into: [:b :c | c isAlphaNumeric
				ifTrue: [b := b
								, (ByteString with: c)]
				ifFalse: [b := b , '$' , c codePoint asString , '$']]! !

!CinnabarGenMethods methodsFor: 'as yet unclassified' stamp: 'strick 2/13/2006 03:14'!
tr: aName

	^CinnabarGenClasses new translateSpacesToDollars: aName! !


!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:32'!
messageAdd: aMessageNode

	^self message: aMessageNode binOp: 'OopAdd'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 1/2/2006 14:23'!
messageBasicAtPut: aMessageNode 
	| n z rcvr arg1 arg2 |
	n := self serial asString.
	z := 'at_' , n.
	rcvr := aMessageNode receiver acceptVisitor: self.
	arg1 := (aMessageNode arguments at: 1)
				acceptVisitor: self.
	arg2 := (aMessageNode arguments at: 2)
				acceptVisitor: self.
	body write: 'oop ' , z , '= OopBasicAtPut(PASS_VAT  ' , rcvr , ' , ' , arg1 , ' , ' , arg2 , ' );'.
	body write: 'if ( !! ' , z , ' ) goto ERROR;'.
	^ z! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 1/2/2006 14:13'!
messageBasicAt: aMessageNode 
	| n z rcvr arg1 |
	n := self serial asString.
	z := 'at_' , n.
	rcvr := aMessageNode receiver acceptVisitor: self.
	arg1 := (aMessageNode arguments at: 1)
				acceptVisitor: self.
	body write: 'oop ' , z , '= OopBasicAt(PASS_VAT  ' , rcvr , ' , ' , arg1 , ' );'.
	body write: 'if ( !! ' , z , ' ) goto ERROR;'.
	^ z! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 18:16'!
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 , '= OopBasicNewColon(PASS_VAT  ' , rcvr ,' , ', arg1, ' );'.
	body write: 'if ( !! ' , z , ' ) goto ERROR;'.
	^ z! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 18:17'!
messageBasicNew: aMessageNode 
	| n z rcvr |

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

	rcvr := aMessageNode receiver acceptVisitor: self.

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

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 18:17'!
messageBasicSize: aMessageNode 
	| n z rcvr |
	n := self serial asString.
	z := 'size_' , n.
	rcvr := aMessageNode receiver acceptVisitor: self.
	body write: 'oop ' , z , '= OopBasicSize(PASS_VAT  ' , rcvr , ' );'.
	body write: 'if ( !! ' , z , ' ) goto ERROR;'.
	^ z! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/12/2005 17:37'!
messageBitAnd: aMessageNode

	^self message: aMessageNode binOp: 'OopBitAnd'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/12/2005 17:37'!
messageBitOr: aMessageNode

	^self message: aMessageNode binOp: 'OopBitOr'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/12/2005 19:35'!
messageBitShift: aMessageNode

	^self message: aMessageNode binOp: 'OopBitShift'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/12/2005 17:38'!
messageBitXor: aMessageNode

	^self message: aMessageNode binOp: 'OopBitXor'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/12/2005 17:17'!
messageEQEQ: aMessageNode

	^self message: aMessageNode binOp: 'OopEQEQ'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:35'!
messageEQ: aMessageNode

	^self message: aMessageNode binOp: 'OopEQ'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 18:11'!
messageErrorColon: aMessageNode 
	| rcvr arg1 |
	rcvr := aMessageNode receiver acceptVisitor: self.
	arg1 := aMessageNode arguments first acceptVisitor: self.
	body write: 'SetVatErrorString(PASS_VAT  ' , arg1 , ' );'.
	body write: 'AddVatErrorString(PASS_VAT  "receiver object is:" );'.
	body write: 'AddVatErrorString(PASS_VAT  ' , rcvr , ' );'.
	body write: 'goto ERROR;'.
	^ 'OopNOTREACHED'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:36'!
messageGE: aMessageNode

	^self message: aMessageNode binOp: 'OopGE'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:35'!
messageGT: aMessageNode

	^self message: aMessageNode binOp: 'OopGT'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 2/12/2006 20:18'!
messageIfElse: aMessageNode receiverIs: predicate 
	| n rcvr arg1 arg2 z |
	"self assert: aMessageNode arguments size == 2. WRONG -- it may be 1."
	n := self serial asString.
	z := 'if_' , n.
	rcvr := aMessageNode receiver acceptVisitor: self.
	body write: 'oop ' , z , '= OopNil; // ' , aMessageNode selector asString , '//'.
	body write: 'if ( '
			, (predicate value: rcvr) , ' ) {'.
	arg1 := self flattenBlockNode: aMessageNode arguments first.
	body write: z , '=' , arg1 , ';'.
	body write: '}'.
	body write: 'else {'.
	( aMessageNode arguments size > 1 ) ifTrue: [
		arg2 := self flattenBlockNode: aMessageNode arguments second.
		body write: z , '=' , arg2 , ';'.
	] ifFalse: [
		body write: z , '=' , rcvr , ';'.
	].
	body write: '}'.
	^ z! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 16:14'!
messageIfFalseIfTrue: aMessageNode 
	^ self
		messageIfElse: aMessageNode
		receiverIs: [:rcvr | '!! OopToBool(PASS_VAT ' , rcvr , ')']! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 15:55'!
messageIfFalse: aMessageNode 
	^ self
		messageIf: aMessageNode
		receiverIs: [:rcvr | '!! OopToBool(PASS_VAT ' , rcvr , ')']! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 16:14'!
messageIfNilIfNotNil: aMessageNode 
	^ self
		messageIfElse: aMessageNode
		receiverIs: [:rcvr | 'OopNil == ' , rcvr]! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 15:57'!
messageIfNil: aMessageNode 
	^ self
		messageIf: aMessageNode
		receiverIs: [:rcvr | 'OopNil == ' , rcvr ]! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 16:15'!
messageIfNotNilIfNil: aMessageNode 
	^ self
		messageIfElse: aMessageNode
		receiverIs: [:rcvr | 'OopNil !!= ' , rcvr]! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 15:57'!
messageIfNotNil: aMessageNode 
	^ self
		messageIf: aMessageNode
		receiverIs: [:rcvr | 'OopNil !!= ' , rcvr]! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 16:03'!
messageIfTrueIfFalse: aMessageNode 
	^ self
		messageIfElse: aMessageNode
		receiverIs: [:rcvr | 'OopToBool(PASS_VAT ' , rcvr , ')']! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 15:45'!
messageIfTrue: aMessageNode 
	^ self
		messageIf: aMessageNode
		receiverIs: [:rcvr | 'OopToBool(PASS_VAT ' , rcvr , ')']! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 16:18'!
messageIf: aMessageNode receiverIs: predicate 
	| n rcvr arg1 z |
	n := self serial asString.
	z := 'if_' , n.
	rcvr := aMessageNode receiver acceptVisitor: self.
	body write: 'oop ' , z , '= OopNil; // ifFalse:'.
	body write: 'if ( '
			, (predicate value: rcvr) , ' ) {'.
	arg1 := self flattenBlockNode: aMessageNode arguments first.
	body write: z , '=' , arg1 , ';'.
	body write: '}'.
	^ z! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:36'!
messageLE: aMessageNode

	^self message: aMessageNode binOp: 'OopLE'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:33'!
messageLT: aMessageNode

	^self message: aMessageNode binOp: 'OopLT'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 1/2/2006 10:19'!
messageMul: aMessageNode 
	^ self message: aMessageNode binOp: 'OopMul'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/12/2005 17:17'!
messageNENE: aMessageNode

	^self message: aMessageNode binOp: 'OopNENE'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:36'!
messageNE: aMessageNode

	^self message: aMessageNode binOp: 'OopNE'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 16:46'!
messageSay: aMessageNode 
	| rcvr |
	rcvr := aMessageNode receiver acceptVisitor: self.
	body write: 'OopSay(PASS_VAT  ' , rcvr , ' );'.
	^ rcvr.! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'Ryan 12/11/2005 09:33'!
messageSub: aMessageNode

	^self message: aMessageNode binOp: 'OopSub'! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 12/23/2005 18:17'!
message: aMessageNode binOp: aFuncName

	| n z rcvr arg1 |

	"self comment: aMessageNode."

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

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

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

	^ z
! !

!CinnabarGenMethods methodsFor: 'specialCases' stamp: 'strick 2/18/2006 21:32'!
specialLoop: aMessageNode 
	| n rcvr argTo argBy block |
	n := self serial asString.
	"---"
	rcvr := aMessageNode receiver acceptVisitor: self.

	(aMessageNode arguments at: 7) ifNotNil: [
		"These have an AssignmentNode for the *LimiT temporary at 7"
		self comment: '(*LimiT*) ', (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'! !


!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 1/1/2006 10:10'!
cleanString: aString max: max
	|z| z := aString
		collect: [:c | $  <= c
				ifTrue: [c]
				ifFalse: [$ ]]
.
	z size > max ifTrue: [ z := (z copyFrom: 1 to: max), '...' ].
^z! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 1/1/2006 10:11'!
comment: aNode 
	body write: '// '
			, (self cleanString: aNode asString max: 999) , ' '! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 12/23/2005 08:43'!
convertSelectorToCbar: aSelector 
	^ self identifier: aSelector! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'Ryan 12/11/2005 06:37'!
convertToUnixNewlines: aString

" CinnabarGen new convertToUnixNewlines: 'blah
two
three' 
"

	^aString copyReplaceAll: Character cr asString with: Character lf asString asTokens: false.! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'Ryan 12/10/2005 19:14'!
declareParameters: aParameterArray

	| decs |

	decs _ ''.

	aParameterArray do: [:parm |

		decs _ decs, ', oop ', parm.
].

	^ decs! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'Ryan 12/10/2005 17:13'!
defineArgumentVariables: anArgArray

	| definitions num |

	definitions _ ''.
	num _ 1.

	anArgArray do: [:arg |

		definitions _ definitions, 'oop arg', (num asString),' = ', (arg acceptVisitor: self),';
'.		num _ num + 1.
].

	^ definitions! !

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

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 2/17/2006 23:50'!
escapeStringForC: aString 
	^ aString
		inject: ''
		into: [:b :c | 
			| x | 
			x := c codePoint.
			x < 32 | (x > 126)
				ifTrue: [b, '\' , (x // 64) asString , (x // 8 \\ 8) asString , (x \\ 8) asString]
				ifFalse: [('\''"' includes: c)
						ifTrue: [b , '\'
								, (ByteString with: c)]
						ifFalse: [b
								, (ByteString with: c)]]]! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 2/13/2006 03:31'!
generateMethod: aMethodNode forClass: aClass 
	| cCode selector bNode argVars funcName |
	theClass := aClass.
	method := aMethodNode.
	firstPass := CinnabarFirstPass new
				visitMethodNode: aMethodNode
				forClass: aClass
				for: self.
	"*** firstPass inspect. ***"
	cCode := ''.
	bNode := aMethodNode block.
	selector := aMethodNode selector asString.
	funcName := stMethodsToCbar at: selector.
	argVars := aMethodNode arguments
				collect: [:var | var acceptVisitor: self].
	cCode := 'oop ' , funcName , '(PARM_VAT   oop v_self, Symbol* selector'
				, (self declareParameters: argVars) , ') {
'.
	"============ trying enterScope ===================="
	
	self enterScope: aMethodNode.
	"======================================================="
	"this will be wrong for methods on num/SmallInteger"
	aClass == SmallInteger
		ifFalse: [cCode := cCode , '
   C_' , (self tr: aClass name) , '* self= (C_' , (self tr: aClass name) , '*) OopToHeader(v_self);
'].
	self flattenBlockNode: bNode.
	cCode := cCode , '
/*BODY*/' , body contents , '
/*END*/ return v_self;
ERROR:
	AddVatErrorString(PASS_VAT  "in ' , aClass name , '>>' , selector , ' ...");
	return (oop)0;
}
Function F_' , funcName , ';
'.
	"==============================="
	self exitScope: aMethodNode.
	"======================================================="
	initializations write: 'F_' , funcName , '.entry = (FUNC*)' , funcName , ';'.
	initializations write: 'F_' , funcName , '.name = "' , aClass name , '>>' , selector , '";'.
	self resetFunction.
	^ cCode! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 2/18/2006 21:31'!
initialize
	captureStack := OrderedCollection new.
	saveStack := OrderedCollection new.
	blockStack := OrderedCollection new.
	contextStack := OrderedCollection new.
	methodNum := 0.
	stMethodsToCbar := Dictionary new.
	nextSerialNumber := 0.
	declarations := CinnabarCodeStream new.
	initializations := CinnabarCodeStream new.
	body := CinnabarCodeStream new.
	"Make a table for special message cases"
	specialCases := Dictionary new.
	"*** all 8 cases of ifTrue, ifFalse, ifNil, ifNotNil..... 
	go to the same #messageIfTrueIfFalse: handler ***"
	specialCases
		add: (Association new key: #ifTrue: value: #messageIfTrueIfFalse:);
		
		add: (Association new key: #ifFalse: value: #messageIfTrueIfFalse:);
		
		add: (Association new key: #ifNil: value: #messageIfTrueIfFalse:);
		
		add: (Association new key: #ifNotNil: value: #messageIfTrueIfFalse:);
		
		add: (Association new key: #ifTrue:ifFalse: value: #messageIfTrueIfFalse:);
		
		add: (Association new key: #ifFalse:ifTrue: value: #messageIfTrueIfFalse:);
		
		add: (Association new key: #ifNil:ifNotNil: value: #messageIfTrueIfFalse:);
		
		add: (Association new key: #ifNotNil:ifNil: value: #messageIfTrueIfFalse:).
	"*** and: & or: also use #messageIfTrueIfFalse: ***"
	specialCases at: #and: put: #messageIfTrueIfFalse:;
		 at: #or: put: #messageIfTrueIfFalse:.
	specialCases
		add: (Association new key: #'==' value: #messageEQEQ:);
		
		add: (Association new key: #'~~' value: #messageNENE:);
		
		add: (Association new key: #= value: #messageEQ:);
		
		add: (Association new key: #'~=' value: #messageNE:);
		
		add: (Association new key: #< value: #messageLT:);
		
		add: (Association new key: #> value: #messageGT:);
		
		add: (Association new key: #'<=' value: #messageLE:);
		
		add: (Association new key: #'>=' value: #messageGE:);
		 at: #+ put: #messageAdd:;
		 at: #- put: #messageSub:;
		 at: #* put: #messageMul:;
		
		add: (Association new key: #bitAnd value: #messageBitAnd:);
		
		add: (Association new key: #bitOr value: #messageBitOr:);
		
		add: (Association new key: #bitXor value: #messageBitXor:);
		
		add: (Association new key: #bitShift: value: #messageBitShift:).
	specialCases
		add: (Association new key: #basicNew value: #messageBasicNew:);
		
		add: (Association new key: #basicNew: value: #messageBasicNewColon:);
		
		add: (Association new key: #say value: #messageSay:);
		
		add: (Association new key: #error: value: #messageErrorColon:).

	"*** both to:by:do: and to:do: are handled by #specialLoop:  ***"
	specialCases
		add: (Association new key: #to:by:do: value: #specialLoop: );
		
		add: (Association new key: #to:do: value: #specialLoop: )! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 12/17/2005 20:32'!
passArgumentVariables: anArgArray

	| definitions |

	definitions _ ''.

	anArgArray do: [:arg |  | a |
		a := (arg acceptVisitor: self) asString.
		""" body write: '// **ARG** ', a. """
		definitions _ definitions, ', ', a.
	].

	^ definitions! !

!CinnabarGenMethods methodsFor: 'private' stamp: 'strick 11/28/2005 02:54'!
serial

	^ nextSerialNumber := nextSerialNumber + 1! !


!CinnabarGenMethods methodsFor: 'public interface' stamp: 'strick 2/16/2006 16:22'!
generateClass: aClass 
	"CinnabarGen new generateClass: Apple"
	| cCode |
	master addClass: aClass.

	cCode := self genCbarHeader: aClass.
	cCode := cCode
				, (self genCbarFromClass: aClass)
				, (self genCbarFromClass: aClass class).
	cCode := cCode
				, (self genCbarFooter: aClass).
	^ cCode
! !

!CinnabarGenMethods methodsFor: 'public interface' stamp: 'strick 2/12/2006 19:32'!
generateClass: aClass toFileName: aFileName for: aMaster

	| fileStream |

	master := aMaster.

	fileStream := (StandardFileStream forceNewFileNamed: aFileName).

	fileStream nextPutAll: (self convertToUnixNewlines: (self generateClass: aClass)).

	fileStream close.
! !

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

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/29/2005 03:54'!
blocks1

	| a b c  |
	a := 1. b := 2. c := 3.
	Transcript show: a @ b @ c.

	Transcript show: [ :i | | j | j := i*2.  a + i @ [ :k  | | m | m := k + j + i + a. m ] ].
	Transcript show: ([ :i | b + i ] value: 4).

	5 zork.

	1 to: 10 do: [ :i | Transcript show: i asString ].
	1 to: 20 do: [ :i | Transcript show: i asFloat ].
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/20/2006 19:23'!
blocks2: x with: y 
	| a b c |
	a := 1.
	b := 2.
	c := 3.
	Transcript show: a @ x @ c.
	Transcript
		show: [:i | 
			| j | 
			j := i * 2.
			a + i
				@ [:k | 
					| m | 
					m := k + j + a + y.
					m]].
	Transcript
		show: ([:i | b + i]
				value: 4).
	5 zork.
	1
		to: 10
		do: [:i | Transcript show: i asString].
	1
		to: 20
		do: [:i | Transcript show: i asFloat]! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 09:22'!
factorialFactoryForY: f 
	^ [:n | n == 0
		ifTrue: [1]
		ifFalse: [n
				* (f value: n - 1)]] ! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 09:42'!
factorial: anInt 
	"
	self new factorial: 5
	"
	| bigY bigF factorial |
	bigY := [:g | "Y Combinator: traditional fixed-point operator from functional programming"
			| a | 
			a := [:f | f value: f].
			a
				value: [:f | g
						value: [:x | 
							| c | 
							c := f value: f.
							c value: x]]].
	bigF := [ :f | "factorial without recursion" 
		[:n | n == 0
			ifTrue: [1]
			ifFalse: [n
				* (f value: n - 1)]]].

	"factorial is the fixed point of F"
	factorial := bigY value: bigF.

	^ factorial value: anInt
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/17/2005 18:38'!
fibRV: n
	" Fib new fibRV: 30 "

	^ (n<2) 
		ifTrue: [ 1 ]
		ifFalse: [ (self fibRV: n-1) + (self fibRV: n-2) ]
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/17/2005 17:53'!
fib: n
	" Fib new fib: 30 "

	(n<2) ifTrue: [ ^ 1. ].
	^ (self fib: n-1) + (self fib: n-2).
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/22/2005 16:59'!
helloWorld
	^'hello world'! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/24/2005 21:49'!
iterativeTriangeNegatively: n

"
	self new iterativeTriangeNegatively: 10
"

	| sum |
	sum := 0.
	n to: 1 by: -1 do: [ :i | sum := sum + i ].
	^sum! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/26/2005 08:30'!
iterativeTriange: n

"
	self new iterativeTriange: 5000000
"

	| sum |
	sum := 0.
	1 to: n do: [ :i | sum := sum + i ].
	^sum! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/17/2005 17:50'!
makeCounter

	| count incr |

	count := 0.
	incr := 1.
"""
	^ [ :incrIncr |

		incr := incr + incrIncr.
		count := incr.
		^ count.
	]
"""! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/20/2006 19:23'!
mumble: a1 
	| t1 |
	t1 := 100.
	^ [:a2 | 
	| t2 | 
	t2 := a1 + t1 + a2.
	t1 := t1 + t2.
	[:a3 | t1 := t1 + a1 + t2 + a2 + a3]]! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/21/2005 01:23'!
newByteString
	^ByteString basicNew: 42.
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/19/2005 23:59'!
newDateAndTime
	^DateAndTime basicNew.
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:28'!
returnABlock: a 
	| b |

	b := a.

	^ [:i :j | 
			b := b + i.
			b + j
	]
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:29'!
returnC

	| a b c |

	c := 0.
	a := 14 + c. 
	b := 56 + c.

	^ c := a + b.
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/25/2005 20:38'!
ttest0
	| fib1 fib3 fib5 fib30 |

	( self iterativeTriange: 10 ) ~~ 55 ifTrue: [ self error: 'not55err'. ^ 'not55' ].
	( self iterativeTriangeNegatively: 10 ) ~~ 55 ifTrue: [ self error: 'neg/not55err'. ^ 'neg/not55' ].

	fib1 _ self fib:1.
	fib3 _ self fib:3.
	fib5 _ self fib:5.
	fib30_ self fib:30.

	 (fib3) < 3  ifTrue: [^false].
	 3 < (fib3)  ifTrue: [^false].

	(fib5) < 8  ifTrue: [^false].
	 8 < (fib5)  ifTrue: [^false].

	(fib30) < 1346269  ifTrue: [^false].
	 1346269 < (fib30)  ifTrue: [^false].

	(fib5) ~= 8  ifTrue: [^false].
	 8 ~= (fib5)  ifTrue: [^false].

	 8 ~= (self fibRV: 5)  ifTrue: [^false].

	self newDateAndTime.
	"2<3 ifTrue: [^true]."
	self newByteString basicSize == 42 ifFalse: [^false].
	self helloWorld basicSize == 11 ifFalse: [^false].

	(self newByteString ~~ self newByteString) ifFalse: [^false].

	1 = (fib1) ifTrue: [^true].

	^ false! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/25/2005 20:38'!
ttest1

	( self iterativeTriange: 10 ) ~~ 55 ifTrue: [ self error: 'not55err'. ^ 'not55' ].
	( self iterativeTriangeNegatively: 10 ) ~~ 55 ifTrue: [ self error: 'neg/not55err'. ^ 'neg/not55' ].
	^ true.
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:40'!
ttest42IfNil

	^ 42 == ( 42 ifNil: [13] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:43'!
ttest42IfNilIfNotNil

	^ 7 == ( 42 ifNil: [888] ifNotNil: [7] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:41'!
ttest42IfNotNil

	^ 13 == ( 42 ifNotNil: [13] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:44'!
ttest42IfNotNilIfNil

	^ 888 == ( 42 ifNotNil: [888] ifNil: [7] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/26/2005 08:59'!
ttest5m

	"
	self new ttest5m
	"
	1 to: 5000 do: [ :i |
		self iterativeTriange: 5000.
	].
	^true
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 12/29/2005 04:27'!
ttestB1
	"self blocks1."
	^ true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 13:57'!
ttestBasicArray
	| a b c |
	a := Array basicNew: 0.
	b := Array basicNew: 10.
	c := Array basicNew: 100.
	c say.
	0 = a basicSize
		ifFalse: [^ false].
	10 = b basicSize
		ifFalse: [^ false].
	100 = c basicSize
		ifFalse: [^ false].
	^true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/20/2006 19:24'!
ttestBitShift

	^ (42 bitShift: 1)
		= 84! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 16:53'!
ttestBraceArray
	| a b c n |
	n := 100.
	b := {1 + n. 5 + n. 9 + n}.
	c := {#value. #(2 4 6 ). {n + n. n + n + n}. nil}.
	a := {}.
	c say.
	0 = a basicSize
		ifFalse: [^ false].
	3 = b basicSize
		ifFalse: [^ false].
	4 = c basicSize
		ifFalse: [^ false].
	109
			== (b basicAt: 3)
		ifFalse: [^ false].
	101
			== (b basicAt: 1)
		ifFalse: [^ false].
	nil
			== (c basicAt: 4)
		ifFalse: [^ false].
	Array == (c basicAt: 2) class
		ifFalse: [^ false].
	#value
			== (c basicAt: 1)
		ifFalse: [^ false].
	^ true
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 03:11'!
ttestClassMethodFive


	^ 5 == self class five
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 14:42'!
ttestClassMethodNine


	^ 9 == self class nine
! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 17:38'!
ttestFactorial
	"^ 120 = (self new factorial: 5)"
	| expected |
	expected := 1.
	1
		to: 8
		do: [:i | 
			| got |
			'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.
			'expected' say.
			expected say.
			got := self factorial: i.
			'got' say.
			got say.
			expected == got
				ifFalse: [^ false]].
	^ true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 15:09'!
ttestLiteralArray
	| a b c |
	a := #().
	b := #(2 4 6 8 10 12 14 16 18 20 ).
	c := #(42 ).
	c say.
	0 = a basicSize
		ifFalse: [^ false].
	10 = b basicSize
		ifFalse: [^ false].
	1 = c basicSize
		ifFalse: [^ false].
	b basicAt: 3 put: 9.
	b basicAt: 10 put: 100.
	9
			== (b basicAt: 3)
		ifFalse: [^ false].
	100
			== (b basicAt: 10)
		ifFalse: [^ false].
	2
			== (b basicAt: 1)
		ifFalse: [^ false].
	18
			== (b basicAt: 9)
		ifFalse: [^ false].
	42
			== (c basicAt: 1)
		ifFalse: [^ false].
	^ true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/2/2006 17:33'!
ttestLiterals
	5 class == 8 class
		ifFalse: [^ false].
	5 class ~~ 8
		ifFalse: [^ false].
	5 class ~~ #(8 ) class
		ifFalse: [^ false].
	{5} class == #(8 ) class
		ifFalse: [^ false].
	'hello' ~~ 'hello'
		ifFalse: [^ false].
	#value: == #value:
		ifFalse: [^ false].
	#value ~~ #value:
		ifFalse: [^ false].
	#(#value ) ~~ #(#value: )
		ifFalse: [^ false].
	^ true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:39'!
ttestNilIfNil

	^ 42 == ( nil ifNil: [42] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:43'!
ttestNilIfNilIfNotNil

	^ 888 == ( nil ifNil: [888] ifNotNil: [42] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:41'!
ttestNilIfNotNil

	^ nil == ( nil ifNotNil: [42] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:44'!
ttestNilIfNotNilIfNil

	^ 7 == ( nil ifNotNil: [888] ifNil: [7] )! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 1/20/2006 19:21'!
ttestReturnedBlock
	| f |
	f := self returnABlock: 10.
	^ 23
		= (f value: 4 value: 9)! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:36'!
ttestWhileFalse

	| i z |

	i := z := 0.

	[ z := z + i.   i := i + 1.  i>10 ] 
		whileFalse. 

	^ z == 55! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:35'!
ttestWhileFalseColon

	| i z |

	i := z := 0.

	[ i > 10 ] whileFalse: [ z := z + i.   i := i + 1.  ]. 

	^ z == 55! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:35'!
ttestWhileTrue

	| i z |

	i := z := 0.

	[ z := z + i.   i := i + 1.  i<=10 ] 
		whileTrue. 

	^ z == 55! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:34'!
ttestWhileTrueColon

	| i z |

	i := z := 0.

	[ i <= 10 ] whileTrue: [ z := z + i.   i := i + 1.  ]. 

	^ z == 55! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CinnabarTestFib class
	instanceVariableNames: ''!

!CinnabarTestFib class methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 03:10'!
five

	^ 5! !

!CinnabarTestFib class methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 14:44'!
nine

	^ (self five) + (CinnabarTestFib five) - 1! !


Object subclass: #CinnabarTestFruit
	instanceVariableNames: 'aaa bbb ccc'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarTestFruit methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:00'!
ones

	^ 1! !

!CinnabarTestFruit methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:03'!
ttest1

	^ 1 == self ones! !

!CinnabarTestFruit methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:20'!
ttest2

	^ 2 == self twos! !

!CinnabarTestFruit methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:02'!
twos

	^ 2! !


CinnabarTestFruit subclass: #CinnabarTestApple
	instanceVariableNames: 'one two three'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 12/23/2005 21:24'!
alter2468

	"
 self new alter2468 
 self new return2468
"

	| x | 
	x := self return2468.
	x at: 2 put: #bogus.
	x := self return2468.
	^x! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:01'!
ones

	^ 10 + super ones! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 12/23/2005 21:28'!
return2468
	^ #(2 4 6 8)   ! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 12/23/2005 19:51'!
returnSmalltalk
	^ Smalltalk! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 11/25/2005 07:49'!
returnSomething
	^42! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 11/25/2005 07:49'!
returnSomethingElse
	^69! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 12/25/2005 20:42'!
ttest

	"(self returnSomething = 42) ifTrue: [
		(self returnSomethingElse = 69) ifTrue: [
			(self varStoreReturn = 42) ifTrue: [ ^true].
		].
	]."

	"^false"

	"self alter2468."

	-999999 < 999999 ifTrue: [
		'Apple test is good' say.
		"self error: 'try throwing this error!!!!!!'."
		^true
	].

	^ false! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:04'!
ttest1

	^ 1 == super ones! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:04'!
ttest11

	^ 11 == self ones! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:05'!
ttest2

	^ 2 == self twos! !

!CinnabarTestApple methodsFor: 'as yet unclassified' stamp: 'strick 12/9/2005 16:11'!
varStoreReturn
	| someVar |

	someVar _ 42.
	^someVar.! !


CinnabarTestApple subclass: #CinnabarTestGreenApple
	instanceVariableNames: 'xray yankee zulu'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarTestGreenApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:02'!
ones

	^ 100 + super ones! !

!CinnabarTestGreenApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:06'!
ttest11

	^ 11 == super ones! !

!CinnabarTestGreenApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:06'!
ttest111

	^ 111 == self ones! !

!CinnabarTestGreenApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:05'!
ttest2

	^ 2 == super twos! !

!CinnabarTestGreenApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:05'!
ttest202

	^ 202 == self twos! !

!CinnabarTestGreenApple methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:02'!
twos

	^ 200 + super twos! !


TestCase subclass: #CinnabarUnitTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 17:45'!
blocks1
	| a b c |
	a := 1.
	b := 2.
	c := 3.
	Transcript show: a @ b @ c.
	Transcript
		show: [:i | 
			| j | 
			j := i * 2.
			a + i
				@ [:k | 
					| m | 
					m := k + j + i + a.
					m]].
	Transcript
		show: ([:i | b + i]
				value: 4).
	5 zork.
	1
		to: 10
		do: [:i | Transcript show: i asString].
	1
		to: 20
		do: [:i | Transcript show: i asFloat]! !

!CinnabarUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 17:43'!
blocks2: x with: y 
	"DONT CHANGE ME -- my structure is hardcoded into CinnabarUnitTests
	#testCapturedVariables"
	"a and b and y are captured"
	| a b c |
	a := 1.
	b := 2.
	c := 3.
	Transcript show: a @ x @ c.
	Transcript
		show: [:i | 
			| j | 
			"this j is captured!!"
			j := i * 2.
			a + i
				@ [:k | 
					| m | 
					"here j is used by inner block"
					m := k + j + a + y.
					m]].
	Transcript
		show: ([:i | b + i]
				value: 4).
	5 zork.
	1
		to: 10
		do: [:i | Transcript show: i asString].
	1
		to: 20
		do: [:i | Transcript show: i asFloat]! !

!CinnabarUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 1/21/2006 01:04'!
testCapturedVariables
	| firstPass methodSource methodNode cls gen |
	gen := CinnabarGenMethods new.
	cls := self class.
	methodSource := cls sourceMethodAt: #blocks2:with:.
	methodNode := Parser new parse: methodSource class: cls.
	firstPass := CinnabarFirstPass new visitMethodNode: methodNode forClass: cls for: gen.
	self
		assert: (firstPass testCapturedVariable: 'a' inScope: methodNode).
	self
		assert: (firstPass testCapturedVariable: 'b' inScope: methodNode).
	self
		assert: (firstPass testCapturedVariable: 'y' inScope: methodNode).
	self assert: (firstPass testCapturedVariable: 'c' inScope: methodNode) not.
	self assert: (firstPass testCapturedVariable: 'x' inScope: methodNode) not.
	self assert: (firstPass
			testCapturedVariable: 'i'
			inScope: ((methodNode block statements at: 5) arguments at: 1)) not.
	self
		assert: (firstPass
				testCapturedVariable: 'j'
				inScope: ((methodNode block statements at: 5) arguments at: 1))! !

!CinnabarUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 17:29'!
testHowManyArgsForSelector
	| fp |
	fp := CinnabarFirstPass new.
	self assert: 0
			= (fp howManyArgsForSelector: #value).
	self assert: 1
			= (fp howManyArgsForSelector: #value:).
	self assert: 1
			= (fp howManyArgsForSelector: #@).
	self assert: 2
			= (fp howManyArgsForSelector: #at:put:).
	self assert: 3
			= (fp howManyArgsForSelector: #to:by:do:)
! !

!CinnabarUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 12/31/2005 17:29'!
testRememberCapturedVariable
	| fp a b c |
	fp := CinnabarFirstPass new.
	a := BlockNode new.
	b := BlockNode new.
	c := BlockNode new.
	fp rememberCapturedVariable: #aaa inScope: a.
	fp rememberCapturedVariable: 'bbb' inScope: b.
	fp rememberCapturedVariable: 'bbb' inScope: c.
	fp rememberCapturedVariable: 'ccc' inScope: c.
	self
		assert: (fp testCapturedVariable: 'aaa' inScope: a).
	self
		assert: (fp testCapturedVariable: 'bbb' inScope: b).
	self
		assert: (fp testCapturedVariable: 'ccc' inScope: c).
	self assert: (fp testCapturedVariable: 'ccc' inScope: a) not.
	self assert: (fp testCapturedVariable: 'aaa' inScope: b) not.
	self
		assert: (fp testCapturedVariable: 'bbb' inScope: c).
	self assert: (fp testCapturedVariable: 'bbb' inScope: BlockNode new) not! !

!CinnabarUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/16/2006 02:52'!
xxxxxxCapturedVariables2

"
 self new xxxxxxCapturedVariables2
"

	| firstPass methodSource methodNode cls gen |
	gen := CinnabarGenMethods new.
	cls := SmallInteger.
	methodSource := cls sourceMethodAt: #quo:.
	methodNode := Parser new parse: methodSource class: cls.
	firstPass := CinnabarFirstPass new visitMethodNode: methodNode forClass: cls for: gen.
	self
		assert: (firstPass testCapturedVariable: 'a' inScope: methodNode).
	self
		assert: (firstPass testCapturedVariable: 'b' inScope: methodNode).
	self
		assert: (firstPass testCapturedVariable: 'y' inScope: methodNode).
	self assert: (firstPass testCapturedVariable: 'c' inScope: methodNode) not.
	self assert: (firstPass testCapturedVariable: 'x' inScope: methodNode) not.
	self assert: (firstPass
			testCapturedVariable: 'i'
			inScope: ((methodNode block statements at: 5) arguments at: 1)) not.
	self
		assert: (firstPass
				testCapturedVariable: 'j'
				inScope: ((methodNode block statements at: 5) arguments at: 1))! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CinnabarUnitTests class
	instanceVariableNames: ''!


Object subclass: #CinnabarxBase
	instanceVariableNames: 'set list fileStream depth howManyDone'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!CinnabarxBase commentStamp: '<historical>' prior: 0!
This base contains both a Set of Classes and a Write Stream for output.

Automatically adds superclasses and metaclasses.

Generates things in order of dependancies, based on superclassses.
!


!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:29'!
addClassSupersAndMetas: aClass

	(set includes: aClass) ifFalse: [

		" do the supers before adding to 'list' "
		aClass superclass ifNotNil: [ self addClassSupersAndMetas: aClass superclass ].

		" supers have metas, so we might have already been done, so check again. "
		(set includes: aClass) ifFalse: [
			set add: aClass.
			list add: aClass.
		].

		" add metaclass last "
		self addClassSupersAndMetas: aClass class.

	].
! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 21:16'!
addImportantClasses

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

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:57'!
cleanString: aString max: max
	^ self 
		string: (

			aString collect: [:c | $  <= c
							ifTrue: [c]
							ifFalse: [$ ]
				]

		) max: max! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 22:47'!
close

	fileStream close.

	" prevent any further work by nilling out fields "
	set := list := fileStream := nil.! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 22:53'!
comment: something 

	" trailing space prevents trailing ${ or $} which indicate nesting "

	self write: '// ' , (self cleanString: something asString max: 999) , ' '! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:10'!
doAll

	howManyDone := 0.

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

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:11'!
doOne: aClass

	howManyDone := howManyDone + 1
! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:49'!
escapeStringForC: aString 
	^ aString
		inject: ''
		into: [:b :c | 
			| x | 
			x := c codePoint.
			x < 32 | (x > 126)
				ifTrue: [b, '\' , (x // 64) asString , (x // 8 \\ 8) asString , (x \\ 8) asString]
				ifFalse: [('\''"' includes: c)
						ifTrue: [b , '\'
								, (ByteString with: c)]
						ifFalse: [b
								, (ByteString with: c)]]]! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:03'!
fileName: aFilename

	fileStream := (StandardFileStream forceNewFileNamed: aFilename)! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:04'!
fileStream

	^ fileStream! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 00:09'!
fileStreamInMemory

	" use an in-memory buffer for the file stream "

	fileStream := (WriteStream with: String new) initialize.! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:04'!
fileStream: aFileStream

	fileStream := aFileStream! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 22:52'!
initialize

	super initialize.

	set := IdentitySet new.
	list := OrderedCollection new.

	fileStream := nil.    "use #toFile: to assign"
	depth := 0.! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:27'!
list

	^ list! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 22:59'!
newline

	fileStream nextPut: Character lf.! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 00:14'!
split: aString on: separatorString

	^ aString findTokens: separatorString! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:55'!
string: aString max: max

	aString size > max 

		ifTrue: [ ^ (aString copyFrom: 1 to: max), '...' ]

		ifFalse: [ ^ aString ]! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:19'!
tr: aString 
	"
	self new tr: 'foo-bar class'
	
	Optimize: just return the string if all AlphaNumeric.
	Otherwise rebuild the string.
	"
	(aString
			inject: true
			into: [:z :c | z
					and: [c isAlphaNumeric]])
		ifTrue: [^ aString].
	^ aString
		inject: ''
		into: [:b :c | c isAlphaNumeric
				ifTrue: [b := b
								, (ByteString with: c)]
				ifFalse: [b := b , '$' , c codePoint asString , '$']]! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 00:11'!
write: aString 

	"
	  A Pretty-Writer for generating C code -- writes one line. 
	  The last character in the string can be ${ or $} to guide nesting.
	"

	| n tail |
	n := aString size.

	"set tail to last char, or to something bogus like $$ if empty"
	n > 0
		ifTrue: [tail := aString at: n]
		ifFalse: [tail := $$].
	$} = tail
		ifTrue: [depth := depth - 1].

	self assert: depth >= 0.

	" write indentation based on depth "
	1 to: depth do: [:i | fileStream nextPutAll: '    '].

	fileStream nextPutAll: aString.
	self newline.

	${ = tail
		ifTrue: [depth := depth + 1]! !


TestCase subclass: #CinnabarxBigTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarxBigTests methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:41'!
testBig

	| d v i t |

	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.

	#( CinnabarTestFib CinnabarTestGreenApple
		Object True False Character 
		UndefinedObject IdentityDictionary TranscriptStream
		SmallInteger ByteString ByteSymbol Array
	) do: [ :clsName |

		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.





! !


CinnabarxBase subclass: #CinnabarxGenDeclaratons
	instanceVariableNames: 'extraFields'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 14:56'!
doAll

	super doAll.

	self write: '#define INITIAL_TYPE_TABLE_NEXT ', 
			( 1 + howManyDone + self howManySpareTypeTableSlots) asString
! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 14:30'!
doOne: aClass

	| n className superClassName clsObjName typeObjName 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.  

	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'.
	typeObjName := 'C_' , className , '_TypeObj'.
	self write: 'extern Type ' , typeObjName , ';'.
	(className endsWith: '$32$class') ifTrue: [
		"cannot use ClassDescription of Metaclass yet (due to category abuse)"
		self write: 'extern struct /*C_Metaclass*/C_Class ' , clsObjName , ';'.
	] ifFalse: [
		self write: 'extern struct C_', className, '$32$class ' , clsObjName , ';'.
	].! !

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

	^ 10! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 21:03'!
initialize

	super initialize.

	extraFields := IdentityDictionary new.

	extraFields at: Behavior put: #( #'x_numFixedOops' ).
	extraFields at: Behavior put: #( #'x_funcMap' ).
	" TODO: where to invalidate method cache for this class "

	extraFields at: Symbol put: #( #'x_arrayIndex' ).
	extraFields at: Symbol put: #( #'x_left' ).
	extraFields at: Symbol put: #( #'x_right' ).

! !


CinnabarxBase subclass: #CinnabarxGenInitializations
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:16'!
doOne: aClass

	| className clsObjName typeObjName superC superClassName |
	super doOne: aClass.


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


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

	self write: 'TypeTable[ C_' , className , '_TypeIndex ]= & ' , typeObjName , ';'.
	self write: ''.
	"following is WRONG -- TODO make a TypeIndex for Type"
	self write: typeObjName , '.setTypeIndex( Type_TypeIndex );'.
	self write: typeObjName , '.setFlags( Header::ETERNAL | Header::SHARED );'.
	self write: typeObjName , '.setHash( C_' , className , '_TypeIndex );'.
	self write: typeObjName , '.typeTableIndex = C_' , className , '_TypeIndex;'.
	self write: typeObjName , '.name = "' , className , '";'.
	self write: typeObjName , '.superType = & ' , superClassName , '_TypeObj ;'.
	self write: typeObjName , '.thisClass = & ' , clsObjName , ';'.
	aClass isBits
		ifTrue: [self write: typeObjName , '.instanceFlags  |=  Header::BITS ;'].
	aClass isBytes
		ifTrue: [self write: typeObjName , '.instanceFlags  |=  Header::BYTES ;'].
	aClass isVariable
		ifTrue: [self write: typeObjName , '.instanceFlags  |=  Header::INDEXED ;'.
			self assert: aClass instSize < 8.
			aClass instSize > 0
				ifTrue: [self write: typeObjName , '.instanceFlags  |=  Header::FIXED_8 ;']].
	self write: typeObjName , '.fixedSize = ' , aClass instSize asString , ';'.
	"self write: '// ' , aClass allInstVarNames asString."
	self write: ''.
	(className endsWith: '$class') ifTrue: [
		"cannot use ClassDescription of Metaclass yet (due to category abuse)"
		self write: clsObjName , '.setTypeIndex( /*C_Metaclass_TypeIndex*/C_Class_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: clsObjName , '.f_category = OopFromHeader( & ' , typeObjName , ');'.
	self write: ''.
	self write: ''.
	self write: ''.! !


CinnabarxBase subclass: #CinnabarxGenVariables
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarxGenVariables methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:13'!
doOne: aClass

	| className clsObjName typeObjName |
	super doOne: aClass.


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

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

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:58'!
addClassToMasters: aClass

	masterDecls addClassSupersAndMetas: aClass.
	masterVars addClassSupersAndMetas: aClass.
	masterInits addClassSupersAndMetas: aClass.



! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 10:02'!
declareParameters: aParameterArray

	^ aParameterArray inject: '' into: [ :z :x | z, ', oop ', x ] ! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 10:06'!
defineArgumentVariables: anArgArray

	| num |

	num _ 0.

	^ anArgArray inject: '' into: [ :z :arg |

		num := num + 1.

		z, '  oop arg', (num asString),' = ', (arg acceptVisitor: self),'  ;;;  '.
	].
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:57'!
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 Object {'.
			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_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]! !

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

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


	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/18/2006 23:53'!
generateMethodInstalls

	" --- install methods for theClass itself "

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

		self write: 'type->insertFunction( InternString("', 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: 'typeType->insertFunction( InternString("', k, '"),'.
		self write: '  (FUNC*) Func_', theClass name, '$32$class_', kk, ');'.

	].

! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 22:10'!
initialize

	super initialize.

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

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

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

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

		 at: #+ put: #messageAdd: ;
		 at: #- put: #messageSub: ;
		 at: #* put: #messageMul: ;
		
		at: #bitAnd put: #messageBitAnd: ;
		
		at: #bitOr put: #messageBitOr: ;
		
		at: #bitXor put: #messageBitXor: ;
		
		at: #bitShift: put: #messageBitShift: ;

		at: #basicNew put: #messageBasicNew: ;
		
		at: #basicNew: put: #messageBasicNewColon: ;
		
		at: #say put: #messageSay: ;
		
		at: #error: put: #messageErrorColon: .

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

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

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

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

	1 to: litArray size do: [:i | 

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

		].

	^ z
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 10:44'!
literalByteString: lit 
	| n z |
	n := self serial asString.
	z := 'str_' , n.

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

	myInits write: z , '= OopLiteralByteString(PASS_VAT  "'
			, (self escapeStringForC: lit asString) , '");'.
	myInits write: 'assert(' , z , ');'.

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 10:44'!
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( InternString( "'
			, (self escapeStringForC: lit) , '") );'.
	myInits write: 'assert(' , z , ');'.

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 10:40'!
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].

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:42'!
masterDecls: d masterVars: v masterInits: i

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:42'!
messageAdd: aMessageNode

	^ self message: aMessageNode binOp: 'OopAdd'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:45'!
messageBasicAtPut: aMessageNode 

	| n z rcvr arg1 arg2 |

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

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

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

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:46'!
messageBasicAt: aMessageNode 

	| n z rcvr arg1 |

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

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

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

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:46'!
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 , '= OopBasicNewColon(PASS_VAT  ' , rcvr ,' , ', arg1, ' );'.
	body write: 'if ( !! ' , z , ' ) goto ERROR;'.

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:46'!
messageBasicNew: aMessageNode 

	| n z rcvr |

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

	rcvr := aMessageNode receiver acceptVisitor: self.

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

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:46'!
messageBasicSize: aMessageNode 

	| n z rcvr |

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

	rcvr := aMessageNode receiver acceptVisitor: self.

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

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:47'!
messageBitAnd: aMessageNode

	^ self message: aMessageNode binOp: 'OopBitAnd'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:47'!
messageBitOr: aMessageNode

	^ self message: aMessageNode binOp: 'OopBitOr'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:47'!
messageBitShift: aMessageNode

	^ self message: aMessageNode binOp: 'OopBitShift'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:47'!
messageBitXor: aMessageNode

	^ self message: aMessageNode binOp: 'OopBitXor'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:47'!
messageEQEQ: aMessageNode

	^self message: aMessageNode binOp: 'OopEQEQ'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:48'!
messageEQ: aMessageNode

	^self message: aMessageNode binOp: 'OopEQ'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:48'!
messageErrorColon: aMessageNode 

	| rcvr arg1 |

	rcvr := aMessageNode receiver acceptVisitor: self.
	arg1 := aMessageNode arguments first acceptVisitor: self.

	body write: 'SetVatErrorString(PASS_VAT  ' , arg1 , ' );'.
	body write: 'AddVatErrorString(PASS_VAT  "receiver object is:" );'.
	body write: 'AddVatErrorString(PASS_VAT  ' , rcvr , ' );'.
	body write: 'goto ERROR;'.

	^ 'OopNOTREACHED'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:48'!
messageGE: aMessageNode

	^ self message: aMessageNode binOp: 'OopGE'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:48'!
messageGT: aMessageNode

	^ self message: aMessageNode binOp: 'OopGT'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:49'!
messageLE: aMessageNode

	^ self message: aMessageNode binOp: 'OopLE'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:49'!
messageLT: aMessageNode

	^ self message: aMessageNode binOp: 'OopLT'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:42'!
messageMul: aMessageNode 

	^ self message: aMessageNode binOp: 'OopMul'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:49'!
messageNENE: aMessageNode

	^ self message: aMessageNode binOp: 'OopNENE'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:49'!
messageNE: aMessageNode

	^ self message: aMessageNode binOp: 'OopNE'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:49'!
messageSay: aMessageNode 

	| rcvr |

	rcvr := aMessageNode receiver acceptVisitor: self.

	body write: 'OopSay(PASS_VAT  ' , rcvr , ' );'.

	^ rcvr.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:42'!
messageSub: aMessageNode

	^ self message: aMessageNode binOp: 'OopSub'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:43'!
message: aMessageNode binOp: aFuncName

	| n z rcvr arg1 |

	"self comment: aMessageNode."

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

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

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

	^ z
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:48'!
passArgumentVariables: anArgArray

	| definitions |

	definitions _ ''.

	anArgArray do: [:arg |  | a |
		a := (arg acceptVisitor: self) asString.
		""" body write: '// **ARG** ', a. """
		definitions _ definitions, ', ', a.
	].

	^ definitions! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:43'!
popFunction

	myDecls fileStream nextPutAll: body fileStream contents.
	body := saveStack removeLast! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 10:20'!
pushFunction
	saveStack addLast: body.
	body := CinnabarxBase new fileStreamInMemory.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:13'!
resetFunction


	self fileStream nextPutAll: myDecls fileStream contents. 
	self fileStream nextPutAll: body fileStream contents. 

	myDecls := CinnabarxBase new fileStreamInMemory.
	body := CinnabarxBase new fileStreamInMemory.

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:50'!
serial

	^ nextSerialNumber := nextSerialNumber + 1! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:20'!
specialConditional: aMessageNode

	
	| n rcvr nargs arg1 arg2 z special |


	body comment: 'Special Conditional...'.

	special := aMessageNode special.
	nargs := aMessageNode arguments size.
	self assert: (nargs == 1) | (nargs == 2).

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

	rcvr := aMessageNode receiver acceptVisitor: self.

	body write: 'oop ' , z , '= OopNil;   /*' , aMessageNode selector asString , '*/'.

	( special == 15 ) | ( special == 16 ) ifTrue: [
		( special == 15 ) ifTrue: [
			body write: 'if ( OopNil == ',rcvr,'  ) {'.
		] ifFalse: [
			body write: 'if ( OopNil !!= ',rcvr,'  ) {'.
		].
	] ifFalse: [
		body write: 'if ( OopToBool(PASS_VAT ' , rcvr , ') ) {'.
	].

	arg1 := self flattenBlockNode: aMessageNode arguments first.
	body write: z , '=' , arg1 , ';'.

	body write: '}'.
	body write: 'else {'.

	( nargs > 1 ) ifTrue: [
		arg2 := self flattenBlockNode: aMessageNode arguments second.
		body write: z , '=' , arg2 , ';'.
	] ifFalse: [
		body write: z , '=' , rcvr , ';'.
	].

	body write: '}'.

	^ z


! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 22:57'!
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) 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/18/2006 23:37'!
specialWhileLoop: aMessageNode 
	| n rcvr |

	body comment: 'Special While Loop...'.
	self assert: aMessageNode arguments size < 2.
	
	n := self serial asString.

	body write: 'while /*',n,'*/ (1) {'.

	rcvr := self flattenBlockNode: aMessageNode receiver.

	( aMessageNode special == 7 ) | ( aMessageNode special == 9 ) ifTrue: [
		body comment: 'While False -- so Break If True'.
		body write: 'if (  OopToBool(PASS_VAT  ', rcvr, ') ) goto break',n,';'.
	] ifFalse: [
		body comment: 'While True -- so Break If False'.
		body write: 'if (  !!  OopToBool(PASS_VAT  ', rcvr, ') ) goto break',n,';'.
	].

	aMessageNode arguments size > 0 ifTrue: [
		self flattenBlockNode: aMessageNode arguments first.
	].

	body write: '/*endwhile*/ }'.
	body write: 'break',n,': ;'.

	^ 'OopNil'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 13:30'!
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* type= & C_', aClass name, '_TypeObj;'.
	self write: 'Type* typeType= & C_', aClass name, '$32$class_TypeObj;'.

	self generateMethodInstalls.
	self fileStream nextPutAll: myInits fileStream contents.

	self write: '}'.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 01:59'!
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", selector->string );'.
	].
	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 , '.entry = (FUNC*)' , funcName , ';'.
	myInits write: 'F_' , funcName , '.name = "' , theClass name , '>>' , selector , '";'.
	self resetFunction.

! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 23:51'!
translateMethodsOf: theClassOrItsClass

	| saveTheClass |

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

	theClass methodDict keys asArray sort do: [ :k | 

		method := (Parser new parse: (theClass sourceMethodAt: k) class: theClass).

		self translateMethod.

	].

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:50'!
unimplemented: x 

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 14:03'!
visitAssignmentNode: anAssignmentNode 
	| var val |
	body comment: anAssignmentNode.
	var := anAssignmentNode variable acceptVisitor: self.
	val := anAssignmentNode value acceptVisitor: self.
	body write: var , ' = ' , val , ';'.
	^ var! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:55'!
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 , ' . entry = (FUNC*) ' , funcName , ';'.
	myInits write: 'Obj_' , funcName , ' . name = Name_' , funcName , ';'.
	myInits write: 'Obj_' , funcName , ' . numArgs = ' , 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->self;'.
	body write: 'oop octx_' , lastN , '= closure->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 , '->function= OopFromHeader( & Obj_' , funcName , ' );'.
	contextStack size > 0
		ifTrue: [body write: z , '->context= octx_' , contextStack last , ';']
		ifFalse: [body write: z , '->context= 0;'].
	body write: z , '->self= v_self;'.
	^ 'o' , z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:54'!
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: 'Func_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:54'!
visitByteSymbol: aByteSymbol 
	^ aByteSymbol! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:54'!
visitCascadeNode: aCascadeNode 
	| result |
	result := 'OopNil'.
	aCascadeNode messages
		do: [:m | "
			--- Create a temporary MessageNode, so we can set its receiver
			correctly. Necessary because the receiver in the Cascade's
			MessageNodes is nil.
			The result of the last message in the cascade is our result. ---
			"
			result := self visitMessageNode: (MessageNode new receiver: aCascadeNode receiver;
							 selector: m selector;
							 arguments: m arguments)].
	^ result! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:53'!
visitLiteralNode: aLiteralNode 

	^ self literal: aLiteralNode eval.
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 10:37'!
visitLiteralVariableNode: aNode 

	| obj |
	obj := aNode key value.
	obj
		ifKindOf: Class
		thenDo: [:cls | 
			self addClassToMasters: 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 2/18/2006 23:09'!
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 specialConditional: 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 , ' = InternString("' , 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/18/2006 02:52'!
visitParseNode: aParseNode

	self error: 'Visiting unimplemented node type ', aParseNode asString
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:51'!
visitReturnNode: aReturnNode

	body write: 'return ', (aReturnNode expr acceptVisitor: self) , ';'.

	^ 'OopNOTREACHED'.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:53'!
visitSelectorNode: aSelectorNode

	^ aSelectorNode key asString.
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 02:51'!
visitTempVariableNode: aTempVariableNode 
	| var j |
	var := aTempVariableNode name.

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

	j := contextStack size.
	captureStack size
		to: 1
		by: -1
		do: [:i | (captureStack at: i) size > 0
				ifTrue: [((captureStack at: i)
							includes: var)
						ifTrue: [^ 'ctx_' , (contextStack at: j) asString , '->v_' , var , '/*level' , i asString , '*/'].
					j := j - 1]].
	^ 'v_' , var , '/*tempVar*/'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 21:54'!
visitVariableNode: aVariableNode 
	| var |
	var := aVariableNode name.
	"-- 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' ].

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


TestCase subclass: #CinnabarxUnitTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:39'!
assertEqualLists: x and: y

	self assert: x size = y size.

	1 to: x size do: [ :i | self assert: (x at: i) = (y at: i ) ].
! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 00:08'!
testAppleAndFib

	| d v i t |

	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.

	#( CinnabarTestFib CinnabarTestApple CinnabarTestFruit CinnabarTestGreenApple 
	) do: [ :clsName |

		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.

! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:41'!
testClassList


	| x y |

	x := { ProtoObject. Object. Behavior. ClassDescription. Class. ProtoObject class. Metaclass. Object class. Behavior class. ClassDescription class. Metaclass class. Class class }.

	y := (CinnabarxBase new addClassSupersAndMetas: Object) list.


	self assertEqualLists: x and: y.! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 00:01'!
testCleanStringMax

	| b |
	b := CinnabarxBase new.

	self assert: '' = (b cleanString: '' max: 3).

	self assert: 'abc' = (b cleanString: 'abc' max: 3).

	self assert: ' ' = (b cleanString: String cr max: 3).

	self assert: 'abc d...' = (b cleanString: 'abc', String lf, 'def' max: 5).
! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:47'!
testEscapeStringForC

	| b |
	b := CinnabarxBase new.

	self assert: '' = (b escapeStringForC: '').

	self assert: 'abc' = (b escapeStringForC: 'abc').

	self assert: 'foo bar' = (b escapeStringForC: 'foo bar').

	self assert: 'baz\015' = (b escapeStringForC: 'baz', String cr).

	self assert: 'baz\015\012' = (b escapeStringForC: 'baz', String cr, String lf).
! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:20'!
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 2/18/2006 13:19'!
testGenDeclarationsToFile

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

	b addImportantClasses.

	b doAll.

	b close.

! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:21'!
testGenInitializations

	| b result |
	b := CinnabarxGenInitializations 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 2/18/2006 13:18'!
testGenInitializationsToFile

	| b |
	b := CinnabarxGenInitializations new fileName: '_gen_inits.tmp'.

	b addImportantClasses.

	b doAll.

	b close.
! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:21'!
testGenVariables

	| b result |
	b := CinnabarxGenVariables 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 2/18/2006 13:19'!
testGenVariablesToFile

	| b |
	b := CinnabarxGenVariables new fileName: '_gen_objects.tmp'.

	b addImportantClasses.

	b doAll.

	b close.
! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/17/2006 23:58'!
testStringMax

	| b |
	b := CinnabarxBase new.

	self assert: '' = (b string: '' max: 3).

	self assert: 'abc' = (b string: 'abc' max: 3).

	self assert: 'ab...' = (b string: 'abc' max: 2).
! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 00:05'!
testTr

	| b |
	b := CinnabarxBase new.

	self assert: '' = (b tr: '').

	self assert: 'abc' = (b tr: 'abc').

	self assert: '$13$' = (b tr: String cr).

	self assert: '$43$$45$$42$$47$' = (b tr: '+-*/' ).

	self assert: 'Object$32$class' = (b tr: Object class asString).
! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 01:37'!
testTranslateClass

	| b |
	b := CinnabarxTranslateClass new fileStreamInMemory.

! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 2/18/2006 00:24'!
testWrite

	| b |
	b := CinnabarxBase new fileStreamInMemory.

	b write: 'abc'.
	b write: 'def{'.
	b write: 'ghi'.
	b write: 'jkl}'.
	b write: 'mno'.

	self assertEqualLists: (b split: b fileStream contents on: String lf) and: {
		'abc'.
		'def{'.
		'    ghi'.   " indented 4 spaces, due to 1 brace level "
		'jkl}'.
		'mno'.
	}.

! !


Object subclass: #ClassHacks
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!ClassHacks commentStamp: 'strick 1/20/2006 19:14' prior: 0!
Cinnabar ClassHacks is just a testbed.  The class is not needed.
!


!ClassHacks methodsFor: 'as yet unclassified' stamp: 'strick 12/4/2005 10:27'!
countGrope: aClass

	| subClasses numSubs |
	subClasses _ aClass subclasses.

	numSubs _ subClasses size.
	subClasses do: [:class | numSubs _ numSubs + self countGrope: class ].

	^numSubs! !

!ClassHacks methodsFor: 'as yet unclassified' stamp: 'strick 12/3/2005 17:34'!
grope: aClass

  | s z |

	s := Set new.
	
	s addAll: aClass subclasses.

     z _ s collect: [ :c |  self grope: c ] . 
     z add: aClass.

    ^z! !

!ClassHacks methodsFor: 'as yet unclassified' stamp: 'strick 12/4/2005 10:02'!
transGrope: aClass

	| setOfClasses |

	setOfClasses := (Set new).

	setOfClasses addAll: aClass subclasses.

	setOfClasses do: [:class | Transcript show: class name, ' '].

	Transcript show: '
'.
	setOfClasses do: [:class | self transGrope: class].! !