1 files changed, 609 insertions, 0 deletions
diff --git a/src/cgil/rlhc-ocaml.lm b/src/cgil/rlhc-ocaml.lm
new file mode 100644
index 00000000..f68b61be
--- /dev/null
+++ b/src/cgil/rlhc-ocaml.lm
@@ -0,0 +1,609 @@
+include 'ril.lm'
+
+namespace ocaml_out
+	token _IN_ /''/
+	token _EX_ /''/
+
+	lex
+		token comment /
+			'(*' any* :>> '*)'
+		/
+
+		literal `begin `end `{ `}
+
+		token id
+			/[a-zA-Z_][a-zA-Z_0-9]* "'"? /
+
+		token number /
+			[0-9]+
+		/
+
+		token symbol /
+			'!' | '#' | '$' | '%' | '&' | '(' | ')' | '*' |
+			'+' | ',' | '-' | '.' | '/' | ':' | ';' | '<' |
+			'=' | '>' | '?' | '@' | '[' | ']' | '^' | '|' |
+			'~' | '`' /
+
+		token string /
+				'"' ( [^"\\\n] | '\\' any ) * '"' |
+				"'" ( [^'\\\n] | '\\' any ) * "'"
+			/
+
+		ignore
+			/[ \t\v\r\n]+/
+	end
+
+	def item
+		[comment]
+	|	[id]
+	|	[number]
+	|	[symbol]
+	|	[string]
+	|	[`begin _IN_ item* _EX_ `end ]
+	|	[`{ _IN_ item* _EX_ `} ]
+
+	def ocaml_out
+		[_IN_ _EX_ item*]
+end
+
+namespace ml_gen
+
+	global StaticVarMap: map<str, str> = new map<str, str>()
+	global Parser: parser<ocaml_out::ocaml_out>
+
+	void tok_list( TL: host::tok* )
+	{
+		for Tok: host::tok in repeat(TL) {
+			switch Tok
+			case [host::`${ StmtList: stmt* host::`}$]
+				send Parser
+					"begin
+					"[stmt_list( StmtList )]
+					"end;
+			case [host::`={ Expr: expr host::`}=]
+				send Parser "([expr( Expr )])"
+			case [E: escape] {
+				Str: str = $E
+				send Parser
+					"[Str.suffix( 1 )]"
+			}
+			default {
+				send Parser [Tok]
+			}
+		}
+	}
+
+	void embedded_host( EH: embedded_host )
+	{
+		switch EH
+		case [`host `( string `, uint `) `={ TL: host::tok* host::`}=]
+		{
+			send Parser
+				"([tok_list( TL )])"
+		}
+		case [`host `( string `, uint `) `${ TL: host::tok* host::`}$]
+		{
+			send Parser 
+				"begin
+				"[tok_list( TL )]
+				"end;
+		}
+		case [`host `( string `, uint `) `@{ TL: host::tok* host::`}@]
+		{
+			send Parser
+				[tok_list( TL )]
+		}
+	}
+
+	void expr_factor( ExprFactor: expr_factor )
+	{
+		switch ExprFactor
+		case [EH: embedded_host]
+		{
+			send Parser
+				[embedded_host( EH )]
+		}
+		case [`( TL: expr `)]
+		{
+			send Parser
+				"( [ expr(TL) ] )"
+		}
+		case [I: ident `[ TL: expr `]]
+		{
+			if ( StaticVarMap->find( $I ) || $I == 'stack' ) {
+				send Parser
+					"[ ExprFactor.ident ].([ expr( TL ) ])"
+			}
+			else {
+				send Parser
+					"[ ExprFactor.ident ].\[[ expr( TL ) ]\]"
+			}
+		}
+		case [I: ident `[ E: expr `] `. F: ident] {
+			send Parser
+				[^I '_' ^F '.(' expr(E) ')']
+		}
+		case ['offset' '(' ident ',' expr ')']
+		{
+			send Parser
+				[expr( ExprFactor.expr )]
+		}
+		case ['deref' '(' I: ident ',' Expr: expr ')']
+		{
+			if ( $I == 'data' )
+				send Parser 'Char.code '
+
+			if ( StaticVarMap->find( $I ) ) {
+				send Parser
+					"[I].( [ expr( Expr ) ] )"
+			}
+			else {
+				send Parser
+					"[I].\[[ expr( Expr ) ]\]"
+			}
+		}
+		case [T: `TRUE]
+		{
+			T.data = 'true'
+			send Parser [T]
+		}
+		case [F: `FALSE]
+		{
+			F.data = 'false'
+			send Parser [F]
+		}
+		case [N: `nil]
+		{
+			N.data = '0'
+			send Parser [N]
+		}
+		case [Number: number]
+		{
+			number( Number )
+		}
+		case [I: ident] {
+			if ( StaticVarMap->find( $I ) ) {
+				send Parser
+					[^I]
+			}
+			else {
+				send Parser
+					"[^I].contents"
+			}
+		}
+		case [E1: embedded_host `-> E2: expr_factor]
+		{
+			# The accessor operator is contained wihtin the lhs.
+			embedded_host( E1 )
+			expr_factor( E2 )
+		}
+		case [`cast `( type `) expr_factor]
+		{
+			send Parser
+				[expr_factor( ExprFactor._expr_factor )]
+		}
+		case [I: ident `[ E: expr `] `. F: ident] {
+			send Parser
+				[^I '_' ^F '[' E ']']
+		}
+		default {
+			# Catches cases not specified
+			send Parser [ExprFactor]
+		}
+	}
+
+	void lvalue( ExprFactor: lvalue )
+	{
+		switch ExprFactor
+		case [EH: embedded_host]
+		{
+			send Parser
+				[embedded_host( EH )]
+		}
+		case [ident O: `[ TL: expr C: `]]
+		{
+			send Parser
+				[ExprFactor.ident O expr( TL ) C]
+		}
+		case [E1: embedded_host `-> E2: lvalue]
+		{
+			# The accessor operator is contained wihtin the lhs.
+			embedded_host( E1 )
+			lvalue( E2 )
+		}
+		case [I: ident `[ E: expr `] `. F: ident] {
+			send Parser
+				[^I '_' ^F '.(' E ')']
+		}
+		default {
+			# Catches cases not specified
+			send Parser [ExprFactor]
+		}
+	}
+
+	void expr_factor_op( ExprFactorOp: expr_factor_op )
+	{
+		switch ExprFactorOp
+		case [B: `! expr_factor_op]
+		{
+			send Parser [B]
+			expr_factor_op( ExprFactorOp._expr_factor_op )
+		}
+		case [T: `~ expr_factor_op]
+		{
+			send Parser " lnot "
+			expr_factor_op( ExprFactorOp._expr_factor_op )
+		}
+		case [expr_factor]
+		{
+			expr_factor( ExprFactorOp.expr_factor )
+		}
+	}
+
+	void expr_bitwise( ExprBitwise: expr_bitwise )
+	{
+		switch ExprBitwise
+		case [L: expr_bitwise `& R: expr_factor_op]
+		{
+			send Parser
+				"[expr_bitwise( L )] land [expr_factor_op( R )]"
+		}
+		case [expr_factor_op]
+		{
+			expr_factor_op( ExprBitwise.expr_factor_op )
+		}
+	}
+
+	void expr_mult( ExprMult: expr_mult )
+	{
+		switch ExprMult
+		case [expr_mult T: `* expr_bitwise]
+		{
+			expr_mult( ExprMult._expr_mult )
+			send Parser [T]
+			expr_bitwise( ExprMult.expr_bitwise )
+		}
+		case [expr_bitwise]
+		{
+			expr_bitwise( ExprMult.expr_bitwise )
+		}
+	}
+
+	void expr_add( ExprAdd: expr_add )
+	{
+		switch ExprAdd
+		case [expr_add Op: add_op expr_mult]
+		{
+			expr_add( ExprAdd._expr_add )
+			send Parser [Op]
+			expr_mult( ExprAdd.expr_mult )
+		}
+		case [expr_mult]
+		{
+			expr_mult( ExprAdd.expr_mult )
+		}
+	}
+
+	void expr_shift( ExprShift: expr_shift )
+	{
+		switch ExprShift
+		case [expr_shift Op: shift_op expr_add]
+		{
+			expr_shift( ExprShift._expr_shift )
+			switch Op
+			case [`<<]
+				send Parser " lsl "
+			default
+				send Parser " asr "
+			expr_add( ExprShift.expr_add )
+		}
+		case [expr_add]
+		{
+			expr_add( ExprShift.expr_add )
+		}
+	}
+
+	void expr_test( ExprTest: expr_test )
+	{
+		switch ExprTest
+		case [expr_test Op: test_op expr_shift]
+		{
+			expr_test( ExprTest._expr_test )
+			switch Op
+			case [`==]
+				send Parser "= "
+			default
+				send Parser [Op]
+			expr_shift( ExprTest.expr_shift )
+		}
+		case [expr_shift]
+		{
+			expr_shift( ExprTest.expr_shift )
+		}
+	}
+
+	void expr( Expr: expr )
+	{
+		expr_test( Expr.expr_test )
+	}
+
+	void type( Type: type )
+	{
+		switch Type
+		case "s8"
+			send Parser ['char ']
+		case "s16"
+			send Parser ['short ']
+		case "s32"
+			send Parser ['int ']
+		case "s64"
+			send Parser ['long ']
+		case "s128"
+			send Parser ['long long ']
+		case "uint"
+			send Parser ['int ']
+		default
+			send Parser [Type]
+	}
+
+	void number( Number: number )
+	{
+		switch Number
+		case [`u `( uint `) ]
+			send Parser "[Number.uint]u"
+		default
+			send Parser [Number]
+	}
+
+	void num_list( NumList: num_list )
+	{
+		for Number: number in NumList
+			send Parser "[number( Number )]; "
+	}
+
+	void stmt( Stmt: stmt )
+	{
+		switch Stmt
+		case [EH: embedded_host]
+		{
+			send Parser
+				[embedded_host( EH )]
+		}
+		case [A: static_array] {
+			StaticVarMap->insert( $A.ident, ' ' )
+			send Parser
+				"let [A.ident] : int array = \[|
+					"	[num_list(A.num_list)]
+				"|\]
+		}
+		case [V: static_value] {
+			StaticVarMap->insert( $V.ident, ' ' )
+			send Parser
+				"let [V.ident] : [V.type] = [V.number]
+		}
+		case [
+				'if' O: `( IfExpr: expr C: `) IfStmt: stmt
+				ElseIfClauseList: else_if_clause* ElseClauseOpt: else_clause?
+		] {
+			send Parser
+				"if [expr(IfExpr)] then
+				"begin
+				"	[stmt(IfStmt)]
+				"end
+
+			for ElseIfClause: else_if_clause in repeat( ElseIfClauseList ) {
+				match ElseIfClause
+					['else if (' ElseIfExpr: expr ')' ElseIfStmt: stmt]
+
+				send Parser
+					"else if [expr(ElseIfExpr)] then
+					"begin
+					"	[stmt(ElseIfStmt)]
+					"end
+			}
+
+			if ( match ElseClauseOpt ['else' ElseStmt: stmt] ) {
+				send Parser
+					"else
+					"begin
+					"	[stmt(ElseStmt)]
+					"end
+			}
+
+			send Parser
+				";"
+		}
+		case ['while' '(' WhileExpr: expr ')' WhileStmt: stmt] {
+			send Parser
+				"while [expr(WhileExpr)] do
+				"	[stmt(WhileStmt)]
+				"done;
+		}
+		case ['switch' '(' SwitchExpr: expr ')' '{' StmtList: stmt* '}'] {
+			require StmtList
+				[`case E1: expr `{ Inner: stmt* `} Rest: stmt*]
+
+			send Parser
+				"if [expr(SwitchExpr)] = [expr(E1)] then
+				"begin
+				"	[stmt_list(Inner)]
+				"end
+
+			for S: stmt in repeat(Rest) {
+				switch S
+				case [`case E1: expr `{ Inner: stmt* `}]
+				{
+					send Parser
+						"else if [expr(SwitchExpr)] = [expr(E1)] then
+						"begin
+						"	[stmt_list(Inner)]
+						"end
+				}
+				case
+					[`default `{ Inner: stmt* `}]
+				{
+					send Parser
+						"else
+						"begin
+						"	[stmt_list(Inner)]
+						"end
+				}
+			}
+
+			send Parser
+				";
+		}
+		case [ExprExpr: expr Semi: `;] {
+			send Parser
+				[expr(ExprExpr) Semi]
+		}
+		case [L: `{ TL: stmt* R: `}] {
+			send Parser
+				"begin
+				"[stmt_list(TL)]
+				"end;
+		}
+		case [D: declaration] {
+			send Parser
+				"let [D.ident] : [type(D.type)] ref "
+
+			switch D.opt_init
+			case [E: `= expr] {
+				send Parser
+					"= ref ( [expr(D.opt_init.expr)] )"
+			}
+			default {
+				send Parser
+					"= ref 0"
+			}
+
+			send Parser
+				" in
+		}
+		case [Export: export_stmt]
+		{
+			send Parser
+				"#define [Export.ident] [number(Export.number)] 
+		}
+		case ['fallthrough' ';']
+		{
+			# Nothing needed here.
+		}
+		case [Index: index_stmt]
+		{
+			send Parser
+				"let [Index.ident] : int ref "
+
+			switch Index.opt_init
+			case [E: `= expr] {
+				send Parser
+					"= ref ( [expr(Index.opt_init.expr)] )"
+			}
+			default {
+				send Parser
+					"= ref 0"
+			}
+
+			send Parser
+				" in
+		}
+		case [case_block]
+		{
+			send Parser
+				"| [expr( Stmt.case_block.expr )] -> 
+				"begin
+				"[stmt_list( Stmt.case_block._repeat_stmt )]
+				"end;
+		}
+		case [default_block]
+		{
+			send Parser
+				"| _ ->
+				"[stmt_list( Stmt.default_block._repeat_stmt )]
+		}
+		case [case_label]
+		{
+			send Parser
+				"case [expr( Stmt.case_label.expr )]:
+		}
+		case [AS: assign_stmt]
+		{
+			switch AS.assign_op 
+			case [`=]
+			{
+				switch AS.LValue
+				case "stack\[[expr]\]" {
+					send Parser
+						"Array.set stack top.contents [expr(AS.expr)];
+				}
+				case "nfa_bp\[[expr]\].state" {
+					send Parser
+						"Array.set nfa_bp_state nfa_len.contents [expr(AS.expr)];
+				}
+				case "nfa_bp\[[expr]\].p" {
+					send Parser
+						"Array.set nfa_bp_p nfa_len.contents [expr(AS.expr)];
+				}
+				default {
+					send Parser
+						"[lvalue(AS.LValue)] := [expr(AS.expr)];
+				}
+			}
+			case [`+=]
+			{
+				parse RhsAsFactor: expr_factor [$AS.LValue]
+				send Parser
+					"[lvalue(AS.LValue)] := [expr_factor(RhsAsFactor)] + [expr(AS.expr)];
+			}
+			case [`-=]
+			{
+				parse RhsAsFactor: expr_factor [$AS.LValue]
+				send Parser
+					"[lvalue(AS.LValue)] := [expr_factor(RhsAsFactor)] - [expr(AS.expr)];
+			}
+			default {
+				send Parser
+					"[lvalue(AS.LValue) AS.assign_op expr(AS.expr)];
+			}
+		}
+		default {
+			# catches unspecified cases
+			send Parser [Stmt]
+		}
+	}
+
+	void stmt_list( StmtList: stmt* )
+	{
+		for Stmt: stmt in repeat( StmtList )
+			stmt( Stmt )
+	}
+
+	void trans( Output: stream, Start: start )
+	{
+		Parser = new parser<ocaml_out::ocaml_out>()
+
+		if ( Start.opt_bom.bom )
+			send Output [Start.opt_bom.bom]
+
+		stmt_list( Start._repeat_stmt )
+
+		MO: ocaml_out::ocaml_out = Parser->finish()
+
+		if MO {
+			send Output
+				[MO]
+		}
+		else {
+			send stderr
+				"failed to parse output: [Parser->error]
+		}
+	}
+
+end
+
+void trans( Output: stream, Start: start )
+{
+	ml_gen::trans( Output, Start )
+}
+
+include 'rlhc-main.lm'