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 2/26/2006 17:14'!
literalArray: litArray 
	| n z |
	n := self serial asString.
	z := 'lit_' , n.
	declarations write: 'static oop ' , z , ';'.
	initializations write: z , '= BasicNewColon(PASS_VAT  & C_Array_TypeObj, ' , litArray size asString , ');'.
	initializations write: 'assert(' , z , ');'.
	1
		to: litArray size
		do: [:i | 
			| x y | 
			x := litArray at: i.
					y := self literal: x.
					initializations write: 'Prim_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarGenMethods methodsFor: 'visitors' stamp: 'strick 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 2/26/2006 17:14'!
visitBraceNode: aBraceNode 
	| n z e |
	e := aBraceNode elements.
	n := self serial asString.
	z := 'brace_' , n.
	body write: 'oop ' , z , '= BasicNewColon(PASS_VAT  & C_Array_TypeObj, ' , e size asString , ');'.
	body write: 'assert(' , z , ');'.
	1
		to: e size
		do: [:i | 
			| y |
			y := (e at: i) acceptVisitor: self.
			body write: 'Prim_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarGenMethods methodsFor: '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: #CinnabarTestCollections
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/19/2006 18:41'!
ttest00000NonLocalReturn

	| b |

	b := [ ^ true ].

	b value.  "-- this should cause return of true --"

	^ false.   "-- should not be reached --"! !

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/15/2006 21:28'!
ttest100factorial

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

	2432902008176640000 = z  ifFalse: [^false].

	^  2432902008176640000 = ( 20 factorial )
! !

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

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

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/19/2006 20:08'!
ttestBag

	| b |

	b := Bag new.
	#( 1 2 3 4 5 a b c d e a b c d e 1234567890123 1234567890124 ) do: [:x| b add: x].

	
	#( 1 2 3 4 5 1234567890123 1234567890124 ) do: [:x|
		[ 1 = ( b occurrencesOf: x) ] assert.
	].

	#( a b c d e ) do: [:x|
		[ 2 = ( b occurrencesOf: x) ] assert.
	].

	#( 10 100 1000 w x y z ) do: [:x|
		[ 0 = ( b occurrencesOf: x) ] assert.
	].

	^ true! !

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/24/2006 15:09'!
ttestDelimiter

	| d |
	d := FileDirectory primPathNameDelimiter.

	^ ( d == $/ "unix" ) | ( d == $\ "win" ) | ( d == $: "old mac" ).
! !

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

	| d |

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

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/18/2006 09:57'!
ttestKindOf

	[ 333333 isKindOf: SmallInteger ] assert.
	[ 333333333333 isKindOf: SmallInteger ] refute.


	^ true! !

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/19/2006 18:35'!
ttestNonLocalReturn

	| b |

	b := [ ^ true ].

	b value.  "-- this should cause return of true --"

	^ false.   "-- should not be reached --"! !

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

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

!CinnabarTestCollections methodsFor: 'as yet unclassified' stamp: 'strick 3/18/2006 18:35'!
xxxxxtestFraction	

	[ ( 123456789012345 / 9876543210987654321 ) numerator = 41152263004115 ] assert.

	[ ( 123456789012345 / 9876543210987654321 ) denominator = 3292181070329218107 ] assert.

	[ ( 12358024580135802457890 / 12345678901234567890 ) = 1001 ] assert.

	^ true! !


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 3/20/2006 09:02'!
iterativeTriange: n

"
	self new iterativeTriange: 5000
"

	| 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 3/20/2006 09:05'!
