taddeus
/
civicaml


			
				
					
						
						
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176
							type location = string * int * int * int * int
let noloc = ("", 0, 0, 0, 0)

type operator =
    | Neg | Not
    | Add | Sub | Mul | Div | Mod
    | Eq | Ne | Lt | Le | Gt | Ge
    | And | Or
type const =
    | BoolVal of bool
    | IntVal of int
    | FloatVal of float
type ctype =
    | Void | Bool | Int | Float | Array of ctype
    | ArrayDims of ctype * node list
and annotation =
    | Loc of location
    | Depth of int
    | Index of int
    | Type of ctype
    | LabelName of string
and ann = annotation list
and node =
    (* Global *)
    | Program of node list * ann
      (* list of declarations *)
    | FunDec of ctype * string * node list * ann
      (* ret_type, name, params *)
    | FunDef of bool * ctype * string * node list * node * ann
      (* export, ret_type, name, params, body *)
    | GlobalDec of ctype * string * ann
      (* type, name *)
    | GlobalDef of bool * ctype * string * node option * ann
      (* export, type, name, initialisation? *)
    | Param of ctype * string * ann
      (* type, name *)
    | Dim of string * ann
      (* name *)

    | VarDecs of node list
    | LocalFuns of node list

    (* Statements *)
    | VarDec of ctype * string * node option * ann
      (* type, name, initialisation? *)
    | Assign of string * node list option * node * ann
      (* name, indices?, value *)
    | For of string * node * node * node * node * ann
      (* counter, start, stop, step, body *)
    | Allocate of node * node list * ann
      (* dec, dims  # name = __allocate(dims) *)
    | Return of node * ann                   (* return <value>; *)
    | Expr of node                           (* <expr>; *)
    | Block of node list                     (* { <body> } *)
    | If of node * node * ann                (* cond, body *)
    | IfElse of node * node * node * ann     (* cond, true_body, false_body *)
    | While of node * node * ann             (* cond, body *)
    | DoWhile of node * node * ann           (* cond, body *)

    (* Expressions *)
    | Const of const * ann                     (* bool|int|float value *)
    | ArrayConst of node list * ann            (* [<exprs>] *)
    | Var of string * node list option * ann   (* <name> [<indices>]? *)
    | Monop of operator * node * ann           (* op, operand *)
    | Binop of operator * node * node * ann    (* op, left, right *)
    | TypeCast of ctype * node * ann           (* (type) operand *)
    | FunCall of string * node list * ann      (* name(args) *)
    | Arg of node                              (* function argument *)

    (* Additional types for convenience in traversals
     * Mostly used to annotate existing nodes with information from declarations *)
    | VarUse of node * node list option * ann  (* Same as Var, but with decl. *)
    | FunUse of node * node list * ann         (* Same as FunCall, but with decl. *)
    | VarLet of node * node list option * node * ann (* replacement for Assign *)
    | ArrayScalar of node                      (* (Bool|Int|Float)Const *)
    | ArrayInit of node * node list            (* Array(Scalar|Const), dimensions *)
    | Cond of node * node * node * ann         (* cond, true_expr, false_expr *)
    | DummyNode                                (* null node, pruned by traversals *)

type stack_scope = Glob | Local | Rel of int | Current
type rtn_scope = ExternFun of int | LocalFun of int * string
type instr =
    | Comment of string                 (* # <comment> *)
    | InlineComment of instr * string   (* <instr>  # <comment> *)
    | Label of string                   (* <label>: *)

    (* Directives *)
    (* .export "<name>" <ret_type> [ <arg_type>; ... ] <label> *)
    | Export of string * ctype * ctype list * string
    (* .import "<name>" <ret_type> [ <arg_type>; ... ] *)
    | Import of string * ctype * ctype list
    (* .const <value> *)
    | ConstDef of const
    (* .global <type> *)
    | Global of ctype

    | Store of ctype * stack_scope * int (* [ifba]store[ gn] *)

    | Load of ctype * stack_scope * int  (* [ifb]load[ gn] G *)
    | LoadConst of ctype * int           (* [ifb]loadc C *)
    | LoadImm of const                   (* [ifb]load_[01tf] <value> *)

    (* Operators *)
    | Op of operator * ctype             (* [ifb]() *)
    | Convert of ctype * ctype           (* i2f|f2i *)
    | Inc of int * int                   (* iinc L C *)
    | Dec of int * int                   (* idec L C *)
    | IncOne of int                      (* iinc_1 L *)
    | DecOne of int                      (* idec_1 L *)

    (* Control flow *)
    | RtnInit of stack_scope
    | RtnJmp of rtn_scope
    | RtnEnter of int
    | Ret of ctype
    | Branch of bool * string
    | Jump of string

    (* Stack management *)
    | Pop of ctype                       (* [ifb]pop *)

    (* Arrays *)
    | NewArray of ctype * int
    | LoadArray of ctype
    | StoreArray of ctype

    | EmptyLine
    | DummyInstr

let immediate_consts = [
    BoolVal true;
    BoolVal false;
    IntVal (-1);
    IntVal 0;
    IntVal 1;
    FloatVal 0.0;
    FloatVal 1.0;
]

(* Container for command-line arguments *)
type args_record = {
    mutable infile   : string option;
    mutable outfile  : string option;
    mutable verbose  : int;
    mutable cpp      : bool;
    mutable optimize : bool;
    mutable endphase : string;
}

(* Commandline args are stored in a global record
 * (yes, it is a bit dirty, but I don't know how to do this without passing
 * [args] to every function) *)
let args = {
    infile   = None;
    outfile  = None;
    verbose  = 1;
    cpp      = true;
    optimize = true;
    endphase = "";
}

(* Intermediate representations between phases *)
type intermediate =
    | Empty
    | FileContent of string * string
    | Ast of node
    | Assembly of instr list

(* Exceptions *)
exception LocError of location * string
exception NodeError of node * string
exception CompileError of string
exception EmptyError

exception InvalidNode
exception InvalidInput of string