ibpc.ml

open Printf

let ( let* ) x f = match x with Ok v -> f v | Error _ as e -> e
let ( let+ ) x f = match x with Ok v -> Ok (f v) | Error _ as e -> e

let error msg = Error msg
let ok x = Ok x

module Lexer = struct
	type token =
		| IDENT of string
		| INT_LIT of string
		| REAL_LIT of string
		| STR_LIT of string
		| KW_FUNC | KW_END | KW_IF | KW_THEN | KW_ELSE
		| KW_LOOP | KW_WHILE | KW_UNTIL | KW_FROM | KW_TO
		| KW_BREAK | KW_CONTINUE | KW_RETURN
		| KW_INPUT | KW_OUTPUT
		| KW_TRUE | KW_FALSE | KW_NULL
		| KW_AND | KW_OR | KW_NOT | KW_DIV | KW_MOD
		| LPAREN | RPAREN | COMMA
		| PLUS | MINUS | STAR | SLASH | PERCENT
		| EQ | NEQ | LT | LE | GT | GE | ASSIGN | BANG
		| NEWLINE
		| EOF

	type t = {
		src: string;
		len: int;
		mutable i: int;
		mutable line: int;
	}

	let is_space = function ' ' | '\t' -> true | _ -> false

	let is_ident_start c =
		match c with
		| 'A'..'Z' | 'a'..'z' | '_' -> true
		| _ -> false

	let is_ident_char c =
		match c with
		| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> true
		| _ -> false

	let make src = { src; len = String.length src; i = 0; line = 1 }

	let peek lx =
		if lx.i >= lx.len then None else Some lx.src.[lx.i]

	let bump lx = lx.i <- lx.i + 1

	let consume lx = match peek lx with None -> None | Some c -> bump lx; Some c

	let rec skip_ws_and_comments lx =
		let rec skip_block_comment () =
			let rec loop () =
				match consume lx with
				| None -> ()
				| Some '*' ->
					begin match peek lx with
					| Some '/' -> bump lx
					| _ -> loop ()
					end
				| Some '\n' -> lx.line <- lx.line + 1; loop ()
				| Some _ -> loop ()
			in loop ()
		in
		let rec loop () =
			match peek lx with
			| Some c when is_space c -> bump lx; loop ()
			| Some '/' ->
				begin
					bump lx;
					match peek lx with
					| Some '/' ->
						while (match peek lx with
							| Some '\n' -> false
							| Some _ -> bump lx; true
							| None -> false) do () done
					| Some '*' ->
						bump lx; skip_block_comment ()
					| _ ->
						lx.i <- lx.i - 1
				end
			| _ -> ()
		in
		loop ()

	let read_while lx pred =
		let j = lx.i in
		while (match peek lx with Some c when pred c -> bump lx; true | _ -> false) do () done;
		String.sub lx.src j (lx.i - j)

	let read_number lx first =
		let buf = Buffer.create 16 in
		Buffer.add_char buf first;
		let rec int_part () =
			match peek lx with
			| Some ('0'..'9' as c) -> bump lx; Buffer.add_char buf c; int_part ()
			| Some '.' ->
				bump lx; Buffer.add_char buf '.';
				fraction ()
			| _ -> `Int (Buffer.contents buf)
		and fraction () =
			let rec go have_any =
				match peek lx with
				| Some ('0'..'9' as c) -> bump lx; Buffer.add_char buf c; go true
				| _ -> if have_any then `Real (Buffer.contents buf) else `Int (Buffer.contents buf)
			in go false
		in
		int_part ()

	let read_string lx =
		let buf = Buffer.create 32 in
		let rec loop () =
			match consume lx with
			| None -> error (sprintf "unterminated string literal at line %d" lx.line)
			| Some '"' -> ok (Buffer.contents buf)
			| Some '\\' ->
				begin match consume lx with
				| Some 'n' -> Buffer.add_char buf '\n'; loop ()
				| Some 'r' -> Buffer.add_char buf '\r'; loop ()
				| Some 'x' ->
					let hex2 () =
						let hex c =
							match c with
							| '0'..'9' -> Char.code c - Char.code '0'
							| 'a'..'f' -> 10 + Char.code c - Char.code 'a'
							| 'A'..'F' -> 10 + Char.code c - Char.code 'A'
							| _ -> -1
						in
						match consume lx, consume lx with
						| Some a, Some b2 ->
							let ha, hb = hex a, hex b2 in
							if ha < 0 || hb < 0 then
								error (sprintf "bad \\x escape at line %d" lx.line)
							else (Buffer.add_char buf (Char.chr (ha * 16 + hb)); ok ())
						| _ -> error (sprintf "bad \\x escape at line %d" lx.line)
					in
					let* () = hex2 () in loop ()
				| Some '\\' -> Buffer.add_char buf '\\'; loop ()
				| Some '"' -> Buffer.add_char buf '"'; loop ()
				| Some c ->
					error (sprintf "unknown escape \\%c at line %d" c lx.line)
				| None -> error (sprintf "unterminated string literal at line %d" lx.line)
				end
			| Some '\n' ->
				lx.line <- lx.line + 1;
				error (sprintf "newline in string literal at line %d" (lx.line - 1))
			| Some c -> Buffer.add_char buf c; loop ()
		in
		loop ()

	let keyword s =
		match String.lowercase_ascii s with
		| "func" -> Some KW_FUNC
		| "end" -> Some KW_END
		| "if" -> Some KW_IF
		| "then" -> Some KW_THEN
		| "else" -> Some KW_ELSE
		| "loop" -> Some KW_LOOP
		| "while" -> Some KW_WHILE
		| "until" -> Some KW_UNTIL
		| "from" -> Some KW_FROM
		| "to" -> Some KW_TO
		| "break" -> Some KW_BREAK
		| "continue" -> Some KW_CONTINUE
		| "return" -> Some KW_RETURN
		| "input" -> Some KW_INPUT
		| "output" -> Some KW_OUTPUT
		| "true" -> Some KW_TRUE
		| "false" -> Some KW_FALSE
		| "null" -> Some KW_NULL
		| "and" -> Some KW_AND
		| "or" -> Some KW_OR
		| "not" -> Some KW_NOT
		| "div" -> Some KW_DIV
		| "mod" -> Some KW_MOD
		| _ -> None

	let rec next lx =
		let rec go () =
			skip_ws_and_comments lx;
			match consume lx with
			| None -> EOF
			| Some '\n' -> lx.line <- lx.line + 1; NEWLINE
			| Some '(' -> LPAREN
			| Some ')' -> RPAREN
			| Some ',' -> COMMA
			| Some '+' -> PLUS
			| Some '-' -> MINUS
			| Some '*' -> STAR
			| Some '%' -> PERCENT
			| Some '!' -> begin match peek lx with Some '=' -> bump lx; NEQ | _ -> BANG end
			| Some '=' -> begin match peek lx with Some '=' -> bump lx; EQ | _ -> ASSIGN end
			| Some '<' ->
				begin match peek lx with
				| Some '=' -> bump lx; LE
				| Some '>' -> bump lx; NEQ
				| _ -> LT
				end
			| Some '>' -> begin match peek lx with Some '=' -> bump lx; GE | _ -> GT end
			| Some '/' ->
				begin match peek lx with
				| Some '/' -> assert false
				| Some '*' -> assert false
				| _ -> SLASH
				end
			| Some '"' ->
				begin match read_string lx with
				| Ok s -> STR_LIT s
				| Error _ -> STR_LIT ""
				end
			| Some c when ('0' <= c && c <= '9') ->
				begin match read_number lx c with
				| `Int s -> INT_LIT s
				| `Real s -> REAL_LIT s
				end
			| Some c when is_ident_start c ->
				let s = String.make 1 c ^ read_while lx is_ident_char in
				begin match keyword s with
				| Some kw -> kw
				| None -> IDENT s
				end
			| Some _ ->
				go ()
		in
		go ()

	type stream = {
		lx: t;
		mutable look: token option;
	}

	let stream lx = { lx; look = None }

	let peek_tok s =
		match s.look with
		| Some t -> t
		| None ->
			let t = next s.lx in
			s.look <- Some t; t

	let take_tok s =
		match s.look with
		| Some t -> s.look <- None; t
		| None -> next s.lx

	let expect s t =
		let got = take_tok s in
		if got = t then ok ()
		else error (sprintf "expected token, got something else at line %d" s.lx.line)

	let rec take_newlines s =
		match peek_tok s with
		| NEWLINE -> ignore (take_tok s); take_newlines s
		| _ -> ()
end

module Ast = struct
	type uop = UNeg | UNot | UBang
	type bop =
		| BAdd | BSub | BMul | BDiv | BIDiv | BMod
		| BEq | BNeq | BLt | BLe | BGt | BGe
		| BAnd | BOr

	type expr =
		| EInt of int64
		| EReal of float
		| EStr of string
		| EBool of bool
		| ENull
		| EVar of string
		| ECall of string * expr list
		| EUnary of uop * expr
		| EBin of bop * expr * expr

	type stmt =
		| SAssign of string * expr
		| SInput of string
		| SOutput of expr list
		| SIf of (expr * stmt list) list * stmt list option
		| SLoopWhile of expr * stmt list
		| SLoopUntil of expr * stmt list
		| SFor of string * expr * expr * stmt list
		| SBreak
		| SContinue
		| SReturn of expr
		| SExpr of expr

	type func = { name: string; params: string list; body: stmt list }
	type prog = { funcs: func list }
end

module Parser = struct
	open Lexer
	open Ast

	type st = Lexer.stream

	let rec parse_prog s =
		Lexer.take_newlines s;
		let rec many acc =
			match Lexer.peek_tok s with
			| KW_FUNC ->
				let f = parse_func s in
				let* f = f in
				Lexer.take_newlines s;
				many (f :: acc)
			| EOF -> ok { funcs = List.rev acc }
			| _ ->
				error "Only function declarations are allowed at top-level. Define func main()."
		in
		many []

	and parse_func s =
		let* () = expect s KW_FUNC in
		let name =
			match take_tok s with
			| IDENT id -> id
			| _ -> "<?>"
		in
		let* () = expect s LPAREN in
		let rec params acc =
			match peek_tok s with
			| RPAREN -> ignore (take_tok s); List.rev acc
			| IDENT id ->
				ignore (take_tok s);
				begin match peek_tok s with
				| COMMA -> ignore (take_tok s); params (id :: acc)
				| RPAREN -> ignore (take_tok s); List.rev (id :: acc)
				| _ -> List.rev (id :: acc)
				end
			| _ -> List.rev acc
		in
		let params = params [] in
		let* () =
			match peek_tok s with
			| NEWLINE -> ignore (take_tok s); ok ()
			| _ -> ok ()
		in
		let* body = parse_block s ~enders:[KW_END] in
		let* () =
			match take_tok s with
			| KW_END ->
				begin match take_tok s with
				| IDENT id when String.lowercase_ascii id = String.lowercase_ascii name -> ok ()
				| _ -> error "expected end <function_name>"
				end
			| _ -> error "expected end <function_name>"
		in
		ok { name; params; body }

	and parse_block s ~enders =
		let rec many acc =
			Lexer.take_newlines s;
			match Lexer.peek_tok s with
			| EOF -> error "unexpected EOF in block"
			| t when List.exists (fun e -> e = t) enders -> ok (List.rev acc)
			| _ ->
				let* st = parse_stmt s in
				Lexer.take_newlines s;
				many (st :: acc)
		in
		many []

	and parse_stmt s =
		match Lexer.peek_tok s with
		| KW_INPUT ->
			ignore (take_tok s);
			begin match take_tok s with
			| IDENT id -> ok (SInput id)
			| _ -> error "input expects an identifier"
			end
		| KW_OUTPUT ->
			ignore (take_tok s);
			let rec args acc =
				let* e = parse_expr s in
				match Lexer.peek_tok s with
				| COMMA -> ignore (take_tok s); args (e :: acc)
				| _ -> ok (List.rev (e :: acc))
			in
			let* xs = args [] in
			ok (SOutput xs)
		| KW_IF ->
			ignore (take_tok s);
			let* cond = parse_expr s in
			let* () = expect s KW_THEN in
			(match Lexer.peek_tok s with NEWLINE -> ignore (take_tok s) | _ -> ());
			let* tblock = parse_block s ~enders:[KW_ELSE; KW_END] in
			let rec elseifs acc =
				match Lexer.peek_tok s with
				| KW_ELSE ->
					ignore (take_tok s);
					begin match Lexer.peek_tok s with
					| KW_IF ->
						ignore (take_tok s);
						let* c = parse_expr s in
						let* () = expect s KW_THEN in
						(match Lexer.peek_tok s with NEWLINE -> ignore (take_tok s) | _ -> ());
						let* b = parse_block s ~enders:[KW_ELSE; KW_END] in
						elseifs ((c, b) :: acc)
					| _ ->
						let* eblock = parse_block s ~enders:[KW_END] in
						let* () = expect s KW_END in
						let* () = expect s KW_IF in
						ok (SIf (List.rev ((cond, tblock) :: acc), Some eblock))
					end
				| KW_END ->
					ignore (take_tok s);
					let* () = expect s KW_IF in
					ok (SIf (List.rev ((cond, tblock) :: acc), None))
				| _ -> error "expected else or end if"
			in
			elseifs []
		| KW_LOOP ->
			ignore (take_tok s);
			begin match Lexer.peek_tok s with
			| KW_WHILE ->
				ignore (take_tok s);
				let* c = parse_expr s in
				(match Lexer.peek_tok s with NEWLINE -> ignore (take_tok s) | _ -> ());
				let* b = parse_block s ~enders:[KW_END] in
				let* () = expect s KW_END in
				let* () = expect s KW_LOOP in
				ok (SLoopWhile (c, b))
			| KW_UNTIL ->
				ignore (take_tok s);
				let* c = parse_expr s in
				(match Lexer.peek_tok s with NEWLINE -> ignore (take_tok s) | _ -> ());
				let* b = parse_block s ~enders:[KW_END] in
				let* () = expect s KW_END in
				let* () = expect s KW_LOOP in
				ok (SLoopUntil (c, b))
			| IDENT id ->
				ignore (take_tok s);
				let* () = expect s KW_FROM in
				let* a = parse_expr s in
				let* () = expect s KW_TO in
				let* bgn_to = parse_expr s in
				(match Lexer.peek_tok s with NEWLINE -> ignore (take_tok s) | _ -> ());
				let* body = parse_block s ~enders:[KW_END] in
				let* () = expect s KW_END in
				let* () = expect s KW_LOOP in
				ok (SFor (id, a, bgn_to, body))
			| _ -> error "expected while / until / I from A to B after loop"
			end
		| KW_BREAK -> ignore (take_tok s); ok SBreak
		| KW_CONTINUE -> ignore (take_tok s); ok SContinue
		| KW_RETURN ->
			ignore (take_tok s);
			let* e = parse_expr s in
			ok (SReturn e)
		| IDENT id ->
			ignore (take_tok s);
			begin match Lexer.peek_tok s with
			| ASSIGN ->
				ignore (take_tok s);
				let* e = parse_expr s in
				ok (SAssign (id, e))
			| LPAREN ->
				let* call = parse_call_tail s id in
				ok (SExpr call)
			| _ ->
				error "expected assignment (=) or call"
			end
		| _ ->
			error "could not parse statement"

	
	and parse_call_tail s fname =
		let* () = expect s LPAREN in
		let rec args acc =
			match Lexer.peek_tok s with
			| RPAREN ->
				ignore (take_tok s);
				ok (List.rev acc)
			| _ ->
				let* e = parse_expr s in
				begin match Lexer.peek_tok s with
				| COMMA ->
					ignore (take_tok s);
					args (e :: acc)
				| RPAREN ->
					ignore (take_tok s);
					ok (List.rev (e :: acc))
				| _ ->
					error "expected , or ) in call"
				end
		in
		let* xs = args [] in
		ok (ECall (fname, xs))


	and parse_expr s =
		parse_or s

	and parse_or s =
		let* lhs = parse_and s in
		let rec loop acc =
			match Lexer.peek_tok s with
			| KW_OR -> ignore (take_tok s); let* rhs = parse_and s in loop (EBin (BOr, acc, rhs))
			| _ -> ok acc
		in
		loop lhs

	and parse_and s =
		let* lhs = parse_not s in
		let rec loop acc =
			match Lexer.peek_tok s with
			| KW_AND -> ignore (take_tok s); let* rhs = parse_not s in loop (EBin (BAnd, acc, rhs))
			| _ -> ok acc
		in
		loop lhs

	and parse_not s =
		match Lexer.peek_tok s with
		| KW_NOT -> ignore (take_tok s); let* e = parse_not s in ok (EUnary (UNot, e))
		| _ -> parse_cmp s

	and parse_cmp s =
		let* lhs = parse_add s in
		let rec loop acc =
			match Lexer.peek_tok s with
			| EQ -> ignore (take_tok s); let* r = parse_add s in loop (EBin (BEq, acc, r))
			| NEQ -> ignore (take_tok s); let* r = parse_add s in loop (EBin (BNeq, acc, r))
			| LT -> ignore (take_tok s); let* r = parse_add s in loop (EBin (BLt, acc, r))
			| LE -> ignore (take_tok s); let* r = parse_add s in loop (EBin (BLe, acc, r))
			| GT -> ignore (take_tok s); let* r = parse_add s in loop (EBin (BGt, acc, r))
			| GE -> ignore (take_tok s); let* r = parse_add s in loop (EBin (BGe, acc, r))
			| _ -> ok acc
		in
		loop lhs

	and parse_add s =
		let* lhs = parse_mul s in
		let rec loop acc =
			match Lexer.peek_tok s with
			| PLUS -> ignore (take_tok s); let* r = parse_mul s in loop (EBin (BAdd, acc, r))
			| MINUS -> ignore (take_tok s); let* r = parse_mul s in loop (EBin (BSub, acc, r))
			| _ -> ok acc
		in
		loop lhs

	and parse_mul s =
		let* lhs = parse_unary s in
		let rec loop acc =
			match Lexer.peek_tok s with
			| STAR -> ignore (take_tok s); let* r = parse_unary s in loop (EBin (BMul, acc, r))
			| SLASH -> ignore (take_tok s); let* r = parse_unary s in loop (EBin (BDiv, acc, r))
			| KW_DIV -> ignore (take_tok s); let* r = parse_unary s in loop (EBin (BIDiv, acc, r))
			| KW_MOD | PERCENT -> ignore (take_tok s); let* r = parse_unary s in loop (EBin (BMod, acc, r))
			| _ -> ok acc
		in
		loop lhs

	and parse_unary s =
		match Lexer.peek_tok s with
		| BANG -> ignore (take_tok s); let* e = parse_unary s in ok (EUnary (UBang, e))
		| MINUS -> ignore (take_tok s); let* e = parse_unary s in ok (EUnary (UNeg, e))
		| _ -> parse_primary s

	and parse_primary s =
		match take_tok s with
		| INT_LIT n -> ok (EInt (Int64.of_string n))
		| REAL_LIT r -> ok (EReal (float_of_string r))
		| STR_LIT s' -> ok (EStr s')
		| KW_TRUE -> ok (EBool true)
		| KW_FALSE -> ok (EBool false)
		| KW_NULL -> ok ENull
		| IDENT id ->
			begin match Lexer.peek_tok s with
			| LPAREN -> parse_call_tail s id
			| _ -> ok (EVar id)
			end
		| LPAREN ->
			let* e = parse_expr s in
			let* () = expect s RPAREN in
			ok e
		| _ -> error "unexpected token in expression"
end

module Codegen = struct
	open Ast

	type env = {
		mutable temp: int;
		mutable vars: (string, unit) Hashtbl.t;
		buf: Buffer.t;
	}

	let env () = { temp = 0; vars = Hashtbl.create 32; buf = Buffer.create 4096 }

	let fresh e =
		let n = e.temp in
		e.temp <- e.temp + 1;
		sprintf "_t%d" n

	let emit e fmt = ksprintf (fun s -> Buffer.add_string e.buf s) fmt

	let declare_var e name =
		if not (Hashtbl.mem e.vars name) then begin
			Hashtbl.add e.vars name ();
			emit e "\tValue v_%s = V_NULL();\n" name
		end

	let runtime_header () = {|
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdbool.h>
#include <stdint.h>
#include <sys/types.h>
#include <math.h>

typedef enum { T_NULL, T_INT, T_REAL, T_BOOL, T_STRING } TypeTag;

typedef struct {
	size_t cap;
	size_t len;
	char *data;
} String;

typedef struct {
	TypeTag tag;
	union {
		long long i;
		double r;
		bool b;
		String s;
	} v;
} Value;

/* Constructors */
static inline Value V_NULL(void){ Value x; x.tag=T_NULL; return x; }
static inline Value V_INT(long long v){ Value x; x.tag=T_INT; x.v.i=v; return x; }
static inline Value V_REAL(double v){ Value x; x.tag=T_REAL; x.v.r=v; return x; }
static inline Value V_BOOL(bool v){ Value x; x.tag=T_BOOL; x.v.b=v; return x; }
static inline String S_newlen(const char*src, size_t n){
	String s; s.cap=n+1; s.len=n; s.data=(char*)malloc(s.cap);
	if(!s.data){perror("malloc"); exit(1);}
	memcpy(s.data, src, n); s.data[n]='\0'; return s;
}
static inline Value V_STR(const char* c){
	size_t n = strlen(c);
	Value x; x.tag=T_STRING; x.v.s = S_newlen(c,n); return x;
}
static inline Value V_STR_take(String s){
	Value x; x.tag=T_STRING; x.v.s=s; return x;
}

/* Copy for assignment / arg passing */
static inline String S_copy(String s){
	return S_newlen(s.data, s.len);
}
static inline Value V_copy(Value v){
	if(v.tag==T_STRING){ String c = S_copy(v.v.s); return V_STR_take(c); }
	return v;
}

/* Helpers */
static inline void runtime_error(const char*msg){
	fprintf(stderr, "runtime error: %s\n", msg); exit(1);
}
static inline bool as_bool(Value v){
	if(v.tag!=T_BOOL) runtime_error("boolean required");
	return v.v.b;
}

static inline long long as_int_floor(Value v){
	switch(v.tag){
		case T_INT:  return v.v.i;
		case T_REAL: return (long long)floor(v.v.r);
		case T_BOOL: return v.v.b ? 1 : 0;
		case T_STRING: {
			const char *s = v.v.s.data;
			char *end = NULL;
			long long val = strtoll(s, &end, 10); /* base-10 per spec */
			return val;
		}
		default:
			runtime_error("int/real required");
			return 0;
	}
}

static inline double as_real(Value v){
	switch(v.tag){
		case T_INT:  return (double)v.v.i;
		case T_REAL: return v.v.r;
		case T_BOOL: return v.v.b ? 1.0 : 0.0;
		case T_STRING: {
			const char *s = v.v.s.data;
			char *end = NULL;
			double val = strtod(s, &end);       /* decimal per spec */
			return val;
		}
		default:
			runtime_error("int/real required");
			return 0.0;
	}
}

/* int/real/str(X) builtins */
static inline Value ibpc_int(Value x){
	if(x.tag==T_STRING){
		const char *s = x.v.s.data;
		char *end = NULL;
		long long v = strtoll(s, &end, 10); /* base 10 as per spec */
		/* We don't error on garbage; strtoll handles leading ws; result is v */
		return V_INT(v);
	}
	return V_INT(as_int_floor(x));
}

static inline Value ibpc_real(Value x){
	if(x.tag==T_STRING){
		const char *s = x.v.s.data;
		char *end = NULL;
		double v = strtod(s, &end); /* decimal as per spec */
		return V_REAL(v);
	}
	return V_REAL(as_real(x));
}

static inline Value ibpc_str(Value x){
	char buf[64];
	switch(x.tag){
		case T_NULL: return V_STR("null");
		case T_BOOL: return V_STR(x.v.b?"true":"false");
		case T_INT: snprintf(buf,sizeof buf,"%lld", x.v.i); return V_STR(buf);
		case T_REAL: snprintf(buf,sizeof buf,"%.17g", x.v.r); return V_STR(buf);
		case T_STRING: return V_copy(x);
		default: return V_STR("<unsupported>");
	}
}

/* Arithmetic & comparisons */
static inline Value op_add(Value a, Value b){
	if(a.tag==T_STRING || b.tag==T_STRING) runtime_error("+ on strings not supported");
	if(a.tag==T_INT && b.tag==T_INT) return V_INT(a.v.i + b.v.i);
	return V_REAL(as_real(a) + as_real(b));
}
static inline Value op_sub(Value a, Value b){
	if(a.tag==T_STRING || b.tag==T_STRING) runtime_error("- on strings not supported");
	if(a.tag==T_INT && b.tag==T_INT) return V_INT(a.v.i - b.v.i);
	return V_REAL(as_real(a) - as_real(b));
}
static inline Value op_mul(Value a, Value b){
	if(a.tag==T_STRING || b.tag==T_STRING) runtime_error("* on strings not supported");
	if(a.tag==T_INT && b.tag==T_INT) return V_INT(a.v.i * b.v.i);
	return V_REAL(as_real(a) * as_real(b));
}
static inline Value op_div(Value a, Value b){
	double d = as_real(b);
	if(d==0.0) runtime_error("division by zero");
	return V_REAL(as_real(a) / d);
}
static inline Value op_idiv(Value a, Value b){
	long long bb = as_int_floor(b);
	if(bb==0) runtime_error("division by zero");
	long long aa = as_int_floor(a);
	return V_INT( (long long)floor((double)aa / (double)bb) );
}
static inline Value op_mod(Value a, Value b){
	long long bb = as_int_floor(b);
	if(bb==0) runtime_error("mod by zero");
	long long aa = as_int_floor(a);
	return V_INT( aa % bb );
}

/* unary */
static inline Value op_neg(Value x){
	if(x.tag==T_INT) return V_INT(-x.v.i);
	if(x.tag==T_REAL) return V_REAL(-x.v.r);
	return V_REAL(-as_real(x));
}
static inline Value op_not(Value x){
	return V_BOOL(!as_bool(x));
}

/* comparisons */
static inline int cmp_num(Value a, Value b, int op){
	/* op: 0:<,1:<=,2:>,3:>= */
	double aa = as_real(a), bb = as_real(b);
	switch(op){
		case 0: return aa < bb;
		case 1: return aa <= bb;
		case 2: return aa > bb;
		default: return aa >= bb;
	}
}
static inline Value op_lt(Value a, Value b){ return V_BOOL(cmp_num(a,b,0)); }
static inline Value op_le(Value a, Value b){ return V_BOOL(cmp_num(a,b,1)); }
static inline Value op_gt(Value a, Value b){ return V_BOOL(cmp_num(a,b,2)); }
static inline Value op_ge(Value a, Value b){ return V_BOOL(cmp_num(a,b,3)); }

static inline Value op_eq(Value a, Value b){
	if(a.tag==T_INT && b.tag==T_REAL) return V_BOOL(((double)a.v.i) == b.v.r);
	if(a.tag==T_REAL && b.tag==T_INT) return V_BOOL(a.v.r == (double)b.v.i);
	if(a.tag!=b.tag){
		return V_BOOL(false);
	}
	switch(a.tag){
		case T_NULL: return V_BOOL(true);
		case T_INT: return V_BOOL(a.v.i == b.v.i);
		case T_REAL: return V_BOOL(a.v.r == b.v.r);
		case T_BOOL: return V_BOOL(a.v.b == b.v.b);
		case T_STRING:
			if(a.v.s.len != b.v.s.len) return V_BOOL(false);
			return V_BOOL(memcmp(a.v.s.data, b.v.s.data, a.v.s.len)==0);
		default: return V_BOOL(false);
	}
}
static inline Value op_neq(Value a, Value b){
	Value e = op_eq(a,b); e.v.b = !e.v.b; return e;
}

/* logic (no short-circuit) */
static inline Value op_and(Value a, Value b){
	return V_BOOL(as_bool(a) && as_bool(b));
}
static inline Value op_or(Value a, Value b){
	return V_BOOL(as_bool(a) || as_bool(b));
}

/* input/output */
static inline String read_line_trimlf(void){
	char *line = NULL; size_t cap = 0; ssize_t n = getline(&line, &cap, stdin);
	if(n < 0){ /* EOF */ return S_newlen("", 0); }
	if(n>0 && line[n-1]=='\n'){ n--; }
	String s = S_newlen(line, (size_t)n);
	free(line);
	return s;
}
static inline void ibpc_input_into(Value*dst){
	String s = read_line_trimlf();
	*dst = V_STR_take(s);
}
static inline void ibpc_output_n(int n, Value* xs){
	for(int i=0;i<n;i++){
		Value s = ibpc_str(xs[i]);
		fwrite(s.v.s.data, 1, s.v.s.len, stdout);
	}
	fputc('\n', stdout);
}

/* Guarded boolean for control flow */
static inline bool as_condition(Value v){
	return as_bool(v);
}

/* Forward decl for user functions will be emitted later */
|}

	let emit_runtime b = Buffer.add_string b (runtime_header ())

	type cexp = { pre: string list; name: string }

	let rec cg_expr (e:env) (x:expr) : cexp =
		match x with
		| EInt n ->
			let t = fresh e in
			{ pre = [sprintf "\tValue %s = V_INT(%Ld);\n" t n]; name = t }
		| EReal f ->
			let t = fresh e in
			{ pre = [sprintf "\tValue %s = V_REAL(%.17g);\n" t f]; name = t }
		| EStr s ->
			let esc =
				let b = Buffer.create (String.length s + 8) in
				String.iter (fun c ->
					match c with
					| '\\' -> Buffer.add_string b "\\\\"
					| '"' -> Buffer.add_string b "\\\""
					| '\n' -> Buffer.add_string b "\\n"
					| '\r' -> Buffer.add_string b "\\r"
					| _ when Char.code c < 32 ->
						Buffer.add_string b (sprintf "\\x%02x" (Char.code c))
					| _ -> Buffer.add_char b c
				) s;
				Buffer.contents b
			in
			let t = fresh e in
			{ pre = [sprintf "\tValue %s = V_STR(\"%s\");\n" t esc]; name = t }
		| EBool b ->
			let t = fresh e in
			{ pre = [sprintf "\tValue %s = V_BOOL(%s);\n" t (if b then "true" else "false")]; name = t }
		| ENull ->
			let t = fresh e in
			{ pre = [sprintf "\tValue %s = V_NULL();\n" t]; name = t }
		| EVar v ->
			let t = fresh e in
			{ pre = [sprintf "\tValue %s = V_copy(v_%s);\n" t v]; name = t }
		| EUnary (op, a) ->
			let a' = cg_expr e a in
			let t = fresh e in
			let fn = match op with
				| UNeg -> "op_neg"
				| UNot | UBang -> "op_not"
			in
			{ pre = a'.pre @ [sprintf "\tValue %s = %s(%s);\n" t fn a'.name]; name = t }
		| EBin (op, a, b) ->
			let a' = cg_expr e a in
			let b' = cg_expr e b in
			let t = fresh e in
			let fn = match op with
				| BAdd -> "op_add" | BSub -> "op_sub" | BMul -> "op_mul"
				| BDiv -> "op_div" | BIDiv -> "op_idiv" | BMod -> "op_mod"
				| BEq -> "op_eq" | BNeq -> "op_neq"
				| BLt -> "op_lt" | BLe -> "op_le" | BGt -> "op_gt" | BGe -> "op_ge"
				| BAnd -> "op_and" | BOr -> "op_or"
			in
			{ pre = a'.pre @ b'.pre @ [sprintf "\tValue %s = %s(%s, %s);\n" t fn a'.name b'.name]; name = t }
		| ECall (fname, args) ->
			let args' = List.map (cg_expr e) args in
			let t = fresh e in
			let pre = List.flatten (List.map (fun x -> x.pre) args') in
			let argnames = String.concat ", " (List.map (fun x -> x.name) args') in
			{ pre = pre @ [sprintf "\tValue %s = ibpc_%s(%s);\n" t fname argnames]; name = t }

	let rec collect_vars_stmts (stms:stmt list) acc =
		List.fold_left (fun acc st ->
			match st with
			| SAssign (v, _) -> if List.mem v acc then acc else v::acc
			| SInput v -> if List.mem v acc then acc else v::acc
			| SOutput _ -> acc
			| SIf (branches, elseb) ->
				let acc = List.fold_left (fun a (_,b) -> collect_vars_stmts b a) acc branches in
				begin match elseb with None -> acc | Some b -> collect_vars_stmts b acc end
			| SLoopWhile (_, b)
			| SLoopUntil (_, b) -> collect_vars_stmts b acc
			| SFor (v, _, _, b) ->
				let acc = if List.mem v acc then acc else v::acc in
				collect_vars_stmts b acc
			| SBreak | SContinue -> acc
			| SReturn _ -> acc
			| SExpr _ -> acc
		) acc stms

	let rec emit_stmt (e:env) (st:stmt) =
		match st with
		| SAssign (v, ex) ->
			declare_var e v;
			let ce = cg_expr e ex in
			List.iter (emit e "%s") ce.pre;
			emit e "\tv_%s = V_copy(%s);\n" v ce.name

		| SInput v ->
			declare_var e v;
			emit e "\tibpc_input_into(&v_%s);\n" v

		| SOutput xs ->
			let ces = List.map (cg_expr e) xs in
			List.iter (fun ce -> List.iter (emit e "%s") ce.pre) ces;
			let names = List.map (fun ce -> ce.name) ces in
			emit e "\t{ Value _args[%d] = {0};\n" (List.length names);
			List.iteri (fun i n -> emit e "\t\t_args[%d] = %s;\n" i n) names;
			emit e "\t\tibpc_output_n(%d, _args);\n\t}\n" (List.length names)

		| SIf (branches, elseb) ->
			emit_if_chain e branches elseb

		| SLoopWhile (cond, body) ->
			let c = cg_expr e cond in
			List.iter (emit e "%s") c.pre;
			emit e "\twhile(as_condition(%s)){\n" c.name;
			List.iter (emit_stmt e) body;
			emit e "\t}\n"

		| SLoopUntil (cond, body) ->
			let c = cg_expr e cond in
			List.iter (emit e "%s") c.pre;
			emit e "\twhile(!as_condition(%s)){\n" c.name;
			List.iter (emit_stmt e) body;
			emit e "\t}\n"

		| SFor (v, a, b, body) ->
			declare_var e v;
			let ca = cg_expr e a in
			let cb = cg_expr e b in
			List.iter (emit e "%s") ca.pre;
			List.iter (emit e "%s") cb.pre;
			let ta = fresh e and tb = fresh e in
			emit e "\tlong long %s = as_int_floor(%s);\n" ta ca.name;
			emit e "\tlong long %s = as_int_floor(%s);\n" tb cb.name;
			let ii = fresh e in
			emit e "\tfor(long long %s=%s; %s <= %s; ++%s){\n" ii ta ii tb ii;
			emit e "\t\tv_%s = V_INT(%s);\n" v ii;
			List.iter (emit_stmt e) body;
			emit e "\t}\n"

		| SBreak -> emit e "\tbreak;\n"
		| SContinue -> emit e "\tcontinue;\n"

		| SReturn ex ->
			let ce = cg_expr e ex in
			List.iter (emit e "%s") ce.pre;
			emit e "\treturn %s;\n" ce.name

		| SExpr ex ->
			let ce = cg_expr e ex in
			List.iter (emit e "%s") ce.pre;
			()

	and emit_if_chain (e:env) (branches:(expr * stmt list) list) (elseb:stmt list option) =
		match branches with
		| [] ->
			begin match elseb with
			| None -> ()
			| Some b -> List.iter (emit_stmt e) b
			end
		| (cond, body) :: rest ->
			let c = cg_expr e cond in
			List.iter (emit e "%s") c.pre;
			emit e "\tif(as_condition(%s)){\n" c.name;
			List.iter (emit_stmt e) body;
			emit e "\t}\n";
			begin match rest, elseb with
			| [], None -> ()
			| _ ->
				emit e "\telse{\n";
				emit_if_chain e rest elseb;
				emit e "\t}\n"
			end
	
	let emit_func (f:func) =
		let e = env () in
		emit e "Value ibpc_%s(%s){\n"
			f.name
			(String.concat ", "
				(List.map (fun p -> "Value " ^ p) f.params));
		let locals = collect_vars_stmts f.body [] in
		List.iter (declare_var e) locals;
		List.iter (emit_stmt e) f.body;
		emit e "\treturn V_NULL();\n";
		emit e "}\n";
		Buffer.contents e.buf

	let generate (p:prog) : string =
		let protos =
			List.map (fun (f:Ast.func) ->
				sprintf "Value ibpc_%s(%s);\n"
					f.name
					(String.concat ", "
						(List.map (fun p -> "Value " ^ p) f.params))
			) p.funcs
			|> String.concat ""
		in
		let b = Buffer.create 8192 in
		Buffer.add_string b (runtime_header ());
		Buffer.add_string b "\n/* Prototypes */\n";
		Buffer.add_string b protos;
		Buffer.add_string b "\n/* Functions */\n";
		List.iter (fun f ->
			Buffer.add_string b (emit_func f);
			Buffer.add_char b '\n';
		) p.funcs;
		let has_main =
			List.exists (fun (f:Ast.func) -> String.lowercase_ascii f.name = "main" && f.params = []) p.funcs
		in
		if not has_main then failwith "No func main() found.";
		Buffer.add_string b "int main(void){ Value r = ibpc_main(); (void)r; return 0; }\n";
		Buffer.contents b
end

let read_file path =
	let ic = open_in_bin path in
	let st = in_channel_length ic in
	let s = really_input_string ic st in
	close_in ic; s

let write_file path s =
	let oc = open_out_bin path in
	output_string oc s; close_out oc

let () =
	let infile = ref None in
	let outfile = ref "out.c" in
	let speclist = [
		("-o", Arg.String (fun s -> outfile := s), "Output C file");
	] in
	let anon f =
		match !infile with
		| None -> infile := Some f
		| Some _ -> raise (Arg.Bad "multiple input files")
	in
	Arg.parse speclist anon "ibpc <input.ibpc> [-o out.c]";
	match !infile with
	| None -> eprintf "Provide an input .ibpc file.\n"; exit 2
	| Some path ->
		let src = read_file path in
		let lx = Lexer.make src in
		let st = Lexer.stream lx in
		match Parser.parse_prog st with
		| Error msg ->
			eprintf "Parse error: %s (line %d)\n" msg lx.line; exit 1
		| Ok prog ->
			let c = Codegen.generate prog in
			write_file !outfile c