ttest0
	| fib1 fib3 fib5 fib20 |

	( 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.
	fib20_ self fib:20.

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

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

	(fib20) <  10946  ifTrue: [^false].
	 10946 < (fib20)  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 3/20/2006 09:03'!
ttest5m

	"
	self new ttest5m
	"
	1 to: 50 do: [ :i |
		[  12502500 = ( self iterativeTriange: 5000) ] assert
	].
	^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 3/1/2006 17:36'!
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 := {}.

	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 2/26/2006 17:03'!
ttestFactorial
	"^ 120 = (self new factorial: 5)"
	| expected |
	expected := 1.
	1
		to: 8
		do: [:i | 
			| got |
			i > 7 ifTrue: [
				'i=' say.
				i say.
			].
			"#(1 2 3 4 5 6 7 8) collect: [:x | x factorial]"
			"#(1 2 6 24 120 720 5040 40320)"
			"expected := i factorial."
			expected := expected * i.

			i > 7 ifTrue: [
			'expected' say.
			expected say.
			].
			got := self factorial: i.

			i > 7 ifTrue: [
			'got' say.
			got say.
			].
			expected == got
				ifFalse: [^ false]].
	^ true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 12:07'!
ttestIdentityDictionary

"
	| d |


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

	^ true! !

!CinnabarTestFib methodsFor: 'as yet unclassified' stamp: 'strick 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 methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 13:31'!
ttestWhileTrueColonUnflat

	| i z a b |

	i := z := 0.

	a := [ i <= 10 ].

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

	a whileTrue: b.

	^ z == 55! !

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

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: #CinnabarTestFloat
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

!CinnabarTestFloat methodsFor: 'as yet unclassified' stamp: 'strick 3/19/2006 21:11'!
ttest12

	[ 12.0 = ( 3.0 + 9.0 ) ] assert.
	[ 12.1 ~= ( 3.0 + 9.0 ) ] assert.
	[ 12.0 >= ( 3.0 + 9.0 ) ] assert.
	[ 12.1 >= ( 3.0 + 9.0 ) ] assert.
	[ 12.1 > ( 3.0 + 9.0 ) ] assert.
	[ 12.0 <= ( 3.0 + 9.0 ) ] assert.
	[ 12.0 <= ( 3.1 + 9.0 ) ] assert.
	[ 12.0 < ( 3.1 + 9.0 ) ] assert.

	[ 12.0 = 12 ] assert.

	^ true! !

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


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 3/5/2006 20:08'!
addImportantClasses

	self addClassSupersAndMetas: Object.
	self addClassSupersAndMetas: CinnabarxCFunction.
	self addClassSupersAndMetas: CinnabarxClosure.
	self addClassSupersAndMetas: CinnabarxContextBase.

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

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 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 3/6/2006 11:34'!
doAll

	howManyDone := 0.

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

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

	howManyDone := howManyDone + 1
! !

!CinnabarxBase methodsFor: 'as yet unclassified' stamp: 'strick 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 3/9/2006 08:56'!
generateClassDefinition: aClass useIfdef: useIfdef

	| className superClassName clsObjName superC fdn metatype |


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

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

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

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

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

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

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

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

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

		fdn ifNotNil: [
			(fdn extraFields at: aClass ifAbsent: [#()]) 
					do: [ :x | self write: 'oop ', x, ';' ].
		].

	self write: '/*' , aClass instSize asString , '*/ }'.
	self write: ';'.


	"--- be curious about big class objects ---"
	(('*$32$class' match: className)
			and: [11 ~= aClass instSize])
		ifTrue: [self write: '/*EXTRA CLASS VAR NAMES: ' , aClass instVarNames asString , '*/'].

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

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

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

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

	].
! !

!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 3/1/2006 17:28'!
nocomment: something 

	"-- don't write comment --"! !

!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 3/18/2006 20:52'!
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 codePoint < 128] and: [c isAlphaNumeric]]
	)
		ifTrue: [^ aString].


	^ aString
		inject: ''
		into: [:b :c | (c codePoint < 128 & 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 3/1/2006 22:23'!
closureOfSupers: aCollection 
"
self new closureOfSupers: #( IdentityDictionary )

(self new closureOfSupers: #( CinnabarTestFib CinnabarTestFruit CinnabarTestApple CinnabarTestGreenApple	Object True False Character 	UndefinedObject IdentityDictionary TranscriptStream SmallInteger ByteString ByteSymbol Array ) ) asArray sort
"

	^ self closureOfSupers: aCollection into: Set new
! !

!CinnabarxBigTests methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 22:23'!
closureOfSupers: aCollection into: aSet

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

	^ aSet.

! !

!CinnabarxBigTests methodsFor: 'as yet unclassified' stamp: 'strick 3/4/2006 22:58'!
testBig
"
self new testBig
"

	| d v i t list |

	d := CinnabarxGenDeclaratons new fileName: '_gen_header.h'.
	v := CinnabarxGenVariables new fileName: '_gen_objects.h'.
	i :=  CinnabarxGenInitializations new fileName: '_gen_inits.h'.

	d addImportantClasses.
	v addImportantClasses.
	i addImportantClasses.

	list := #( Integer ).

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


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

			t := CinnabarxTranslateClass new fileName: '_', clsName, '.cc'.
			t masterDecls: d masterVars: v masterInits: i.

			t translateClass: (Smalltalk at: clsName).

			t fileStream close.
		]
	].

	d doAll fileStream close.
	v doAll fileStream close.
	i doAll fileStream close.





! !


Object subclass: #CinnabarxCFunction
	instanceVariableNames: 'numArgs name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!CinnabarxCFunction commentStamp: '<historical>' prior: 0!
The runtime objects representing compiled C Functions for Smalltalk Blocks.  

An extra field 'x_entry' (not directly usable from Smalltalk) holds the memory address of the function (as a raw pointer with the low tag bit added so the garbage collector will ignore it).
  !



Object subclass: #CinnabarxClosure
	instanceVariableNames: 'function context myself id'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!CinnabarxClosure commentStamp: '<historical>' prior: 0!
The runtime closure objects representing Smalltalk Block Closures that can be sent #value...!



Object subclass: #CinnabarxContextBase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!
!CinnabarxContextBase commentStamp: '<historical>' prior: 0!
A base class for runtime context objects for holding captured variables that might be used my multple blocks and scopes!


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

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

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

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

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

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

!CinnabarxFirstPass 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) .
	]

! !

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

!CinnabarxFirstPass 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)].! !

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

	nil.! !

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

	nil.! !

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

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

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

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

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

	aReturnNode expr acceptVisitor: self
! !

!CinnabarxFirstPass methodsFor: 'as yet unclassified' stamp: 'strick 4/10/2006 00:33'!
visitTempVariableNode: v 
"--
	v name = 'notEmptyBlock' & (method selector = #ifEmpty:ifNotEmptyDo:)
		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']]! !

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

	nil.! !


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

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

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

	^ blockParents! !

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

	blockParents _ anObject! !

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

	^ blockStack! !

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

	blockStack _ anObject! !

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

	class _ anObject! !

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

	^ method! !

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

	method _ anObject! !

!CinnabarxFirstPass methodsFor: 'accessing' stamp: 'strick 12/29/2005 20:26'!
specialFlatCases
	"Answer the value of specialFlatCases"

	^ specialFlatCases! !

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

	specialFlatCases _ anObject! !


Object subclass: #CinnabarxFoundation
	instanceVariableNames: 'version decls vars inits model extraFields'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

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

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

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

	^ self closureOfSubs: aCollection into: Set new
! !

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

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

	^ aSet.

! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/6/2006 12:05'!
closureOfSupers: aCollection 
"
self new closureOfSupers: #( IdentityDictionary )

(self new closureOfSupers: #( CinnabarTestFib CinnabarTestFruit CinnabarTestApple CinnabarTestGreenApple	Object True False Character 	UndefinedObject IdentityDictionary TranscriptStream SmallInteger ByteString ByteSymbol Array ) ) asArray sort
"

	^ self closureOfSupers: aCollection into: Set new
! !

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

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

	^ aSet.

! !

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

	^ extraFields! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 19:10'!
generateDefinesForSymbolsTo: aDcls


	inits generateDefinesForSymbolsTo: aDcls
! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 4/8/2006 22:59'!
hugeArrayOfAllClasses

"
  self new hugeArrayOfAllClasses
"
	^ ( self closureOfSubs:  #(   ProtoObject  ))  asArray sort.
! !

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

	super initialize.

	version := DateAndTime now asSeconds.

	extraFields := IdentityDictionary new.

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

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


! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 15:32'!
intern: aSymbol

	^ inits ifNotNil: [inits intern: aSymbol]! !

!CinnabarxFoundation methodsFor: 'as yet unclassified' stamp: 'strick 4/9/2006 23:25'!
largeArrayOfClasses

"
  self new largeArrayOfClasses
"


	^ 
(
	(self closureOfSupers: 
		( self closureOfSubs: 
			#(  
				UndefinedObject True False Integer Character DateAndTime
				Behavior Set Array SequenceableCollection Magnitude Collection ParseNode
				CinnabarxCFunction CinnabarxClosure CinnabarxContextBase
	)))
	select: [:s| ( s beginsWith: 'B3D' ) not ]
) asArray sort.

! !

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

"
	self new mediumArrayOfClasses
"

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

! !

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

	^model! !

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

	model := aModelSymbol! !

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

	^ #( 
		CinnabarTestFib CinnabarTestFruit CinnabarTestApple CinnabarTestGreenApple
	) asArray sort.

! !

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

	self model: #incr.

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

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

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

			t translateClass: (Smalltalk at: clsName).

			t fileStream close.
		]
	].






! !

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

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

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

	decls addImportantClasses.
	vars addImportantClasses.
	inits addImportantClasses.

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

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

			t translateClass: (Smalltalk at: clsName).

			t fileStream close.
		]
	].

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





! !

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

	^ version! !

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

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 19:10'!
doAll

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

	super doAll.

	foundation generateDefinesForSymbolsTo: self.


	! !

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

	super doOneClass: aClass.

	self generateClassDefinition: aClass useIfdef: false.
! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 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 3/8/2006 21:46'!
foundation

	^ foundation! !

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

	foundation := f! !

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

	^ 1! !

!CinnabarxGenDeclaratons methodsFor: 'as yet unclassified' stamp: 'strick 2/28/2006 15:11'!
initialize

	super initialize.

	extraFields := IdentityDictionary new.

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

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


! !


CinnabarxBase subclass: #CinnabarxGenInitializations
	instanceVariableNames: 'symDict nextClassyNum nextTackyNum foundation symTable tBits tRange sBits sRange'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Cinnabar'!

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

	self doSymbols.

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

	super doAll.! !

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

	| className clsObjName |

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

	className := self tr: aClass name.

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


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

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/13/2006 08:23'!
doOneClass: aClass

	| className clsObjName |
	super doOneClass: aClass.


	className := self tr: aClass name.

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

	self write: ''.
	self write: 'ResetObject( & ',clsObjName,' );'.
	self write: clsObjName , '.setTypeNumber( C_', (self tr: aClass class name), '_TypeNumber );'.

	self write: clsObjName , '.setAge( AGE_IMMORTAL );'.
	self write: clsObjName , '.setHash( C_' , className , '_TypeNumber );'.
	self write: clsObjName , '.x_typeNumber = OopFromNum( C_' , className , '_TypeNumber );'.
	self write: clsObjName , '.f_format = OopFromNum( ',aClass format asString,' );'.
	self write: clsObjName , '.x_name = OopFromHeader( SymbolTable[', (self intern: aClass name), '] );'.
	aClass superclass ifNil: [		
		self write: clsObjName , '.f_superclass = OopNil;'.
	] ifNotNil: [
		self write: clsObjName , '.f_superclass = OopFromHeader(& C_' ,(self tr: aClass superclass name) , '_ClsObj);'.
	].

	aClass isVariable
		ifFalse: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_NONE);' ]
		ifTrue: [
			aClass isBits
				ifTrue: [
					aClass isBytes
						ifTrue: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_BYTES);']
			 			ifFalse: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_WORDS);'].
				]
			 	ifFalse: [ self write: clsObjName , '.x_arrayShape = OopFromNum(ARRAY_OOPS);'].
		].

	self write: clsObjName , '.x_numFixedOops = OopFromNum((sizeof(C_',className,')-sizeof(Header))/sizeof(word));'.

	"<<self write: '// ' , aClass allInstVarNames asString.>>"

	self write: ''.
! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 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: ''.! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/18/2006 20:48'!
doSymbols

	symDict keys asArray sort do: [ :s |

		self write: 'InternSymbolAt( "', (self escapeStringForC: s), '", ', (symDict at: s),' );'.

	].
 ! !

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

	foundation := f! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 19:21'!
generateDefinesForSymbolsTo: aDcls

	symDict keys asArray sort do: [ :s |

		aDcls write: '#define Sym_', (self tr: s), ' ', (symDict at: s) asString.

	].! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 21:17'!
initialize

	tBits :=  15.
	tRange := 1 bitShift: tBits.

	sBits :=  32 - tBits.
	sRange := 1 bitShift: sBits.

	symDict := Dictionary new.
	symTable := Array new: sRange.

	self intern: #SmallInteger.		"must be 0"
	self intern: #ByteSymbol.	

	super initialize.! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 19:13'!
insertSymbol: sym starting: start range: range

	"---add one to index of symTable, so it is 0-based---"

	| h |

	h := (self stringHash: sym) \\ range.

	start+h to: start+range-1 do: [ :i |
		(symTable at: i+1) ifNil: [
			symTable at: i+1 put: sym.
			symDict at: sym put: i.
			^ i asString
		]
	].
 
	start to: start+h-1 do: [ :i |
		(symTable at: i+1) ifNil: [
			symTable at: i+1 put: sym.
			symDict at: sym put: i.
			^ i asString
		]
	].
 
	self error: 'Symbol table is full'
! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 19:12'!
intern: sym

	"-- returns the SymbolTable index of the sym, inserting it if absent --"


	^ symDict at: sym ifAbsentPut: [

		(self stringIsClassy: sym) ifTrue: [

			self insertSymbol: sym starting: 0 range: tRange

		] ifFalse: [

			self insertSymbol: sym starting: tRange range: sRange - tRange

		]

	]! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 18:43'!
stringHash: s

"
	(self new stringHash: #SmallInteger)
"

	"--- 28bit hash of string -- The constant  171460249 is added to make SmallInteger have hash 0 ---"


	^ ( 
		s inject: 0 into: [:z :c | (z*7 + c codePoint) bitAnd: 16rFFFFFFF ]
       ) +  171460249 bitAnd: 16rFFFFFFF! !

!CinnabarxGenInitializations methodsFor: 'as yet unclassified' stamp: 'strick 3/17/2006 18:37'!
stringIsClassy: s

	"if it begins with a Capital Letter, it is Classy"

	^  (s size > 0) and: [$A <= s first] and: [s first <= $Z]
! !

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

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

	| className clsObjName |
	super doOneClass: aClass.


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

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

!CinnabarxGenVariables methodsFor: 'as yet unclassified' stamp: 'strick 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 , ';'.
	].! !

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

	foundation := f! !

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

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

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.

	f translateClassesIncr:  f smallArrayOfClasses.


! !

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

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

"
	self new testDoTranslate
"

	| f |

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

! !

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

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

"
	self new testDoTranslate
"

	| f |

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

! !

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

!CinnabarxTestNextIncrModel methodsFor: 'as yet unclassified' stamp: 'strick 4/8/2006 17:53'!
testDoTranslate

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.

	f translateClassesIncr:  #( CinnabarTestCollections CinnabarTestFloat EncodedCharSet FileDirectory FloatArray CinnabarTestFib CinnabarTestFruit CinnabarTestApple CinnabarTestGreenApple   ).


! !

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

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

"
	self new testDoTranslate
"

	| f |

	f := CinnabarxFoundation new.

	f translateClassesIncr: #( CinnabarTestFib ).

! !

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

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

"
	self new testDoTranslate
"

	| f |

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

! !

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 11:46'!
aboutUnknownISSUES

"<<

Object decompile: #caseOf:
  the printing of the decompile is WRONG:  (* 
   caseOf: t1 
	^ self caseOf: t1
*)
   The message-send (really to #caseOf:otherwise:) is special: 14.
DOES NOT SEEM TO BE ANY ACTUAL SENDERS OF #caseOf: NOR OF #caseOf:otherwise:

MessageNode class initialize
(*
    	MacroSelectors _ 
		#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:
			and: or:
			whileFalse: whileTrue: whileFalse whileTrue
			to:do: to:by:do:
			caseOf: caseOf:otherwise:
			ifNil: ifNotNil:  ifNil:ifNotNil: ifNotNil:ifNil:).
... and more ... *)

--------------------------------------------------------

Smalltalk keys select: [ :k |  (Smalltalk at: k) isBehavior not ] 
   an IdentitySet(#Undeclared #Transcript #Smalltalk #ScheduledControllers #WonderlandConstants #Sensor #ActiveEvent #References #SourceFiles #ActiveHand #SystemOrganization #World #ScriptingSystem #Processor #ImageImports #ActiveWorld #Display #TextConstants #CustomEventsRegistry)
----------------------------------------------------------

>>"! !

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

	foundation addClassToFoundation: aClass

! !

!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 3/18/2006 20:16'!
declareClassVariables

	[ theClass isMeta not ] assert.   "should be the real class"

	theClass allClassVarNames do: [:cv|  |cvar|

		cvar := 'ClsVar_', theClass name, '_', cv.

		self write: 'static oop ', cvar, ';'.

	].
! !

!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 4/9/2006 01:52'!
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 nocomment: '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 nocomment: 'captureStack: ' , captureStack asString.
	body nocomment: 'contextStack: ' , contextStack asString.
	body nocomment: 'blockStack: ' , blockStack size asString.
	"-" 
		captures do: [:v | body comment: '!!!!!!!! CAPTURED: ' , v asString ].
	"-"
	"==="
	aScope temporaries
		do: [:t | (captures includes: t)
				ifFalse: [body write: 'oop v_' , t name , '= OopNil; /* define temp */']].
	"==="
	captures size > 0
		ifTrue: [n := self serial asString.
			myDecls write: 'struct context_' , n , ' : public C_CinnabarxContextBase {'.
			contextStack size > 0
				ifTrue: [myDecls write: 'oop octx_' , lastN , ';'].

			"--alphabetize--"
			(captures inject: OrderedCollection new into: [:z :x| z add: x name; yourself]) 
				asArray sort do: [:v | myDecls write: 'oop v_' , v, ';'].

			myDecls write: '}'.
			myDecls write: ';'.
			body write: 'oop octx_' , n , '= BasicNewColon(PASS_VAT  &C_Array_ClsObj, ' , (captures size + 1) asString , ' );'.
			body write: 'context_' , n , ' * ctx_' , n , '= (context_' , n , '*) OopToHeader( octx_' , n , ');'.
			contextStack size > 0
				ifTrue: [lastN := contextStack last.
					body write: 'ctx_' , n , '->octx_' , lastN , '= octx_' , lastN , ';'].
			captures
				do: [:v | (argNames includes: v name)
						ifTrue: [body write: 'ctx_' , n , '->v_' , v name , ' = v_' , v name , ';']
						ifFalse: [body write: 'ctx_' , n , '->v_' , v name , ' = ' , 'OopNil;']
				].
			contextStack addLast: n.
			body nocomment: 'pushed to ' , contextStack asString
		]
		ifFalse: [body nocomment: 'no captures, so dont push to ' , contextStack asString]! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 17:30'!
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 nocomment: 'exitScope: removeLast from ' , contextStack asString.
			contextStack removeLast]
		ifFalse: [body nocomment: '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 nocomment: 'Exiting Scope: ', aScope asString.
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 4/9/2006 00:56'!
flattenBlockNode: aBlockNode 
	| n z i numStatements |

	aBlockNode class == BlockNode ifFalse: [ ^ self flattenNonBlockNode: aBlockNode ]. 


	n := self serial asString.

	(firstPass blockIsFlat: aBlockNode)
		ifTrue: [self enterScope: aBlockNode. z := 'flat_' , n.  ]
		ifFalse: [ z := 'unflat_' , n. ].

	body write: 'oop ' , z , '= OopNil;'.

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

	aBlockNode temporaries ifNotNil: [
		aBlockNode temporaries  do: [ :t |
			body write: 'oop v_', t key asString, '= OopNil; /*temp in flattenBlockNode*/'.
	]].  

	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 3/1/2006 22:25'!
flattenNonBlockNode: aNode
	| msg |

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

	"-- create a synthetic MessageNode to send #value to the node. --"

	msg := MessageNode new.

	msg receiver: aNode.
	msg selector: ( SelectorNode new key: #value; yourself ).
	msg arguments: #().

	^ msg acceptVisitor: self.	

! !

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

	^ foundation! !

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

	foundation := aCinnabarxFoundation.

	#small == foundation model   ifTrue: [

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

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

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

	self generateClassDefinition: aClass useIfdef: true.


! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:42'!
generateMethodInstalls

	" --- install methods for theClass itself "

	theClass methodDict keys size = 0 ifTrue: [
		self write: 'InsertNoFunctions(cls);'
	] ifFalse: [
		theClass methodDict keys asArray sort do: [ :k |  | kk |  kk := self tr: k.

			self write: '{'.
			#incr == foundation model ifTrue: [
				self write: 'Symbol* s= InternSymbol( "', (self escapeStringForC: k), '" );'.
			] ifFalse: [
				self write: 'Symbol* s= SymbolTable[', (foundation intern: k), '];'.
			]. 

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

			self write: '}'.
		].
	].

	" --- install methods for the metaclass "
	theClass class methodDict keys size = 0 ifTrue: [
		self write: 'InsertNoFunctions(superCls);'
	] ifFalse: [
		theClass class methodDict keys asArray sort do: [ :k |  | kk |  kk := self tr: k.

			self write: '{'.
			#incr == foundation model ifTrue: [
				self write: 'Symbol* s= InternSymbol( "', (self escapeStringForC: k), '" );'.
			] ifFalse: [
				self write: 'Symbol* s= SymbolTable[', (foundation intern: k), '];'.
			]. 


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

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/5/2006 21:03'!
initialize

	super initialize.

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

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

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

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

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

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

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

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

	specialCases
		at: #say put: #messageSay: ;
		
		at: #error: put: #messageErrorColon: .

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/18/2006 20:26'!
initializeClassVariables

	[ theClass isMeta not ] assert.   "should be the real class"

	theClass allClassVarNames do: [:cv|  |cvar|

		cvar := 'ClsVar_', theClass name, '_', cv.

		myInits write: cvar, '= ', (self literal: (theClass classPool at: cv ifAbsent: [nil])), ';'.
	].
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/19/2006 21:29'!
literalArray: litArray 

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

	| n z |

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

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

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

	"BUG: expecting the litArray class to be precompiled in the foundation"
	myInits write: z , '= BasicNewColon(PASS_VAT  & C_',litArray class name,'_ClsObj, ' , litArray basicSize asString , ');'.
	myInits write: 'assert(' , z , ');'.

	1 to: litArray basicSize do: [:i | 

			myInits write: 
					'Prim_BasicAtPut(PASS_VAT  ' , 
					z , 
					',  NULL, OopFromNum(' , i asString , '), ' , 
					(self literal: (litArray basicAt: 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 3/17/2006 15:54'!
literalByteSymbol: lit 
	| n z |

z := self foundation  intern: lit.

z  ifNotNil: [
	z := 'OopFromHeader(SymbolTable[', z asString, '/*',(self escapeStringForC: lit),'*/])'
] ifNil: [
	n := self serial asString.
	z := 'sym_' , n.

	" --- TODO --- collaps these into single instance of each symbol --- "

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

	myInits write: z , '= OopFromHeader( InternSymbol( "', (self escapeStringForC: lit) , '") );'.
	myInits write: 'assert(' , z , ');'.
].

^ z.! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/18/2006 20:20'!
literal: x 

	x == nil
		ifTrue: [^ 'OopNil' ].
	x == false
		ifTrue: [^ 'OopFalse' ].
	x == true
		ifTrue: [^ 'OopTrue' ].
	x class == SmallInteger
		ifTrue: [^ 'OopFromNum(' , x asString , ')'].
	x class == Character
		ifTrue: [^ 'OopFromHeader(&CharInstances[' , x codePoint asString , '])'].
	x class == Array
		ifTrue: [^ self literalArray: x].
	x class == ByteString
		ifTrue: [^ self literalByteString: x].
	x class == ByteSymbol
		ifTrue: [^ self literalByteSymbol: x].

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

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/2/2006 20:09'!
masterDecls: d masterVars: v masterInits: i

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

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

	| n z rcvr arg1 |

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

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

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

	^ z! !

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

	| n z rcvr |

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

	rcvr := aMessageNode receiver acceptVisitor: self.

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

	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 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 14:48'!
messageConditional: aMessageNode

	
	| n rcvr nargs arg1 arg2 z |

	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 , '*/'.

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

	| n z rcvr arg1 |

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

	aMessageNode arguments size == 1 
	ifTrue: [

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

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

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

	] ifFalse: [ 

		self error: 'Not a binop'

	].

	^ z
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 22:01'!
myInits

	^ myInits! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/19/2006 19:32'!
nonLocalReturn:  x

	nonLocalReturnUsed := true.

	body write: 'return StartNonLocalReturn(PASS_VAT  contextId, ',x,' );'.

	^ 'OopNOTREACHED'.
! !

!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 3/19/2006 18:51'!
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.
	
	nonLocalReturnUsed := false.
! !

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

	^ nextSerialNumber := nextSerialNumber + 1! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/26/2006 11:22'!
specialCaseOf: aMessageNode
	
	^ self unimplemented: 'Unsupported #caseOf:... Message Node (may not print correctly) :', aMessageNode asString
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/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/24/2006 17:19'!
specialForLoop: aMessageNode 
	| n rcvr argTo argBy block |


	body comment: 'Special For Loop...'.

	n := self serial asString.
	"---"
	rcvr := aMessageNode receiver acceptVisitor: self.

	(aMessageNode arguments at: 7 ifAbsent: [nil] ) ifNotNil: [
		"These have an AssignmentNode for the *LimiT temporary at 7"
		body comment: 
			'(*',aMessageNode arguments first asString,'*) ', 
					(aMessageNode arguments at: 7) asString.
		argTo := (aMessageNode arguments at: 7) "(AssignmentNode)" value acceptVisitor: self.
	] ifNil: [
		argTo := aMessageNode arguments first acceptVisitor: self.
	].
	argBy := aMessageNode arguments second acceptVisitor: self.

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

	"--- if these are known constants, this will vanish by C++ optimizer:"
	body write: 'if (!!(1&(word)(' , rcvr , ')&(word)(' , argTo , ')&(word)(' , argBy , '))) {'.
	body write: 'SetVatErrorString(PASS_VAT  "to:by:do: requires SmallIntegers");'.
	body write: 'goto ERROR;'.
	body write: '}'.
	"---"
	body write: 'num i_' , n , ' = OopToNum(' , rcvr , ');'.
	body write: 'num to_' , n , ' = OopToNum(' , argTo , ');'.
	body write: 'num by_' , n , ' = OopToNum(' , argBy , ');'.
	"--- if by: is known constant, this will simplify by -O:"
	body write: 'for ( ; (by_' , n , '>0) ? (i_' , n , '<=to_' , n , ') : (i_' , n , '>=to_' , n , ') ; i_' , n , '+=by_' , n , ') {'.
	"--- expand the do: block"
	block := aMessageNode arguments third.
	body write: 'oop v_' , block arguments first name , ' = OopFromNum(i_' , n , ');'.
	self flattenBlockNode: block.
	"---"
	body write: '}'.
	^ 'OopNil'! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/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 3/18/2006 20:30'!
translateClass: aClass

	theClass := aClass.

	self addClassToFoundation: aClass.

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

	self declareClassVariables.

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

	self translateMethodsOf: aClass.
	self translateMethodsOf: aClass class.

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

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

	myDecls := myInits.  "any decls now must go into the init stream"
	self initializeClassVariables.

	self fileStream nextPutAll: myInits fileStream contents.

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

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 4/8/2006 20:00'!
translateMethod

|  selector bNode argVars funcName cc mm namedPrim lits |

	nonLocalReturnUsed := false.

	selector := method selector asString.
	cc := (self tr: theClass name).
	mm := (self tr: selector).
	funcName := 'Func_', cc, '_', mm.

	firstPass := CinnabarxFirstPass new
				visitMethodNode: method
				forClass: theClass
				for: self.
	"*** firstPass inspect. ***"

	bNode := method block.
	argVars := method arguments
				collect: [:var | var acceptVisitor: self].
	body write: 'oop ' , funcName , '(PARM_VAT   oop v_self, Symbol* selector'
				, (self declareParameters: argVars) , ') {'.


	( method primitive > 0 ) ifTrue: [

self comment: 'PRIMITIVE(',method primitive asString,')====> ',
"method primitiveNode spec asString"
(method encoder literals size > 0 
ifTrue: [method encoder literals first asString]
ifFalse: [ 'EMPTY' ]
), '  ...'.


	 (117 == method primitive) ifTrue: [ | npFirst |
	  "NAMED"
		lits := method encoder literals.
		namedPrim := lits first.
		npFirst := namedPrim first ifNil: [ 'nil' ].
		body write: 'static void* primf;'.
		body write: 'primf= primf? primf: FindNamedPrimitive(PASS_VAT  "', npFirst, '","', namedPrim second,'");'.
		body write: 'if (primf) {'.
		body write: 'oop primout= CallNamedPrimitive(PASS_VAT  primf, v_self, selector',
			(argVars inject: '' into: [ :aa :a | aa, ', ', a ]),
			');'.
		body write: 'if (primout) return primout;'.
		body write: '}'.

       ] ifFalse: [
	  "NOT NAMED.... Ignore or Not?"
	  (256 <= method primitive & (method primitive <= 519)) ifTrue: [
		"range 256..519 are optional and of no benefit to cinnabar because they are too trivial"
		"IGNORED"
		body comment: 'Ignoring Optional Primitive ', method primitive asString.
	  ] ifFalse: [
		"NOT INGORED"
		body write: '#ifdef Primitive', method primitive asString.
		body write: 'oop primout= Primitive', method primitive asString,
			'((PASS_VAT  v_self, selector',
			(argVars inject: '' into: [ :aa :a | aa, ', ', a ]),
			'));'.
		body write: 'if (primout) return primout;'.
		body write: 'ReportPrimitiveFailed(',
				method primitive asString, ' , "', funcName, '" );'.
		body write: '#else'.
		body write: 'ReportPrimitiveMissing(',
				method primitive asString, ' , "', funcName, '" );'.
		body write: '#endif'.
	  ].
	 ].
	].

	"-- TODO: eliminate this when you won't need it --"
	"-- TODO: get it from VAT if threaded --"
	body write: 'oop contextId= OopFromNum(++NextContextId);'.

	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: '}'.
	(nonLocalReturnUsed or: [( body fileStream contents findString: 'ERROR') > 0]) ifTrue: [ "--if the test slows things down, always generate:--"
		body write: ' ERROR:'.
		nonLocalReturnUsed ifTrue: [
			body write: '  if (contextId == vat->return_to) return FinishNonLocalReturn(PASS_VAT_ONLY);'.
		].
		body write: '  AddVatErrorString(PASS_VAT  "in ' , theClass name , '>>' , (self escapeStringForC: selector) , ' ...");'.
		body write: '   return (oop)0;'.
	].
	body write: '}'.

	body write: 'Function F_' , funcName , ';'.
	"==============================="
	self exitScope: method.
	"======================================================="
	myInits write: 'F_' , funcName , '.x_entry = OopWrapPointer( (void*)' , funcName , ');'.
	myInits write: 'F_' , funcName , '.f_name = Str(PASS_VAT "' , theClass name , '>>' , (self escapeStringForC: selector), '");'.
	self resetFunction.

! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 4/10/2006 00:39'!
translateMethodsOf: theClassOrItsClass

	| saveTheClass useDecompiler |

	useDecompiler := false.

	"TODO -- debug these cases.  For now, they must set useDecompiler to true."
	theClass == Collection ifTrue: [ useDecompiler := true ].  "problem in ifEmpty:ifNotEmptyDo:"
	theClass == CompiledMethod ifTrue: [ useDecompiler := true ].  "another problem"


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

	theClass methodDict keys asArray sort do: [ :selector | 

		method := useDecompiler ifTrue: [  
				theClass decompile: selector.
		] ifFalse: [
				Parser new parse: (theClass sourceMethodAt: selector) class: theClass.
		].
		
		self translateMethod.

	].

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

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/1/2006 22:31'!
unimplemented: x 

	body write: 'SetVatErrorString(PASS_VAT  "UNIMPLEMENTED: ' , (self escapeStringForC: 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 3/19/2006 19:08'!
visitBlockNode: aBlockNode 
	"<< Push the blockNode & recurse.
	This is what is called when we do NOT flatten a Block, as we do for #ifTrue:ifFalse:
	and other frequent flattenable methods.  
	See #flattenBlockNode for the flattened version.
	>>"


	| lastN n z funcName argVars result summary prev |

	"=================== try enterScope ========================"
	n := self serial asString.
	z := 'closure_' , n.
	lastN := contextStack size > 0
				ifTrue: [contextStack last]
				ifFalse: ['000'].
	funcName := 'block_' , n.
	argVars := aBlockNode arguments
				collect: [:v | 'v_' , v name].

	"========================================================"
	self pushFunction.
	"=============================="

	summary := self
				escapeStringForC: (self cleanString: aBlockNode asString max: 80).
	body write: ''.
	body write: 'static char Name_' , funcName , '[] = "[] in ' , theClass name , '>>' , method selector , '  /*' , funcName , '*/  ' , summary , '";'.
	body write: 'static Function Obj_' , funcName , ';'.
	body write: ''.
	myInits write: 'Obj_' , funcName , ' . x_entry = OopWrapPointer( (void*)' , funcName , ');'.
	myInits write: 'Obj_' , funcName , ' . f_name = Str(PASS_VAT  Name_' , funcName , ');'.
	myInits write: 'Obj_' , funcName , ' . f_numArgs = OopFromNum(' , argVars size asString , ');'.
	myInits write: 'Obj_' , funcName , ' . setTypeNumber( Func_TypeNumber );'.

	"=============== generate block function ================="
	body write: 'static oop ' , funcName , '(PARM_VAT'.
	body write: '   Closure* closure '.
	body
		write: (self declareParameters: argVars).
	body write: ') {'.
	body write: 'oop contextId= closure->f_id;'.
	body write: 'oop v_self= closure->f_myself;'.
	body write: 'oop octx_' , lastN , '= closure->f_context;'.
	body write: '///===contextStack=== ' , contextStack asString.
	contextStack size > 0
		ifTrue: [body write: 'context_' , lastN , ' * ctx_' , lastN , ' = (context_' , lastN , '*) OopToHeader( octx_' , lastN , ' );'.
			prev := 'ctx_' , lastN].
	"this will be wrong for methods on num/SmallInteger"
	theClass == SmallInteger
		ifFalse: [body write: 'C_' , (self tr: theClass name) , '* self= (C_' , (self tr: theClass name) , '*) OopToHeader(v_self);'].
	contextStack size - 1
		to: 1
		by: -1
		do: [:i | 
			| nn | 
			nn := (contextStack at: i) asString.
			body write: 'context_' , nn , ' * ctx_' , nn , ' = (context_' , nn , '*) OopToHeader( ' , prev , '->octx_' , nn , ' );'.
			prev := 'ctx_' , nn].

	self enterScope: aBlockNode.
	result := self flattenBlockNode: aBlockNode.
	self exitScope: aBlockNode.
	body write: '/*END*/ return ' , result , ';'.
	body write: 'ERROR: AddVatErrorString(PASS_VAT  Name_' , funcName , ' );'.
	body write: 'return OopGOTO;'.
	body write: '}'.

	"=============================="
	self popFunction.
	"=============================================================="

	body write: 'oop o' , z , '= BasicNew(PASS_VAT  &ClosureType);'.
	body write: 'Closure* ' , z , '= (Closure*) OopToHeader( o' , z , ');'.
	body write: z , '->f_function= OopFromHeader( & Obj_' , funcName , ' );'.
	contextStack size > 0
		ifTrue: [body write: z , '->f_context= octx_' , contextStack last , ';']
		ifFalse: [body write: z , '->f_context= 0;'].
	body write: z , '->f_myself= v_self;'.
	body write: z , '->f_id= contextId;'.
	^ 'o' , z
! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/27/2006 09:43'!
visitBraceNode: aBraceNode 
	| n z e |
	e := aBraceNode elements.
	n := self serial asString.
	z := 'brace_' , n.
	body write: 'oop ' , z , '= BasicNewColon(PASS_VAT  & C_Array_ClsObj, ' , e size asString , ');'.
	body write: 'assert(' , z , ');'.
	1
		to: e size
		do: [:i | 
			| y |
			y := (e at: i) acceptVisitor: self.
			body write: 'Prim_BasicAtPut(PASS_VAT  ' , z , ',  NULL, OopFromNum(' , i asString , '), ' , y , ');'].
	^ z! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 2/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 4/9/2006 01:06'!
visitLiteralVariableNode: aNode 

	| obj myClass k |
	k := aNode key.
	( k class == ByteString ) ifFalse: [ k := k key ].
	obj := aNode key value.
	obj
		ifKindOf: Class
		thenDo: [:cls | 

				| n z |
				n := self serial asString.
				z := 'cls_' , n, '_', cls name.

	body write: '#ifdef C_',cls name,'_TypeNumber'.

	body write: 'oop ', z,'= OopFromHeader(&C_' , cls name , '_ClsObj);'.

	body write: '#else'.

	body write: 'Type* ', z,'_typePtr= TypeTable[ OopToHeader(', (self literalByteSymbol: cls name), ') ->hash() ];'.
	body write: 'if ( !! ', z, '_typePtr ) {'.
	self unimplemented: 'Missing From TypeTable: ', cls name.
	body write: '}'.
	body write: 'oop ', z,'= OopFromHeader( ',z,'_typePtr );'.

	body write: '#endif'.

			self addClassToFoundation: cls.
			^ z
		].

	(k = #Smalltalk) ifTrue: [ ^ 'OopSmalltalk' ].

	"--Transcript does not need to be special--"
	"<<--  (k = #Transcript) ifTrue: [ 	^ 'OopTranscript' ].  -->>" 

	"---perhaps it is a class variable---"
	myClass := theClass isMeta ifTrue: [ theClass soleInstance ] ifFalse: [ theClass ].
	( myClass allClassVarNames includes: k ) ifTrue: [

		^ 'ClsVar_', myClass name, '_', k.

		"<< ^ (self literal: (myClass classPool at: k)),'/*ClassVar ASSUMED READONLY: ',k,'*/'. >>" 
	].

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

! !

!CinnabarxTranslateClass methodsFor: 'as yet unclassified' stamp: 'strick 3/8/2006 20:36'!
visitMessageNode: aMessageNode 
	| n z msgSelector msgReceiver argList funcType cacheNum symtab |

"<< These are the values of 'special' -- MessageNode::MacroEmitters --
 #( 1 #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: #emitIf:on:value: 7 #emitWhile:on:value: #emitWhile:on:value: #emitWhile:on:value: #emitWhile:on:value: 11 #emitToDo:on:value: #emitToDo:on:value: 13 #emitCase:on:value: #emitCase:on:value: 15 #emitIfNil:on:value: #emitIfNil:on:value: 17 #emitIf:on:value: #emitIf:on:value: 19)
>>"

	body comment: aMessageNode.
	msgSelector := aMessageNode selector acceptVisitor: self.
	"*** Check to see if the message is a special case before you go any
	further "


	(aMessageNode special ~~ nil and: [aMessageNode special > 0]) ifTrue: [
		body comment: 'SPECIAL TYPE ', aMessageNode special asString, ' #', msgSelector.
		(aMessageNode special < 7) ifTrue: [ ^ self specialConditional: aMessageNode ].
		(aMessageNode special < 11) ifTrue: [ ^ self specialWhileLoop: aMessageNode ].
		(aMessageNode special < 13) ifTrue: [ ^ self specialForLoop: aMessageNode ].
		(aMessageNode special < 15) ifTrue: [ ^ self specialCaseOf: aMessageNode ].
		(aMessageNode special < 19) ifTrue: [ ^ self specialConditional: aMessageNode ].
		^ self unimplemented: 'Special Message Type ', aMessageNode special asString.
	].

	(specialCases includesKey: msgSelector)
		ifTrue: [^ self
				perform: (specialCases at: msgSelector)
				with: aMessageNode].


	"*** Normal messages continue here."
	n := self serial asString.
	z := 'send_' , n.

	#incr == foundation model ifTrue: [
		myDecls write: 'static Symbol* sym_',n,';'.
		myInits write: 'sym_',n,'= InternSymbol( "', (self escapeStringForC: msgSelector), '" );'.
		symtab := 'sym_',n.
	] ifFalse: [
		symtab := 'SymbolTable[' , (foundation intern: msgSelector) , ']'.	
	].
	cacheNum := senderCacheArraySize asString.
	senderCacheArraySize := senderCacheArraySize + 1.



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


	body write: '{'.
	msgReceiver := aMessageNode receiver acceptVisitor: self.

	argList := self passArgumentVariables: aMessageNode arguments.
	( aMessageNode receiver class == VariableNode 
		and: [ aMessageNode receiver name = 'super' ]
	) ifTrue: [
		"--- send to super --- based on static superclass"
		body write: 'word typeNumber= C_', (self tr: theClass superclass name), '_TypeNumber;'.
		body comment: 'Sending To Super...'.
	] ifFalse: [
		"--- normal send --- based on runtime type"
		body write: 'word typeNumber= OopToTypeNumber(' , msgReceiver , ');'.
	].
	body write: 'BIND_CACHE( Cache[' , cacheNum, '], typeNumber, ', symtab,' );   /* ' , msgSelector , ' */'.
	funcType := 'FUNC' , aMessageNode arguments size asString , '*'.
	body write: funcType , ' f= (' , funcType , ') Cache[' , cacheNum, '].func;'.
	body write: z , '=  f(PASS_VAT  ' , msgReceiver , ', ', symtab , argList , ');'.
	body write: 'if (!!' , z , ') goto ERROR;'.
	body write: '}'.
	^ z! !

!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 3/19/2006 18:55'!
visitReturnNode: aReturnNode

	( 0 == saveStack size ) ifTrue: [

		"---- at toplevel, simply make the function return what you want ----"
	
		body write: 'return ', (aReturnNode expr acceptVisitor: self) , ';'.

	] ifFalse: [

		"---- if inside a Block, cause a non-local GOTO back to the home scope ----"

		self nonLocalReturn: (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 4/8/2006 20:29'!
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/26/2006 11:58'!
visitVariableNode: aVariableNode 
	| var |
	var := aVariableNode name.

	"-- compiler uses LiteralVariableNode, but decompiler just uses VariableNode, for these: --"
	( $A <= var first and: [ var first <= $Z ] ) ifTrue: [
		^ self visitLiteralVariableNode: aVariableNode
	].
 
	"-- check first for reserved names --"
	var = 'true'
		ifTrue: [^ 'OopTrue'].
	var = 'false'
		ifTrue: [^ 'OopFalse'].
	var = 'nil'
		ifTrue: [^ 'OopNil'].
	var = 'self'
		ifTrue: [^ 'v_self'].
	var = 'super'
		ifTrue: [^ 'v_self'   "-- for super, the object is self -- but the dispatch is different --" ].
	var = 'thisContext'
		ifTrue: [^ self unimplemented: 'thisContext' ].
	var = 'Smalltalk'
		ifTrue: [^ self unimplemented: 'Smalltalk' ].

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


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/20/2006 13:40'!
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 CinnabarTestFruit CinnabarTestApple 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 3/7/2006 23:42'!
testGenDeclarations

	| b result |
	b := CinnabarxGenDeclaratons new fileStreamInMemory.

	b addImportantClasses.

	b doAll.

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

! !

!CinnabarxUnitTests methodsFor: 'as yet unclassified' stamp: 'strick 3/7/2006 23:42'!
testGenDeclarationsToFile

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

	b addImportantClasses.

	b doAll.

	b close.

! !

!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 2/24/2006 17:09'!
questions

	( Metaclass allInstances collect: [ :m | m theNonMetaClass instVarNames ] )

	CinnabarTestFib decompile: #fib: .


	( Metaclass allInstances collect: [ :m | m soleInstance] ) select: [ :c | (c theNonMetaClass instVarNames size > 0) and: [c isVariable] ] . 

	#(PseudoContext BlockContext MethodContext WeakMessageSend SparseLargeTable B3DSimpleMesh B3DSimpleMeshFace)

! !

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