stop.ml
open Core.Std
module A = Analysis
module C = Codegen
module E = Exceptions
module G = Generator
module L = Llvm
module P = Parser
module S = Scanner
module U = Utils
type action = Tokens | Ast | Sast
| CompileStdinStdout| CompileStdinFile
| CompileFileStdout | CompileFileFile
| Help
let get_action = function
-> Tokens
| -> Ast
| -> Sast
| -> CompileStdinStdout
| -> CompileStdinFile
| -> CompileFileStdout
| -> CompileFileFile
| -> Help
| _ as s -> raise (E.InvalidOption s)
let check_single_argument = function
-> (Help, "")
| "-tendl"
| "-t"
| "-a"
| "-s"
| "-c"
| -> raise (E.NoFileArgument)
| "-cff"
| _ as s -> (CompileFileStdout, s)
let help_string = (
"Usage: stop [-option] <source file>\n" ^
"-option: (defaults to \"-css\")\n" ^
"\t-t: Print tokens\n" ^
"\t-a: Prints AST\n" ^
"\t-s: Prints SAST\n" ^
"\t-css: Compiles stdin to stdout \n" ^
"\t-csf: Compiles stdin to file\n" ^
"\t-cfs: Compiles file to stdout (<filename>.<ext>)\n" ^
"\t-cff: Compiles file to file (<filename>.<ext> -> <filename>.ll)\n" ^
"\t-h: Print help\n"
)
let stop_name filename =
let basename = Filename.basename filename in
let filename = Filename.chop_extension basename in
filename ^ ".ll"
let _ =
ignore(Printexc.record_backtrace true);
try
let (action, filename) =
if Array.length Sys.argv = 1 then
CompileStdinStdout, ""
else if Array.length Sys.argv = 2 then
check_single_argument (Sys.argv.(1))
else if Array.length Sys.argv = 3 then
get_action Sys.argv.(1), Sys.argv.(2)
else raise E.InvalidArgc
in
let file_in () = if filename = "" then stdin else open_in filename in
let lexbuf () = Lexing.from_channel (file_in ()) in
let token_list () = G.build_token_list filename (lexbuf ()) in
let ast () = G.build_ast filename (token_list ()) in
let sast () = A.analyze filename (ast ()) in
let llm () = C.codegen_sast (sast ()) in
match action with
Tokens -> print_string (U.token_list_to_string (token_list ()))
| Ast -> print_string (U.string_of_program (ast()))
| Sast -> print_string (U.string_of_sprogram (sast()))
| CompileStdinStdout
| CompileFileStdout -> print_string (L.string_of_llmodule (llm ()))
| CompileStdinFile
| CompileFileFile -> L.print_module (stop_name filename) (llm ())
| Help -> print_string help_string
with
E.IllegalCharacter(file, c, ln) ->
print_string
("Illegal character '" ^ c ^ "' in line "
^ string_of_int ln ^ " of " ^ file ^ "\n")
| Parsing.Parse_error ->
print_string
("Syntax Error:\n"
^ U.error_string_of_file !G.filename_ref
^ ", line " ^ string_of_int !G.lineno_ref
^ ", characters " ^ U.error_string_of_cnum !G.cnum_ref !G.last_token_ref
^ ", Token " ^ U.string_of_token !G.last_token_ref ^ "\n")
| _ as e -> raise e
codegen.ml
open Core.Std
open Sast
open Ast
module A = Analysis
module E = Exceptions
module L = Llvm
module U = Utils
let context = L.global_context ()
let the_module = L.create_module context "Stop"
let builder = L.builder context
let i32_t = L.i32_type context
let i8_t = L.i8_type context
let i1_t = L.i1_type context
let float_t = L.float_type context
let void_t = L.void_type context
let str_t = L.pointer_type (L.i8_type context)
let br_block = ref (L.block_of_value (L.const_int i32_t 0))
let cont_block = ref (L.block_of_value (L.const_int i32_t 0))
let is_loop = ref false
let struct_types:(string, L.lltype) Hashtbl.t = Hashtbl.create ()
~hashable:String.hashable
~size:10
let struct_field_indexes:(string, int) Hashtbl.t = Hashtbl.create ()
~hashable:String.hashable
~size:50
let named_values:(string, L.llvalue) Hashtbl.t = Hashtbl.create ()
~hashable:String.hashable
~size:50
let named_parameters:(string, L.llvalue) Hashtbl.t = Hashtbl.create ()
~hashable:String.hashable
~size:50
let str_type = Arraytype(Char_t, 1)
let rec get_array_type array_t = match array_t with
Arraytype(prim, 1) -> L.pointer_type(get_lltype_exn (Datatype(prim)))
| Arraytype(prim, i) -> L.pointer_type(get_array_type (Arraytype(prim, i-1)))
| _ -> raise(E.InvalidDatatype "Array Type")
and find_struct_exn name =
if name = "String" then (L.i8_type context) else
try
Hashtbl.find_exn struct_types name
with
Not_found -> raise (E.InvalidStructType(name))
and get_function_type data_t_list return_t =
let llargs = List.fold_left (List.rev data_t_list)
~f:(fun l data_t -> get_lltype_exn data_t :: l)
~init:[]
in
L.pointer_type (L.function_type (get_lltype_exn return_t) (Array.of_list llargs))
and get_lltype_exn (data_t:datatype) = match data_t with
Datatype(Int_t) -> i32_t
| Datatype(Float_t) -> float_t
| Datatype(Bool_t) -> i1_t
| Datatype(Char_t) -> i8_t
| Datatype(Unit_t) -> void_t
| Datatype(Object_t(name)) -> L.pointer_type(find_struct_exn name)
| Arraytype(t, i) -> get_array_type (Arraytype(t, i))
| Functiontype(dt_l, dt) -> get_function_type dt_l dt
| data_t -> raise (E.InvalidDatatype(U.string_of_datatype data_t))
let lookup_llfunction_exn fname = match (L.lookup_function fname the_module) with
None -> raise (E.LLVMFunctionNotFound(fname))
| Some f -> f
let rec codegen_sexpr sexpr ~builder:llbuilder = match sexpr with
SIntLit(i) -> L.const_int i32_t i
| SFloatLit(f) -> L.const_float float_t f
| SBoolLit(b) -> if b then L.const_int i1_t 1 else L.const_int i1_t 0
| SCharLit(c) -> L.const_int i8_t (Char.to_int c)
| SStringLit(s) -> L.build_global_stringptr s "tmp" llbuilder
| SFunctionLit(s, _) -> codegen_function_lit s llbuilder
| SAssign(e1, e2, _) -> codegen_assign e1 e2 llbuilder
| SArrayAccess(se, se_l, _) -> codegen_array_access false se se_l llbuilder
| SObjAccess(se1, se2, d) -> codegen_obj_access true se1 se2 d llbuilder
| SNoexpr -> L.build_add (L.const_int i32_t 0) (L.const_int i32_t 0) "nop" llbuilder
| SId(id, _) -> codegen_id false id llbuilder
| SBinop(e1, op, e2, data_t) -> handle_binop e1 op e2 data_t llbuilder
| SUnop(op, e, d) -> handle_unop op e d llbuilder
| SCall(fname, se_l, data_t, _) -> codegen_call fname se_l data_t llbuilder
| SArrayCreate(t, el, d) -> codegen_array_create llbuilder t d el
| _ -> raise E.NotImplemented
and handle_binop e1 op e2 data_t llbuilder =
let type1 = A.sexpr_to_type e1 in
let type2 = A.sexpr_to_type e2 in
let e1 = codegen_sexpr e1 ~builder:llbuilder in
let e2 = codegen_sexpr e2 ~builder:llbuilder in
let int_ops e1 op e2 =
match op with
Add -> L.build_add e1 e2 "addtmp" llbuilder
| Sub -> L.build_sub e1 e2 "subtmp" llbuilder
| Mult -> L.build_mul e1 e2 "multmp" llbuilder
| Div -> L.build_sdiv e1 e2 "divtmp" llbuilder
| Modulo -> L.build_srem e1 e2 "sremtmp" llbuilder
| Equal -> L.build_icmp L.Icmp.Eq e1 e2 "eqtmp" llbuilder
| Neq -> L.build_icmp L.Icmp.Ne e1 e2 "neqtmp" llbuilder
| Less -> L.build_icmp L.Icmp.Slt e1 e2 "lesstmp" llbuilder
| Leq -> L.build_icmp L.Icmp.Sle e1 e2 "leqtmp" llbuilder
| Greater -> L.build_icmp L.Icmp.Sgt e1 e2 "sgttmp" llbuilder
| Geq -> L.build_icmp L.Icmp.Sge e1 e2 "sgetmp" llbuilder
| And -> L.build_and e1 e2 "andtmp" llbuilder
| Or -> L.build_or e1 e2 "ortmp" llbuilder
| _ -> raise Exceptions.IntOpNotSupported
in
let float_ops e1 op e2 =
match op with
Add -> L.build_fadd e1 e2 "flt_addtmp" llbuilder
| Sub -> L.build_fsub e1 e2 "flt_subtmp" llbuilder
| Mult -> L.build_fmul e1 e2 "flt_multmp" llbuilder
| Div -> L.build_fdiv e1 e2 "flt_divtmp" llbuilder
| Modulo -> L.build_frem e1 e2 "flt_sremtmp" llbuilder
| Equal -> L.build_fcmp L.Fcmp.Oeq e1 e2 "flt_eqtmp" llbuilder
| Neq -> L.build_fcmp L.Fcmp.One e1 e2 "flt_neqtmp" llbuilder
| Less -> L.build_fcmp L.Fcmp.Ult e1 e2 "flt_lesstmp" llbuilder
| Leq -> L.build_fcmp L.Fcmp.Ole e1 e2 "flt_leqtmp" llbuilder
| Greater -> L.build_fcmp L.Fcmp.Ogt e1 e2 "flt_sgttmp" llbuilder
| Geq -> L.build_fcmp L.Fcmp.Oge e1 e2 "flt_sgetmp" llbuilder
| _ -> raise Exceptions.FloatOpNotSupported
in
let type_handler data_t = match data_t with
Datatype(Int_t)
| Datatype(Char_t)
| Datatype(Bool_t) -> int_ops e1 op e2
| Datatype(Float_t) -> float_ops e1 op e2
| _ -> raise E.InvalidBinopEvaluationType
in
type_handler data_t
and handle_unop op se data_t llbuilder =
let se_type = A.sexpr_to_type_exn se in
let llvalue = codegen_sexpr se llbuilder in
let unops op se_type llval = match (op, se_type) with
(Neg, Datatype(Int_t)) -> L.build_neg llvalue "int_unoptmp" llbuilder
| (Neg, Datatype(Float_t)) -> L.build_fneg llvalue "flt_unoptmp" llbuilder
| (Not, Datatype(Bool_t)) -> L.build_not llvalue "bool_unoptmp" llbuilder
| _ -> raise E.UnopNotSupported
in
let type_handler data_t = match data_t with
Datatype(Float_t)
| Datatype(Int_t)
| Datatype(Bool_t) -> unops op se_type llvalue
| _ -> raise E.InvalidUnopEvaluationType
in
type_handler data_t
and codegen_call sexpr sexpr_l data_t llbuilder = match sexpr with
SId(fname, _) ->
(match fname with
-> codegen_printf sexpr_l llbuilder
| _ -> codegen_function_call sexpr sexpr_l data_t llbuilder)
| _ -> codegen_function_call sexpr sexpr_l data_t llbuilder
and codegen_function_call sexpr sexpr_l data_t llbuilder =
let call_function fllval =
let params = List.map ~f:(codegen_sexpr ~builder:llbuilder) sexpr_l in
match data_t with
Datatype(Unit_t) -> L.build_call fllval (Array.of_list params) "" llbuilder
| _ -> L.build_call fllval (Array.of_list params) "tmp" llbuilder
in
match sexpr with
SId(fname, _) ->
let f = lookup_llfunction_exn fname in
call_function f
| SObjAccess(se1, se2, data_t) ->
let f = codegen_obj_access true se1 se2 data_t llbuilder in
call_function f
and codegen_printf sexpr_l llbuilder =
let format_str = List.hd_exn sexpr_l in
let format_llstr = match format_str with
SStringLit(s) -> L.build_global_stringptr s "fmt" llbuilder
| _ -> raise E.PrintfFirstArgNotString
in
let args = List.tl_exn sexpr_l in
let format_llargs = List.map args ~f:(codegen_sexpr ~builder:llbuilder) in
let fun_llvalue = lookup_llfunction_exn "printf" in
let llargs = Array.of_list (format_llstr :: format_llargs) in
L.build_call fun_llvalue llargs "printf" llbuilder
and codegen_id isDeref id llbuilder =
if isDeref then
try Hashtbl.find_exn named_parameters id
with | Not_found ->
try let var = Hashtbl.find_exn named_values id in
L.build_load var id llbuilder
with | Not_found -> raise (E.UndefinedId id)
else
try Hashtbl.find_exn named_parameters id
with | Not_found ->
try Hashtbl.find_exn named_values id
with | Not_found -> raise (E.UndefinedId id)
and codegen_assign se1 se2 llbuilder =
let lhs = match se1 with
SId(id, _) ->
(try Hashtbl.find_exn named_parameters id
with Not_found ->
try Hashtbl.find_exn named_values id
with Not_found -> raise (E.UndefinedId id))
| SObjAccess(se1, se2, data_t) -> codegen_obj_access false se1 se2 data_t llbuilder
| SArrayAccess(se, se_l, _) ->
codegen_array_access true se se_l llbuilder
| _ -> raise E.AssignmentLhsMustBeAssignable
in
let rhs = match se2 with
SObjAccess(se1, se2, data_t) -> codegen_obj_access true se1 se2 data_t llbuilder
| _ -> codegen_sexpr se2 ~builder:llbuilder
in
ignore(L.build_store rhs lhs llbuilder);
rhs
and codegen_obj_access isAssign lhs rhs data_t llbuilder =
let obj_type_name = match lhs with
SId(_, data_t) -> U.string_of_datatype data_t
| SObjAccess(_, _, data_t) -> U.string_of_datatype data_t
in
let struct_llval = match lhs with
SId(s, _) -> codegen_id false s llbuilder
| SObjAccess(le, re, data_t) -> codegen_obj_access true le re data_t llbuilder
in
let field_name = match rhs with
SId(field, _) -> field
in
let field_type = match rhs with
SId(_, data_t) -> data_t
in
let search_term = obj_type_name ^ "." ^ field_name in
let field_index = Hashtbl.find_exn struct_field_indexes search_term in
let llvalue = L.build_struct_gep struct_llval field_index field_name llbuilder in
let llvalue = if isAssign
then L.build_load llvalue field_name llbuilder
else llvalue
in
llvalue
and codegen_array_access isAssign e e_l llbuilder =
let indices = List.map e_l ~f:(codegen_sexpr ~builder:llbuilder) in
let indices = Array.of_list indices in
let arr = codegen_sexpr e ~builder:llbuilder in
let llvalue =L.build_gep arr indices "tmp" llbuilder in
if isAssign
then llvalue
else L.build_load llvalue "tmp" llbuilder
and codegen_function_lit fname llbuilder =
let f_llval = lookup_llfunction_exn fname in
f_llval
and codegen_return sexpr llbuilder = match sexpr with
SNoexpr -> L.build_ret_void llbuilder
| _ -> L.build_ret (codegen_sexpr sexpr ~builder:llbuilder) llbuilder
and codegen_break llbuilder =
let b = fun () -> !br_block in
L.build_br (b ()) llbuilder
and codegen_continue llbuilder =
let b = fun () -> !cont_block in
L.build_br (b ()) llbuilder
and codegen_local var_name data_t sexpr llbuilder =
let lltype = match data_t with
Datatype(Object_t(name)) -> find_struct_exn name
| _ -> get_lltype_exn data_t
in
let alloca = L.build_alloca lltype var_name llbuilder in
Hashtbl.add_exn named_values ~key:var_name ~data:alloca;
let lhs = SId(var_name, data_t) in
match sexpr with
SNoexpr -> alloca
| _ -> codegen_assign lhs sexpr llbuilder
and codegen_stmt stmt ~builder:llbuilder = match stmt with
SBlock(sl) -> List.hd_exn (List.map ~f:(codegen_stmt ~builder:llbuilder) sl)
| SExpr(se, _) -> codegen_sexpr se llbuilder
| SReturn(se, _) -> codegen_return se llbuilder
| SLocal(s, data_t, se) -> codegen_local s data_t se llbuilder
| SIf(se, s1, s2) -> codegen_if_stmt se s1 s2 llbuilder
| SFor(se1, se2, se3, ss) -> codegen_for_stmt se1 se2 se3 ss llbuilder
| SWhile(se, ss) -> codegen_while_stmt se ss llbuilder
| SBreak -> codegen_break llbuilder
| SContinue -> codegen_continue llbuilder
and codegen_if_stmt predicate then_stmt else_stmt llbuilder =
let cond_val = codegen_sexpr predicate llbuilder in
let start_bb = L.insertion_block llbuilder in
let the_function = L.block_parent start_bb in
let then_bb = L.append_block context "then" the_function in
L.position_at_end then_bb llbuilder;
let _ = codegen_stmt then_stmt llbuilder in
let new_then_bb = L.insertion_block llbuilder in
let else_bb = L.append_block context "else" the_function in
L.position_at_end else_bb llbuilder;
let _ = codegen_stmt else_stmt llbuilder in
let new_else_bb = L.insertion_block llbuilder in
let merge_bb = L.append_block context "ifcont" the_function in
L.position_at_end merge_bb llbuilder;
let else_bb_val = L.value_of_block new_else_bb in
L.position_at_end start_bb llbuilder;
ignore (L.build_cond_br cond_val then_bb else_bb llbuilder);
L.position_at_end new_then_bb llbuilder; ignore (L.build_br merge_bb llbuilder);
L.position_at_end new_else_bb llbuilder; ignore (L.build_br merge_bb llbuilder);
L.position_at_end merge_bb llbuilder;
else_bb_val
and codegen_for_stmt init_se cond_se inc_se body_stmt llbuilder =
let old_val = !is_loop in
is_loop := true;
let the_function = L.block_parent (L.insertion_block llbuilder) in
let _ = codegen_sexpr init_se llbuilder in
let loop_bb = L.append_block context "loop" the_function in
let inc_bb = L.append_block context "inc" the_function in
let cond_bb = L.append_block context "cond" the_function in
let after_bb = L.append_block context "afterloop" the_function in
let _ = if not old_val then
cont_block := inc_bb;
br_block := after_bb;
in
ignore (L.build_br cond_bb llbuilder);
L.position_at_end loop_bb llbuilder;
ignore (codegen_stmt body_stmt ~builder:llbuilder);
let bb = L.insertion_block llbuilder in
L.move_block_after bb inc_bb;
L.move_block_after inc_bb cond_bb;
L.move_block_after cond_bb after_bb;
ignore(L.build_br inc_bb llbuilder);
L.position_at_end inc_bb llbuilder;
let _ = codegen_sexpr inc_se llbuilder in
ignore(L.build_br cond_bb llbuilder);
L.position_at_end cond_bb llbuilder;
let cond_val = codegen_sexpr cond_se llbuilder in
ignore (L.build_cond_br cond_val loop_bb after_bb llbuilder);
L.position_at_end after_bb llbuilder;
is_loop := old_val;
L.const_null float_t
and codegen_while_stmt cond_se body_stmt llbuilder =
let null_sexpr = SIntLit(0) in
codegen_for_stmt null_sexpr cond_se null_sexpr body_stmt llbuilder
and codegen_array_create llbuilder t expr_type el =
if(List.length el > 1) then raise(Exceptions.ArrayLargerThan1Unsupported)
else
match expr_type with
Arraytype(Char_t, 1) ->
let e = List.hd_exn el in
let size = (codegen_sexpr e llbuilder) in
let t = get_lltype_exn t in
let arr = L.build_array_malloc t size "tmp" llbuilder in
let arr = L.build_pointercast arr (L.pointer_type t) "tmp" llbuilder in
arr
| _ ->
let e = List.hd_exn el in
let t = get_lltype_exn t in
let size = (codegen_sexpr e llbuilder) in
let size_t = L.build_intcast (L.size_of t) i32_t "tmp" llbuilder in
let size = L.build_mul size_t size "tmp" llbuilder in
let size_real = L.build_add size (L.const_int i32_t 1) "arr_size" llbuilder in
let arr = L.build_array_malloc t size_real "tmp" llbuilder in
let arr = L.build_pointercast arr (L.pointer_type t) "tmp" llbuilder in
let arr_len_ptr = L.build_pointercast arr (L.pointer_type i32_t) "tmp" llbuilder in
ignore(L.build_store size_real arr_len_ptr llbuilder);
arr
let codegen_library_functions () =
let printf_t = L.var_arg_function_type i32_t [| L.pointer_type i8_t |] in
let _ = L.declare_function "printf" printf_t the_module in
let malloc_t = L.function_type (str_t) [| i32_t |] in
let _ = L.declare_function "malloc" malloc_t the_module in
let open_t = L.function_type i32_t [| (L.pointer_type i8_t); i32_t |] in
let _ = L.declare_function "open" open_t the_module in
let close_t = L.function_type i32_t [| i32_t |] in
let _ = L.declare_function "close" close_t the_module in
let read_t = L.function_type i32_t [| i32_t; L.pointer_type i8_t; i32_t |] in
let _ = L.declare_function "read" read_t the_module in
let write_t = L.function_type i32_t [| i32_t; L.pointer_type i8_t; i32_t |] in
let _ = L.declare_function "write" write_t the_module in
let lseek_t = L.function_type i32_t [| i32_t; i32_t; i32_t |] in
let _ = L.declare_function "lseek" lseek_t the_module in
let exit_t = L.function_type void_t [| i32_t |] in
let _ = L.declare_function "exit" exit_t the_module in
let realloc_t = L.function_type str_t [| str_t; i32_t |] in
let _ = L.declare_function "realloc" realloc_t the_module in
let getchar_t = L.function_type (i32_t) [| |] in
let _ = L.declare_function "getchar" getchar_t the_module in
let sizeof_t = L.function_type (i32_t) [| i32_t |] in
let _ = L.declare_function "sizeof" sizeof_t the_module in
()
let codegen_struct_stub s =
let struct_t = L.named_struct_type context s.scname
in
Hashtbl.add struct_types
~key:s.scname
~data:struct_t
let codegen_struct s =
let struct_t = Hashtbl.find_exn struct_types s.scname in
let type_list = List.map s.sfields
~f:(function Field(_, _, data_t) -> get_lltype_exn data_t)
in
let name_list = List.map s.sfields
~f:(function Field(_, s, _) -> s)
in
let type_list = i32_t :: type_list in
let name_list = ".key" :: name_list in
let type_array = Array.of_list type_list in
List.iteri name_list
~f:(fun i f ->
let n = s.scname ^ "." ^ f in
Hashtbl.add_exn struct_field_indexes ~key:n ~data:i);
L.struct_set_body struct_t type_array true
let codegen_function_stub sfdecl =
let fname = sfdecl.sfname in
let is_var_arg = ref false in
let params = List.rev
(List.fold_left sfdecl.sformals
~f:(fun l -> (function
Formal(_, data_t) -> get_lltype_exn data_t :: l
| _ -> is_var_arg := true; l))
~init: [])
in
let ftype =
if !is_var_arg
then L.var_arg_function_type (get_lltype_exn sfdecl.sreturn_t) (Array.of_list params)
else L.function_type (get_lltype_exn sfdecl.sreturn_t) (Array.of_list params)
in
L.define_function fname ftype the_module
let init_params f formals =
let formals = Array.of_list formals in
Array.iteri (L.params f)
~f:(fun i element ->
let n = formals.(i) in
let n = U.string_of_formal_name n in
L.set_value_name n element;
Hashtbl.add_exn named_parameters
~key:n
~data:element;
)
let codegen_function sfdecl =
Hashtbl.clear named_values;
Hashtbl.clear named_parameters;
let fname = sfdecl.sfname in
let f = lookup_llfunction_exn fname in
let llbuilder = L.builder_at_end context (L.entry_block f) in
let _ = init_params f sfdecl.sformals in
let _ = codegen_stmt (SBlock(sfdecl.sbody)) ~builder:llbuilder in
let last_bb = match (L.block_end (lookup_llfunction_exn fname)) with
L.After(block) -> block
| L.At_start(_) -> raise (E.FunctionWithoutBasicBlock(fname))
in
let return_t = L.return_type (L.type_of (lookup_llfunction_exn fname)) in
match (L.instr_end last_bb) with
L.After(instr) ->
let op = L.instr_opcode instr in
if op = L.Opcode.Ret
then ()
else
if return_t = void_t
then (ignore(L.build_ret_void); ())
else (ignore(L.build_ret (L.const_int i32_t 0) llbuilder); ())
| L.At_start(_) ->
if return_t = void_t
then (ignore(L.build_ret_void); ())
else (ignore(L.build_ret (L.const_int i32_t 0) llbuilder); ())
let codegen_main main =
Hashtbl.clear named_values;
Hashtbl.clear named_parameters;
let ftype = L.function_type i32_t [| i32_t; L.pointer_type str_t |] in
let f = L.define_function "main" ftype the_module in
let llbuilder = L.builder_at_end context (L.entry_block f) in
let argc = L.param f 0 in
let argv = L.param f 1 in
L.set_value_name "argc" argc;
L.set_value_name "argv" argv;
Hashtbl.add_exn named_parameters ~key:"argc" ~data:argc;
Hashtbl.add_exn named_parameters ~key:"argv" ~data:argv;
let _ = codegen_stmt (SBlock(main.sbody)) llbuilder in
let last_bb = match (L.block_end (lookup_llfunction_exn "main")) with
L.After(block) -> block
| L.At_start(_) -> raise (E.FunctionWithoutBasicBlock("main"))
in
match (L.instr_end last_bb) with
L.After(instr) ->
let op = L.instr_opcode instr in
if op = L.Opcode.Ret
then ()
else ignore(L.build_ret (L.const_int i32_t 0) llbuilder); ()
| L.At_start(_) -> ignore(L.build_ret (L.const_int i32_t 0) llbuilder); ()
let codegen_sast sast =
let _ = codegen_library_functions () in
let _ = List.map sast.classes ~f:(fun s -> codegen_struct_stub s) in
let _ = List.map sast.classes ~f:(fun s -> codegen_struct s) in
let _ = List.map sast.functions ~f:(fun f -> codegen_function_stub f) in
let _ = List.map sast.functions ~f:(fun f -> codegen_function f) in
let _ = codegen_main sast.main in
the_module
parser.mly
/* Ocamlyacc Parser for Stop */
%{
open Ast
open Core.Std
module E = Exceptions
let lambda_num = ref 0
%}
%token DOT COMMA SEMI COLON LPAREN RPAREN LBRACE RBRACE LBRACKET RBRACKET
%token PLUS MINUS TIMES DIVIDE ASSIGN NOT CARET MODULO
%token INCREMENT DECREMENT
%token EQ NEQ LT LEQ GT GEQ TRUE FALSE AND OR
%token IF ELSE FOR WHILE BREAK CONTINUE
%token ARROW FATARROW
%token RETURN
%token FINAL
%token PUBLIC PRIVATE ANON
%token SPEC CLASS METHOD
%token MATCH CASE
%token TYPE VAR THIS
%token DEF EXTENDS
%token EOF
/* Processor Directives */
%token INCLUDE
%token MODULE
/* Primitive Types */
%token INT FLOAT BOOL CHAR UNIT
%token <string> TYPE_ID
/* Literals */
%token <int> INT_LIT
%token <float> FLOAT_LIT
%token <char> CHAR_LIT
%token <string> STRING_LIT
%token <string> ID
/* Precedence Rules */
%nonassoc NOELSE
%nonassoc ELSE
%right ASSIGN
%left AND OR
%left EQ NEQ
%left LT GT LEQ GEQ
%left PLUS MINUS
%left TIMES DIVIDE MODULO
%right NOT NEG
%right RBRACKET
%left LBRACKET
%left INCREMENT DECREMENT
%right DOT
%right ARROW
%start program
%type <Ast.program> program
%%
/* Context-Free Grammar */
/* -------------------- */
program:
constituents EOF { Program(List.rev $1.includes, List.rev $1.specs,
List.rev $1.cdecls, List.rev $1.fdecls) }
constituents:
{ {
includes = [];
specs = [];
cdecls = [];
fdecls = [];
} }
| constituents include_stmt { {
includes = $2 :: $1.includes;
specs = $1.specs;
cdecls = $1.cdecls;
fdecls = $1.fdecls;
} }
| constituents sdecl { {
includes = $1.includes;
specs = $2 :: $1.specs;
cdecls = $1.cdecls;
fdecls = $1.fdecls;
} }
| constituents cdecl { {
includes = $1.includes;
specs = $1.specs;
cdecls = $2 :: $1.cdecls;
fdecls = $1.fdecls;
} }
| constituents fdecl { {
includes = $1.includes;
specs = $1.specs;
cdecls = $1.cdecls;
fdecls = $2 :: $1.fdecls;
} }
/* Includes */
/* -------- */
include_stmt:
INCLUDE STRING_LIT { Include($2) }
/* Functions */
/* --------- */
fdecl:
DEF ID ASSIGN LPAREN formals_opt RPAREN COLON datatype LBRACE stmts RBRACE { {
fname = $2;
ftype = Functiontype(snd $5, $8);
return_t = $8;
formals = fst $5;
body = $10;
scope = Public;
overrides = false;
root_cname = None;
} }
/* Specs */
/* ----- */
sdecl:
SPEC TYPE_ID LBRACE RBRACE { {
sname = $2;
} }
/* Classes */
/* ------- */
cdecl:
CLASS TYPE_ID ASSIGN LBRACE cbody RBRACE { {
cname = $2;
extends = NoParent;
cbody = $5;
} }
cbody:
/* nothing */ { {
fields = [];
methods = [];
} }
| cbody field { {
fields = $2 :: $1.fields;
methods = $1.methods;
} }
| cbody cfdecl { {
fields = $1.fields;
methods = $2 :: $1.methods;
} }
cfdecl:
scope DEF ID ASSIGN LPAREN formals_opt RPAREN COLON datatype LBRACE stmts RBRACE { {
fname = $3;
ftype = Functiontype(snd $6, $9);
return_t = $9;
formals = fst $6;
body = $11;
scope = $1;
overrides = false;
root_cname = None;
} }
/* Datatypes */
/* --------- */
datatype:
type_tag { Datatype($1) }
| array_type { $1 }
| function_type { $1 }
type_tag:
primitive { $1 }
| object_type { $1 }
/* AST Datatype */
primitive:
INT { Int_t }
| FLOAT { Float_t }
| CHAR { Char_t }
| BOOL { Bool_t }
| UNIT { Unit_t }
object_type:
TYPE_ID { Object_t($1) }
/* AST Arraytype */
array_type:
type_tag LBRACKET brackets RBRACKET { Arraytype($1, $3) }
brackets:
/* nothing */ { 1 }
| brackets RBRACKET LBRACKET { $1 + 1 }
/* AST Functiontype */
/* Type1->Type2 is shorthand for (Type1)->Type2 */
/* NOTE: ARROW is right-associative */
function_type:
LPAREN formal_dtypes_list RPAREN ARROW datatype { Functiontype($2, $5) }
| datatype ARROW datatype { Functiontype([$1], $3) }
/* Fields */
/* ------ */
field:
scope VAR ID COLON datatype SEMI { Field($1, $3, $5) }
/* Formals and Actuals */
/* ------------------- */
/* Formal Datatypes -- Nameless for Function Types */
formal_dtypes_list:
formal_dtype { [$1] }
| formal_dtypes_list COMMA formal_dtype { $3::$1 }
formal_dtype:
datatype { $1 }
/* Formals -- Names & Datatypes for Functions */
/* Returns (f, t), where f = list of formal and t = list of data_t */
formals_opt:
/* nothing */ { ([], []) }
| formal_list { (List.rev (fst $1), List.rev (snd $1)) }
formal_list:
formal { ([fst $1], [snd $1]) }
| formal_list COMMA formal { (fst $3 :: fst $1), (snd $3 :: snd $1) }
formal:
ID COLON datatype { (Formal($1, $3), $3) }
/* Actuals -- Exprs evaluated for Function Calls */
actuals_opt:
/* nothing */ { [] }
| actuals_list { List.rev $1 }
actuals_list:
expr { [$1] }
| actuals_list COMMA expr { $3::$1 }
/* Scope */
/* ----- */
scope:
/* nothing */ { Public }
| PUBLIC { Public }
| PRIVATE { Private }
/* Literals */
/* -------- */
literals:
INT_LIT { IntLit($1) }
| FLOAT_LIT { FloatLit($1) }
| TRUE { BoolLit(true) }
| FALSE { BoolLit(false) }
| CHAR_LIT { CharLit($1) }
| STRING_LIT { StringLit($1) }
| function_literal { $1 }
| ID { Id($1) }
| THIS { This }
function_literal:
ANON LPAREN formals_opt RPAREN COLON datatype LBRACE stmts RBRACE {
lambda_num := !lambda_num + 1;
FunctionLit({
fname = "@" ^ string_of_int !lambda_num;
ftype = Functiontype(snd $3, $6);
return_t = $6;
formals = fst $3;
body = $8;
scope = Private;
overrides = false;
root_cname = None;
})
}
bracket_args:
LBRACKET expr { [$2] }
| bracket_args RBRACKET LBRACKET expr { $4 :: $1 }
/* Statements */
/* ---------- */
stmts:
| stmt_list { List.rev $1 }
stmt_list:
stmt { [$1] }
| stmt_list stmt { $2::$1 }
stmt:
expr SEMI { Expr($1) }
| RETURN SEMI { Return(Noexpr) }
| RETURN expr SEMI { Return($2) }
| LBRACE stmts RBRACE { Block($2) }
| IF LPAREN expr RPAREN stmt ELSE stmt { If($3, $5, $7) }
| WHILE LPAREN expr RPAREN stmt { While($3, $5) }
| VAR ID COLON datatype SEMI { Local($2, $4, Noexpr) }
| VAR ID ASSIGN expr SEMI { Local($2, Any, $4) }
| VAR ID COLON datatype ASSIGN expr SEMI { Local($2, $4, $6) }
| IF LPAREN expr RPAREN stmt %prec NOELSE { If($3, $5, Block([])) }
| FOR LPAREN expr_opt SEMI expr SEMI expr_opt RPAREN stmt { For($3, $5, $7, $9) }
| BREAK SEMI { Break }
| CONTINUE SEMI { Continue }
/* Expressions */
/* ----------- */
expr_opt:
/* nothing */ { Noexpr }
| expr { $1 }
expr:
literals { $1 }
| expr INCREMENT { Binop($1, Add, IntLit(1)) }
| expr DECREMENT { Binop($1, Sub, IntLit(1)) }
| expr PLUS expr { Binop($1, Add, $3) }
| expr MINUS expr { Binop($1, Sub, $3) }
| expr TIMES expr { Binop($1, Mult, $3) }
| expr DIVIDE expr { Binop($1, Div, $3) }
| expr MODULO expr { Binop($1, Modulo, $3) }
| expr EQ expr { Binop($1, Equal, $3) }
| expr NEQ expr { Binop($1, Neq, $3) }
| expr LT expr { Binop($1, Less, $3) }
| expr LEQ expr { Binop($1, Leq, $3) }
| expr GT expr { Binop($1, Greater, $3) }
| expr GEQ expr { Binop($1, Geq, $3) }
| expr AND expr { Binop($1, And, $3) }
| expr OR expr { Binop($1, Or, $3) }
| expr ASSIGN expr { Assign($1, $3) }
| expr DOT expr { ObjAccess($1, $3) }
| expr bracket_args RBRACKET { ArrayAccess($1, List.rev $2) }
| MINUS expr %prec NEG { Unop(Neg, $2) }
| NOT expr { Unop(Not, $2) }
| LPAREN expr RPAREN { $2 }
| ID LPAREN actuals_opt RPAREN { Call($1, $3) }
| type_tag bracket_args RBRACKET LPAREN RPAREN { ArrayCreate (Datatype($1), List.rev $2) }
%%
ast.ml
type op = Add | Sub | Mult | Div | Modulo | And | Or |
Equal | Neq | Less | Leq | Greater | Geq
type uop = Neg | Not
type primitive = Int_t | Float_t | Bool_t | Char_t | Unit_t | Object_t of string
type scope = Private | Public
type extends = NoParent | Parent of string
type fdecl = {
fname : string;
ftype : datatype;
return_t : datatype;
formals : formal list;
body : stmt list;
scope : scope;
overrides : bool;
root_cname : string option;
}
and spec = {
sname : string;
}
and cbody = {
fields : field list;
methods : fdecl list;
}
and cdecl = {
cname : string;
extends : extends;
cbody: cbody;
}
and datatype =
Datatype of primitive
| Arraytype of primitive * int
| Functiontype of datatype list * datatype
| NoFunctiontype
| Any
and formal = Formal of string * datatype | Many of datatype
and field = Field of scope * string * datatype
and expr =
IntLit of int
| FloatLit of float
| BoolLit of bool
| CharLit of char
| StringLit of string
| FunctionLit of fdecl
| Id of string
| Binop of expr * op * expr
| Assign of expr * expr
| Unop of uop * expr
| Call of string * expr list
| ArrayAccess of expr * expr list
| ArrayCreate of datatype * expr list
| ObjAccess of expr * expr
| This
| Noexpr
and stmt =
Block of stmt list
| Expr of expr
| Return of expr
| Local of string * datatype * expr
| If of expr * stmt * stmt
| For of expr * expr * expr * stmt
| While of expr * stmt
| Break
| Continue
and var = Var of datatype * string
and include_stmt = Include of string
type constituents = {
includes : include_stmt list;
specs : spec list;
cdecls : cdecl list ;
fdecls : fdecl list;
}
type program = Program of include_stmt list * spec list * cdecl list * fdecl list
utils.ml
open Ast
open Parser
open Sast
open Core.Std
module E = Exceptions
let string_of_token = function
SEMI -> "SEMI"
| LPAREN -> "LPAREN"
| RPAREN -> "RPAREN"
| LBRACE -> "LBRACE"
| RBRACE -> "RBRACE"
| LBRACKET -> "LBRACKET"
| RBRACKET -> "RBRACKET"
| COMMA -> "COMMA"
| COLON -> "COLON"
| INCREMENT -> "INCREMENT"
| DECREMENT -> "DECREMENT"
| PLUS -> "PLUS"
| MINUS -> "MINUS"
| TIMES -> "TIMES"
| DIVIDE -> "DIVIDE"
| ASSIGN -> "ASSIGN"
| NOT -> "NOT"
| CARET -> "CARET"
| MODULO -> "MODULO"
| EQ -> "EQ"
| NEQ -> "NEQ"
| LT -> "LT"
| LEQ -> "LEQ"
| GT -> "GT"
| GEQ -> "GEQ"
| TRUE -> "TRUE"
| FALSE -> "FALSE"
| AND -> "AND"
| OR -> "OR"
| IF -> "IF"
| ELSE -> "ELSE"
| FOR -> "FOR"
| WHILE -> "WHILE"
| BREAK -> "BREAK"
| CONTINUE -> "CONTINUE"
| RETURN -> "RETURN"
| FINAL -> "FINAL"
| INCLUDE -> "INCLUDE"
| MODULE -> "MODULE"
| DOT -> "DOT"
| SPEC -> "SPEC"
| CLASS -> "CLASS"
| METHOD -> "METHOD"
| ARROW -> "ARROW"
| FATARROW -> "FATARROW"
| PUBLIC -> "PUBLIC"
| PRIVATE -> "PRIVATE"
| ANON -> "ANON"
| MATCH -> "MATCH"
| CASE -> "CASE"
| INT -> "INT"
| FLOAT -> "FLOAT"
| BOOL -> "BOOL"
| CHAR -> "CHAR"
| UNIT -> "UNIT"
| TYPE -> "TYPE"
| VAR -> "VAR"
| THIS -> "THIS"
| DEF -> "DEF"
| EXTENDS -> "EXTENDS"
| EOF -> "EOF"
| INT_LIT(_) -> "INT_LIT"
| FLOAT_LIT(_) -> "FLOAT_LIT"
| CHAR_LIT(_) -> "CHAR_LIT"
| STRING_LIT(_) -> "STRING_LIT"
| ID(_) -> "ID"
| TYPE_ID(_) -> "TYPE_ID"
let rec token_list_to_string = function
(token, _) :: tail ->
string_of_token token ^ " " ^
token_list_to_string tail
| [] -> "\n"
let error_string_of_file filename =
if filename = ""
then "Stdin"
else "File \"" ^ filename ^ "\""
let error_string_of_cnum cnum token =
string_of_int cnum ^ "~"
^ string_of_int (cnum + String.length (string_of_token token))
let string_of_op = function
Add -> "+"
| Sub -> "-"
| Mult -> "*"
| Div -> "/"
| Modulo -> "%"
| Ast.Equal -> "=="
| Neq -> "!="
| Ast.Less -> "<"
| Leq -> "<="
| Ast.Greater -> ">"
| Geq -> ">="
| And -> "&&"
| Or -> "||"
let string_of_uop = function
Neg -> "-"
| Not -> "!"
let string_of_primitive = function
Int_t -> "Int"
| Float_t -> "Float"
| Bool_t -> "Bool"
| Char_t -> "Char"
| Unit_t -> "Unit"
| Object_t(s) -> s
let rec print_brackets = function
1 -> "[]"
| i -> "[]" ^ print_brackets (i - 1)
let rec string_of_datatype = function
Datatype(p) -> string_of_primitive p
| Arraytype(p, i) -> string_of_primitive p ^ print_brackets i
| Functiontype(formal_dtypes, rtype) ->
"(" ^
String.concat ~sep:"," (List.map ~f:string_of_datatype formal_dtypes) ^ ")->" ^
string_of_datatype rtype
| Any -> "Any"
let string_of_scope = function
Public -> "public"
| Private -> "private"
let string_of_formal = function
Formal(s, data_t) -> s ^ ":" ^ string_of_datatype data_t
| Many(data_t) -> "Many :" ^ string_of_datatype data_t
let string_of_formal_name = function
Formal(s, _) -> s
| Many(_) -> "Many"
let string_of_field = function
Field(scope, s, data_t) ->
"\t" ^ string_of_scope scope ^ " " ^ s ^ ":"
^ string_of_datatype data_t ^ ";\n"
let prepend_tab f = fun s -> "\t" ^ f s
let rec string_of_method m =
"\t" ^ string_of_scope m.scope ^ " def " ^ m.fname ^ " = (" ^
String.concat ~sep:", " (List.map ~f:string_of_formal m.formals) ^
"):" ^ string_of_datatype m.return_t ^ "{\n" ^
String.concat ~sep:"" (List.map ~f:(prepend_tab string_of_stmt) m.body) ^
"\t}\n"
and string_of_fdecl f =
"function" ^ " " ^ f.fname ^ " = (" ^
String.concat ~sep:", " (List.map ~f:string_of_formal f.formals) ^
"):" ^ string_of_datatype f.return_t ^ "{\n" ^
String.concat ~sep:"" (List.map ~f:string_of_stmt f.body) ^
"}\n"
and string_of_expr = function
IntLit(i) -> string_of_int i
| FloatLit(f) -> string_of_float f
| BoolLit(true) -> "true"
| BoolLit(false) -> "false"
| CharLit(c) -> String.make 1 c
| StringLit(s) -> "\"" ^ s ^ "\""
| FunctionLit(f) ->
f.fname ^ "(" ^
String.concat ~sep:", " (List.map ~f:string_of_formal f.formals) ^ "):" ^
string_of_datatype f.return_t ^ "{\n" ^
String.concat ~sep:"" (List.map ~f:(prepend_tab string_of_stmt) f.body) ^
"\t}"
| Id(i) -> i
| Binop(e1, op, e2) ->
string_of_expr e1 ^ " " ^ string_of_op op ^ " " ^ string_of_expr e2
| Assign(e1, e2) -> string_of_expr e1 ^ " = " ^ string_of_expr e2
| Unop(op, e1) ->
string_of_uop op ^ " " ^ string_of_expr e1
| Call(s, e_l) -> s ^ "(" ^ String.concat ~sep:", " (List.map ~f:string_of_expr e_l) ^ ")"
| ObjAccess(e1, e2) -> string_of_expr e1 ^ "." ^ string_of_expr e2
| ArrayAccess(e, e_l) ->
string_of_expr e ^ "[" ^ String.concat ~sep:"][" (List.map ~f:string_of_expr e_l) ^ "]"
| ArrayCreate(d, e_l) ->
string_of_datatype d ^ "[" ^ String.concat ~sep:"][" (List.map ~f:string_of_expr e_l) ^ "]"
| This -> "this"
| Noexpr -> ""
and string_of_stmt = function
Block(stmts) ->
"{\n" ^ String.concat ~sep:"" (List.map ~f:string_of_stmt stmts) ^ "}\n"
| _ as stmt ->
prepend_tab string_of_stmt_helper stmt
and string_of_stmt_helper = function
Block(_) -> raise (E.UtilsError("Encountered Block in string_of_stmt helper"))
| Expr(expr) -> string_of_expr expr ^ ";\n"
| Return(expr) -> "return " ^ string_of_expr expr ^ ";\n"
| If(e, s, Block([])) -> "if (" ^ string_of_expr e ^ ")\n" ^ string_of_stmt s
| If(e, s1, s2) -> "if (" ^ string_of_expr e ^ ")\n" ^ string_of_stmt s1
^ "else\n" ^ string_of_stmt s2
| For(e1, e2, e3, s) -> "for (" ^ string_of_expr e1 ^ " ; " ^ string_of_expr e2 ^ " ; "
^ string_of_expr e3 ^ ") " ^ string_of_stmt s
| While(e, s) -> "while (" ^ string_of_expr e ^ ") " ^ string_of_stmt s
| Break -> "break;\n"
| Continue -> "continue;\n"
| Local(s, dtype, e) -> ( match e with
Noexpr -> "var " ^ s ^ ":" ^ string_of_datatype dtype ^ ";\n"
| _ -> "var " ^ s ^ ":" ^ string_of_datatype dtype ^ " = " ^ string_of_expr e ^ ";\n" )
let string_of_include = function
Include(s) -> "#include \"" ^ s ^ "\"\n"
let string_of_spec spec =
"spec " ^ spec.sname ^ " {\n" ^ "}\n"
let string_of_cdecl cdecl = match cdecl.extends with
NoParent ->
"class " ^ cdecl.cname ^ " {\n" ^
String.concat ~sep:"" (List.map ~f:string_of_field cdecl.cbody.fields) ^
String.concat ~sep:"" (List.map ~f:string_of_method cdecl.cbody.methods) ^
"}\n"
| Parent(s) ->
"class " ^ cdecl.cname ^ " extends " ^ s ^ " {\n" ^
String.concat ~sep:"" (List.map ~f:string_of_field cdecl.cbody.fields) ^
String.concat ~sep:"" (List.map ~f:string_of_method cdecl.cbody.methods) ^
"}\n"
let string_of_program = function
Program(includes, specs, cdecls, fdecls) ->
String.concat ~sep:"\n" (List.map ~f:string_of_include includes) ^ "\n" ^
String.concat ~sep:"\n" (List.map ~f:string_of_spec specs) ^ "\n" ^
String.concat ~sep:"\n" (List.map ~f:string_of_cdecl cdecls) ^ "\n" ^
String.concat ~sep:"\n" (List.map ~f:string_of_fdecl fdecls)
let rec string_of_bracket_sexpr = function
[] -> ""
| head :: tail -> "[" ^ (string_of_sexpr head) ^ "]" ^ (string_of_bracket_sexpr tail)
and string_of_sarray_primitive = function
[] -> ""
| [last] -> (string_of_sexpr last)
| head :: tail -> (string_of_sexpr head) ^ ", " ^ (string_of_sarray_primitive tail)
and string_of_sexpr = function
SIntLit(i) -> string_of_int i
| SFloatLit(f) -> string_of_float f
| SBoolLit(b) -> if b then "true" else "false"
| SCharLit(c) -> Char.escaped c
| SStringLit(s) -> "\"" ^ (String.escaped s) ^ "\""
| SFunctionLit(s, data_t) ->
s ^ ":" ^ string_of_datatype data_t
| SId(s, _) -> s
| SBinop(e1, o, e2, _) -> (string_of_sexpr e1) ^ " " ^ (string_of_op o) ^ " " ^ (string_of_sexpr e2)
| SUnop(op, e, _) -> (string_of_uop op) ^ "(" ^ string_of_sexpr e ^ ")"
| SAssign(e1, e2, _) -> (string_of_sexpr e1) ^ " = " ^ (string_of_sexpr e2)
| SObjAccess(e1, e2, data_t) ->
(string_of_sexpr e1) ^ "." ^ (string_of_sexpr e2) ^":"^ (string_of_datatype data_t)
| SCall(ss, el, _, _) -> string_of_sexpr ss ^ "(" ^ String.concat ~sep:", " (List.map ~f:string_of_sexpr el) ^ ")"
| SArrayAccess(se, se_l, _) ->
string_of_sexpr se ^ "[" ^ string_of_bracket_sexpr se_l ^ "]"
| SArrayCreate(d, se_l, _) ->
string_of_datatype d ^ "[" ^ string_of_bracket_sexpr se_l ^ "]"
| SNoexpr -> ""
| SThis(_) -> "this"
and string_of_local_sexpr = function
SNoexpr -> ""
| e -> " = " ^ string_of_sexpr e
and string_of_sstmt indent =
let indent_string = String.make indent '\t' in
let get_stmt_string = function
SBlock(stmts) ->
indent_string ^ "{\n" ^
String.concat ~sep:"" (List.map ~f:(string_of_sstmt (indent+1)) stmts) ^
indent_string ^ "}\n"
| SExpr(expr, data_t) ->
indent_string ^ string_of_sexpr expr ^":" ^ string_of_datatype data_t ^";\n";
| SReturn(expr, _) ->
indent_string ^ "return " ^ string_of_sexpr expr ^ ";\n";
| SIf(e, s, SBlock([SExpr(SNoexpr, _)])) ->
indent_string ^ "if (" ^ string_of_sexpr e ^ ")\n" ^
(string_of_sstmt (indent+1) s)
| SIf(e, s1, s2) ->
indent_string ^ "if (" ^ string_of_sexpr e ^ ")\n" ^
string_of_sstmt (indent+1) s1 ^
indent_string ^ "else\n" ^
string_of_sstmt (indent+1) s2
| SFor(e1, e2, e3, s) ->
indent_string ^ "for (" ^ string_of_sexpr e1 ^ " ; " ^
string_of_sexpr e2 ^ " ; " ^ string_of_sexpr e3 ^ ")\n" ^
string_of_sstmt (indent) s
| SWhile(e, s) ->
indent_string ^ "while (" ^ string_of_sexpr e ^ ")\n" ^
string_of_sstmt (indent) s
| SBreak ->
indent_string ^ "break;"
| SContinue ->
indent_string ^ "continue;"
| SLocal(s, d, e) ->
indent_string ^ s ^ ":" ^ string_of_datatype d ^
string_of_local_sexpr e ^ ";\n"
in
get_stmt_string
and string_of_sfdecl sfdecl =
"function" ^ " " ^ sfdecl.sfname ^ " = (" ^
String.concat ~sep:", " (List.map ~f:string_of_formal sfdecl.sformals) ^
"):" ^ string_of_datatype sfdecl.sreturn_t ^ " {\n" ^
string_of_sstmt 0 (SBlock(sfdecl.sbody)) ^
"}\n"
and string_of_scdecl scdecl =
"class " ^ scdecl.scname ^ " {\n" ^
String.concat ~sep:"" (List.map ~f:string_of_field scdecl.sfields) ^
String.concat ~sep:"" (List.map ~f:string_of_sfdecl scdecl.sfdecls) ^
"}\n"
and string_of_main main = match main with
Some(sfdecl) -> string_of_sfdecl sfdecl
| None -> ""
let string_of_sprogram sprogram =
String.concat ~sep:"\n" (List.map ~f:string_of_scdecl sprogram.classes) ^ "\n" ^
String.concat ~sep:"\n" (List.map ~f:string_of_sfdecl sprogram.functions) ^ "\n" ^
string_of_sfdecl sprogram.main ^ "\n"
sast.ml
open Ast
type fgroup = User | Reserved
type sfdecl = {
sfname : string;
sreturn_t : datatype;
srecord_vars : (string * datatype) list;
sformals : formal list;
sbody : sstmt list;
fgroup : fgroup;
overrides : bool;
source : string option;
sftype : datatype;
}
and scdecl = {
scname : string;
sfields : field list;
sfdecls : sfdecl list;
}
and sprogram = {
classes : scdecl list;
functions : sfdecl list;
main : sfdecl;
}
and sexpr =
SIntLit of int
| SFloatLit of float
| SBoolLit of bool
| SCharLit of char
| SStringLit of string
| SFunctionLit of string * datatype
| SId of string * datatype
| SUnop of uop * sexpr * datatype
| SBinop of sexpr * op * sexpr * datatype
| SAssign of sexpr * sexpr * datatype
| SCall of sexpr * sexpr list * datatype * int
| SObjAccess of sexpr * sexpr * datatype
| SArrayAccess of sexpr * sexpr list * datatype
| SArrayCreate of datatype * sexpr list * datatype
| SThis of datatype
| SNoexpr
and sstmt =
SBlock of sstmt list
| SExpr of sexpr * datatype
| SReturn of sexpr * datatype
| SIf of sexpr * sstmt * sstmt
| SFor of sexpr * sexpr * sexpr * sstmt
| SWhile of sexpr * sstmt
| SLocal of string * datatype * sexpr
| SBreak
| SContinue
scanner.mll
{
open Core.Std
open Parser
module E = Exceptions
let lineno = ref 1
let depth = ref 0
let filename = ref ""
let unescape s =
Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x)
}
let whitespace = [' ' '\t' '\r']
let alpha = ['a'-'z' 'A'-'Z']
let upper_alpha = ['A'-'Z']
let lower_alpha = ['a'-'z']
let digit = ['0'-'9']
let exp = (('e'|'E')('-'|'+')?digit+)
let ascii = [' '-'!' '#'-'[' ']'-'~']
let escape_char = '\\' ['\\' ''' '"' 'n' 'r' 't']
let int_lit = digit+ as lit
let float_lit = (digit+'.'digit*exp?)|(digit+'.'?digit*exp)
|(digit*'.'digit+exp?)|(digit*'.'?digit+exp) as lit
let char_lit = '''(ascii|digit as lit)'''
let escape_char_lit = '''(escape_char as lit)'''
let string_lit = '"'((ascii|escape_char)* as lit)'"'
let id = lower_alpha (alpha | digit | '_')* as lit
let typeid = upper_alpha (alpha | digit | '_')* as lit
rule token = parse
whitespace { token lexbuf }
| "//" { single_comment lexbuf }
| "/*" { incr depth; multi_comment lexbuf }
| '\n' { incr lineno; token lexbuf }
| '(' { LPAREN }
| ')' { RPAREN }
| '{' { LBRACE }
| '}' { RBRACE }
| '[' { LBRACKET }
| ']' { RBRACKET }
| ':' { COLON }
| ';' { SEMI }
| ',' { COMMA }
| '.' { DOT }
| "++" { INCREMENT }
| "--" { DECREMENT }
| '+' { PLUS }
| '-' { MINUS }
| '*' { TIMES }
| '/' { DIVIDE }
| '=' { ASSIGN }
| '^' { CARET }
| '%' { MODULO }
| "==" { EQ }
| "!=" { NEQ }
| '<' { LT }
| "<=" { LEQ }
| ">" { GT }
| ">=" { GEQ }
| "&&" { AND }
| "||" { OR }
| "!" { NOT }
| { ARROW }
| "=>" { FATARROW }
| "public" { PUBLIC }
| "private" { PRIVATE }
| '@' { ANON }
| "if" { IF }
| "else" { ELSE }
| "for" { FOR }
| "while" { WHILE }
| "break" { BREAK }
| "continue" { CONTINUE }
| "return" { RETURN }
| "spec" { SPEC }
| "class" { CLASS }
| "method" { METHOD }
| "def" { DEF }
| "var" { VAR }
| "type" { TYPE }
| "final" { FINAL }
| "this" { THIS }
| "extends" { EXTENDS }
| "match" { MATCH }
| "case" { CASE }
| "#include" { INCLUDE }
| "#module" { MODULE }
| "Int" { INT }
| "Float" { FLOAT }
| "Bool" { BOOL }
| "Char" { CHAR }
| "Unit" { UNIT }
| "true" { TRUE }
| "false" { FALSE }
| int_lit { INT_LIT(int_of_string lit) }
| float_lit { FLOAT_LIT(float_of_string lit) }
| char_lit { CHAR_LIT(lit) }
| escape_char_lit { CHAR_LIT(String.get (unescape lit) 0) }
| string_lit { STRING_LIT(unescape lit) }
| id { ID(lit) }
| typeid { TYPE_ID(lit) }
| eof { EOF }
| _ as illegal { raise (E.IllegalCharacter(!filename, (Char.escaped illegal), !lineno)) }
and single_comment = parse
'\n' { incr lineno; token lexbuf }
| _ { single_comment lexbuf }
and multi_comment = parse
'\n' { incr lineno; multi_comment lexbuf }
| "/*" { incr depth; multi_comment lexbuf }
| "*/" { decr depth; if !depth > 0 then multi_comment lexbuf
else token lexbuf }
| _ { multi_comment lexbuf }
generator.ml
open Parser
module E = Exceptions
type token_attr = {
lineno : int;
cnum : int;
}
let filename_ref = ref ""
let lineno_ref = ref 1
let cnum_ref = ref 1
let last_token_ref = ref EOF
let build_token_list filename lexbuf =
Scanner.filename := filename;
let rec helper lexbuf token_list =
let token = Scanner.token lexbuf in
let lineno = !Scanner.lineno in
let cnum = (Lexing.lexeme_start_p lexbuf).Lexing.pos_cnum in
match token with
EOF as eof -> (eof, { lineno = lineno; cnum = cnum }) :: token_list
| t -> (t, {lineno = lineno; cnum = cnum}) :: helper lexbuf token_list
in
helper lexbuf []
let build_ast filename token_list =
let token_list = ref(token_list) in
let tokenizer _ =
match !token_list with
(head, attr) :: tail ->
filename_ref := filename;
lineno_ref := attr.lineno;
cnum_ref := attr.cnum;
last_token_ref := head;
token_list := tail;
head
| [] -> raise E.MissingEOF
in
let program = Parser.program tokenizer (Lexing.from_string "") in
program
legacy_code.ml
let translate ast = match ast with
A.Program(includess, specs, classes, functions) ->
let context = L.global_context () in
let the_module = L.create_module context "Stop"
and i32_t = L.i32_type context
and i8_t = L.i8_type context
and i1_t = L.i1_type context
and str_t = L.pointer_type (L.i8_type context)
and void_t = L.void_type context in
let str_type = A.Arraytype(A.Char_t, 1) in
let ltype_of_prim = function
A.Int_t -> i32_t
| A.Float_t -> i32_t
| A.Bool_t -> i1_t
| A.Char_t -> i8_t
| A.Unit_t -> void_t
in
let rec ltype_of_arraytype arraytype = match arraytype with
A.Arraytype(p, 1) -> L.pointer_type (ltype_of_prim p)
| A.Arraytype(p, i) ->
L.pointer_type (ltype_of_arraytype (A.Arraytype(p, i-1)))
| _ -> raise(E.InvalidStructType "Array Pointer Type")
in
let ltype_of_datatype = function
A.Datatype(p) -> ltype_of_prim p
| A.Arraytype(p, i) -> ltype_of_arraytype (A.Arraytype(p,i)) in
let ltype_of_formal = function
A.Formal(data_t, s) -> ltype_of_datatype data_t in
let atype_of_datatype = function
A.Datatype(p) -> p
| A.Arraytype(p, i) -> p in
let printf_t = L.var_arg_function_type i32_t [| L.pointer_type i8_t |] in
let printf_func = L.declare_function "printf" printf_t the_module in
let function_decls =
let function_decl m fdecl =
let name = fdecl.A.fname
and formal_types =
Array.of_list (List.map (fun formal -> ltype_of_formal formal) fdecl.A.formals)
in let ftype = L.function_type (ltype_of_datatype fdecl.A.return_t) formal_types in
StringMap.add name (L.define_function name ftype the_module, fdecl) m in
List.fold_left function_decl StringMap.empty functions in
let build_function_body fdecl =
let (the_function, _) = StringMap.find fdecl.A.fname function_decls in
let builder = L.builder_at_end context (L.entry_block the_function) in
let int_format_str = L.build_global_stringptr "%d\n" "fmt" builder in
let rec expr builder = function
A.IntLit i -> L.const_int i32_t i
| A.FloatLit f -> L.const_float i32_t f
| A.BoolLit b -> L.const_int i1_t (if b then 1 else 0)
| A.CharLit c -> L.const_int i8_t (Char.code c)
| A.StringLit s -> L.build_global_stringptr s "tmp" builder
| A.Id s -> raise E.NotImplemented
| A.Binop (e1, op, e2) -> build_binop e1 op e2
| A.Unop(op, e) -> build_unop op e
| A.Call (, e) -> build_printf e
| A.Call (s, e) -> raise E.NotImplemented
| A.Noexpr -> L.const_int i32_t 0
and build_binop e1 op e2 =
let e1' = expr builder e1
and e2' = expr builder e2 in
(match op with
A.Add -> L.build_add
| A.Sub -> L.build_sub
| A.Mult -> L.build_mul
| A.Div -> L.build_sdiv
| A.And -> L.build_and
| A.Or -> L.build_or
| A.Equal -> L.build_icmp L.Icmp.Eq
| A.Neq -> L.build_icmp L.Icmp.Ne
| A.Less -> L.build_icmp L.Icmp.Slt
| A.Leq -> L.build_icmp L.Icmp.Sle
| A.Greater -> L.build_icmp L.Icmp.Sgt
| A.Geq -> L.build_icmp L.Icmp.Sge)
e1' e2' "tmp" builder
and build_unop op e =
let e' = expr builder e in
(match op with
A.Neg -> L.build_neg
| A.Not -> L.build_not)
e' "tmp" builder
and build_printf e =
let format_str = match e with
[] -> A.Noexpr
| hd :: tl -> hd
and args = match e with
[] -> []
| hd :: tl -> tl
in
let first_arg = match args with
[] -> A.Noexpr
| hd :: tl -> hd
in
let format_lstr = match format_str with
A.StringLit(s) -> L.build_global_stringptr s "fmt" builder
| _ -> raise E.PrintfFirstArgNotString
in
let l_format_args_list = List.map (expr builder) args
in
let l_full_args_list = [format_lstr] @ l_format_args_list
in
let l_args_arr = Array.of_list l_full_args_list
in
L.build_call printf_func l_args_arr "printf" builder
in
let add_terminal builder f =
match L.block_terminator (L.insertion_block builder) with
Some _ -> ()
| None -> ignore (f builder) in
let rec stmt builder = function
A.Block sl -> List.fold_left stmt builder sl
| A.Expr e -> ignore (expr builder e); builder
| A.Return e -> build_sreturn e
| A.If (predicate, then_stmt, else_stmt) -> build_sif predicate then_stmt else_stmt
| A.While(predicate, body) -> build_swhile predicate body
| A.For (e1, e2, e3, body) -> build_sfor e1 e2 e3 body
and build_sreturn e =
ignore (match fdecl.A.return_t with
A.Datatype(A.Unit_t) -> L.build_ret_void builder
| _ -> L.build_ret (expr builder e) builder
);
builder
and build_sif predicate then_stmt else_stmt =
let bool_val = expr builder predicate in
let merge_bb = L.append_block context "merge" the_function in
let then_bb = L.append_block context "then" the_function in
add_terminal (stmt (L.builder_at_end context then_bb) then_stmt)
(L.build_br merge_bb);
let else_bb = L.append_block context "else" the_function in
add_terminal (stmt (L.builder_at_end context else_bb) else_stmt)
(L.build_br merge_bb);
ignore (L.build_cond_br bool_val then_bb else_bb builder);
L.builder_at_end context merge_bb
and build_swhile predicate body =
let pred_bb = L.append_block context "while" the_function in
ignore (L.build_br pred_bb builder);
let body_bb = L.append_block context "while_body" the_function in
add_terminal (stmt (L.builder_at_end context body_bb) body)
(L.build_br pred_bb);
let pred_builder = L.builder_at_end context pred_bb in
let bool_val = expr pred_builder predicate in
let merge_bb = L.append_block context "merge" the_function in
ignore (L.build_cond_br bool_val body_bb merge_bb pred_builder);
L.builder_at_end context merge_bb
and build_sfor e1 e2 e3 body =
stmt builder (A.Block [A.Expr(e1); A.While(e2, A.Block [body; A.Expr(e3)])] )
in
let builder = stmt builder (A.Block fdecl.A.body) in
add_terminal builder (match fdecl.A.return_t with
A.Datatype(A.Unit_t) -> L.build_ret_void
| data_t -> L.build_ret (L.const_int (ltype_of_datatype data_t) 0)
)
in
List.iter build_function_body functions;
the_module
analysis.ml
open Core.Std
open Ast
open Sast
module E = Exceptions
module G = Generator
module U = Utils
module StringMap = Map.Make(String)
module StringSet = Set.Make(String)
let seed_index = ref 0;;
let string_of_list string_of_item l =
"[" ^ String.concat ~sep:", " (List.map ~f:string_of_item l) ^ "]"
let higher_order_sfdecls = ref StringMap.empty
let access_link_types:(string, datatype) Hashtbl.t = Hashtbl.create ()
~hashable:String.hashable
~size:10
let access_link_fnames:(string, string) Hashtbl.t = Hashtbl.create ()
~hashable:String.hashable
~size:10
type class_record = {
field_map : field StringMap.t;
method_map : fdecl StringMap.t;
cdecl : cdecl;
}
type env = {
env_cname : string option;
env_crecord : class_record option;
env_cmap : class_record StringMap.t;
env_fname : string option;
env_fmap : fdecl StringMap.t;
env_named_vars : datatype StringMap.t;
env_record_vars : datatype StringMap.t;
env_record_to_pass : (string * datatype) StringMap.t;
env_return_t : datatype;
env_in_for : bool;
env_in_while : bool;
}
let update_env_cname env_cname env =
{
env_cname = env_cname;
env_crecord = env.env_crecord;
env_cmap = env.env_cmap;
env_fname = env.env_fname;
env_fmap = env.env_fmap;
env_named_vars = env.env_named_vars;
env_record_vars = env.env_record_vars;
env_record_to_pass = env.env_record_to_pass;
env_return_t = env.env_return_t;
env_in_for = env.env_in_for;
env_in_while = env.env_in_while;
}
let update_call_stack in_for in_while env =
{
env_cname = env.env_cname;
env_crecord = env.env_crecord;
env_cmap = env.env_cmap;
env_fname = env.env_fname;
env_fmap = env.env_fmap;
env_named_vars = env.env_named_vars;
env_record_vars = env.env_record_vars;
env_record_to_pass = env.env_record_to_pass;
env_return_t = env.env_return_t;
env_in_for = in_for;
env_in_while = in_while;
}
let get_fname_exn fname_option = match fname_option with
Some(s) -> s
| None -> raise E.UnexpectedNoFname
let get_method_name cname fdecl =
let name = fdecl.fname in
cname ^ "." ^ name
let build_reserved_map =
let reserved_stub fname return_t formals =
{
sfname = fname;
sreturn_t = return_t;
sformals = formals;
srecord_vars = [];
sbody = [];
fgroup = Sast.Reserved;
overrides = false;
source = None;
sftype = NoFunctiontype;
}
in
let i32_t = Datatype(Int_t) in
let void_t = Datatype(Unit_t) in
let str_t = Arraytype(Char_t, 1) in
let f s data_t = Formal(s, data_t) in
let reserved_list = [
reserved_stub "printf" void_t [Many(Any)];
reserved_stub "malloc" str_t [f "size" i32_t ];
reserved_stub "cast" Any [f "in" Any];
reserved_stub "sizeof" i32_t [f "in" Any];
reserved_stub "open" i32_t [f "path" str_t; f "flags" i32_t];
reserved_stub "close" i32_t [f "fd" i32_t];
reserved_stub "read" i32_t [f "fd" i32_t; f "buf" str_t; f "nbyte" i32_t];
reserved_stub "write" i32_t [f "fd" i32_t; f "buf" str_t; f "nbyte" i32_t];
reserved_stub "lseek" i32_t [f "fd" i32_t; f "offset" i32_t; f "whence" i32_t];
reserved_stub "exit" (void_t) ([f "status" i32_t]);
reserved_stub "getchar" (i32_t) ([]);
reserved_stub "input" (str_t) ([]);
]
in
let reserved_map =
List.fold_left reserved_list
~init:StringMap.empty
~f:(fun m f -> StringMap.add m ~key:f.sfname ~data:f)
in
reserved_map
let rec expr_to_sexpr e env = match e with
IntLit(i) -> (SIntLit(i), env)
| FloatLit(b) -> (SFloatLit(b), env)
| BoolLit(b) -> (SBoolLit(b), env)
| CharLit(c) -> (SCharLit(c), env)
| StringLit(s) -> (SStringLit(s), env)
| Id(s) -> (check_record_access s env, env)
| Noexpr -> (SNoexpr, env)
| Unop(op, e) -> (check_unop op e env, env)
| Binop(e1, op, e2) -> (check_binop e1 op e2 env, env)
| Assign(e1, e2) -> (check_assign e1 e2 env, env)
| Call(s, e_l) -> (check_call s e_l env, env)
| ArrayAccess(e, e_l) -> (check_array_access e e_l env, env)
| ArrayCreate(d, e_l) -> (check_array_create d e_l env, env)
| FunctionLit(f) -> (check_function_literal f env, env)
| ObjAccess(e1, e2) -> (check_obj_access e1 e2 env, env)
and get_equality_binop_type se1 op se2 =
let type1 = sexpr_to_type_exn se1 in
let type2 = sexpr_to_type_exn se2 in
match (type1, type2) with
(Datatype(Char_t), Datatype(Int_t))
| (Datatype(Int_t), Datatype(Char_t)) ->
SBinop(se1, op, se2, Datatype(Bool_t))
| _ ->
if type1 = type2
then SBinop(se1, op, se2, Datatype(Bool_t))
else
let type1 = U.string_of_datatype type1 in
let type2 = U.string_of_datatype type2 in
raise (E.InvalidEqualityBinop(type1, type2))
and get_logical_binop_type se1 op se2 =
let type1 = sexpr_to_type_exn se1 in
let type2 = sexpr_to_type_exn se2 in
let operable = Set.of_list [Datatype(Int_t); Datatype(Char_t); Datatype(Bool_t)]
~comparator: Comparator.Poly.comparator
in
if Set.mem operable type1 && Set.mem operable type2
then SBinop(se1, op, se2, Datatype(Bool_t))
else raise E.InvalidBinaryOperation
and get_comparison_binop_type se1 op se2 =
let type1 = sexpr_to_type_exn se1 in
let type2 = sexpr_to_type_exn se2 in
let numerics = Set.of_list [Datatype(Int_t); Datatype(Float_t); Datatype(Char_t)]
~comparator: Comparator.Poly.comparator
in
if Set.mem numerics type1 && Set.mem numerics type2
then SBinop(se1, op, se2, Datatype(Bool_t))
else raise E.InvalidBinaryOperation
and get_arithmetic_binop_type se1 op se2 =
let type1 = sexpr_to_type_exn se1 in
let type2 = sexpr_to_type_exn se2 in
match (type1, type2) with
(Datatype(Int_t), Datatype(Int_t)) -> SBinop(se1, op, se2, Datatype(Int_t))
| (Datatype(Float_t), Datatype (Float_t)) -> SBinop(se1, op, se2, Datatype(Float_t))
| _ -> raise E.InvalidBinaryOperation
and get_Id_type s env =
try StringMap.find_exn env.env_named_vars s
with | Not_found ->
raise (E.UndefinedId s)
and get_this_type env = match env.env_cname with
Some(cname) -> Datatype(Object_t(cname))
| None -> raise E.ThisUsedOutsideClass
and check_unop op e env =
let check_num_unop op data_t = match op with
Neg -> data_t
| _ -> raise E.InvalidUnaryOperation
in
let check_bool_unop op = match op with
Not -> Datatype(Bool_t)
| _ -> raise E.InvalidUnaryOperation
in
let (se, env) = expr_to_sexpr e env in
let data_t = sexpr_to_type_exn se in
match data_t with
Datatype(Int_t)
| Datatype(Float_t)
| Datatype(Char_t) -> SUnop(op, se, check_num_unop op data_t)
| Datatype(Bool_t) -> SUnop(op, se, check_bool_unop op)
| _ -> raise E.InvalidUnaryOperation
and check_binop e1 op e2 env =
let (se1, _) = expr_to_sexpr e1 env in
let (se2, _) = expr_to_sexpr e2 env in
match op with
Equal
| Neq -> get_equality_binop_type se1 op se2
| And
| Or -> get_logical_binop_type se1 op se2
| Less
| Leq
| Greater
| Geq -> get_comparison_binop_type se1 op se2
| Add
| Mult
| Sub
| Div
| Modulo -> get_arithmetic_binop_type se1 op se2
| _ -> raise E.InvalidBinaryOperation
and check_assign e1 e2 env =
let (se1, _) = expr_to_sexpr e1 env in
let (se2, _) = expr_to_sexpr e2 env in
let type1 = sexpr_to_type_exn se1 in
let type2 = sexpr_to_type_exn se2 in
match (type1, type2) with
_ -> if type1 = type2
then SAssign(se1, se2, type1)
else
let str1 = U.string_of_datatype type1 in
let str2 = U.string_of_datatype type2 in
raise (E.AssignmentTypeMismatch(str1, str2))
and check_call s e_l env =
let se_l = expr_list_to_sexpr_list e_l env in
let record_to_pass = StringMap.find env.env_record_to_pass s in
let se_l = match record_to_pass with
Some(tuple) ->
let record_name = fst tuple in
let record_type = snd tuple in
let se = SId(record_name, record_type) in
se :: se_l
| None -> se_l
in
try
let fdecl = StringMap.find_exn env.env_fmap s in
let return_t = fdecl.return_t in
let sid = SId(s, fdecl.ftype) in
SCall(sid, se_l, return_t, 0)
with | Not_found ->
try
let rhs_type = StringMap.find_exn env.env_named_vars s in
let return_t = match rhs_type with
Functiontype(_, return_t) -> return_t
| data_t ->
let data_t = U.string_of_datatype data_t in
raise (E.CallFailedOnType data_t)
in
let env_fname = get_fname_exn env.env_fname in
let record_type = Datatype(Object_t(env_fname ^ ".record")) in
let record_type_name = env_fname ^ ".record" in
let record_name = env_fname ^ "_record" in
let record_class = StringMap.find_exn env.env_cmap record_type_name in
let lhs = SId(record_name, record_type) in
let rhs = SId(s, rhs_type) in
let sstmt = SObjAccess(lhs, rhs, rhs_type) in
SCall(sstmt, se_l, return_t, 0)
with | Not_found -> raise (E.UndefinedFunction s)
and expr_list_to_sexpr_list e_l env = match e_l with
hd :: tl ->
let (se, env) = expr_to_sexpr hd env in
se :: expr_list_to_sexpr_list tl env
| [] -> []
and check_array_access e e_l env =
let (se, _) = expr_to_sexpr e env in
let data_t = sexpr_to_type_exn se in
let se_l = expr_list_to_sexpr_list e_l env in
let check_access_params = List.map se_l
~f:(fun se -> match (sexpr_to_type_exn se) with
Datatype(Int_t) -> ()
| _ -> raise (E.ArrayAccess "Passed non-Int Indice Argument"))
in
let arr_num_indices = List.length e_l in
let arr_num_dims = match data_t with
Arraytype(_, n) -> n
| _ -> raise (E.ArrayAccess "Passed non-Arraytype Variable")
in
let check_num_dims_indices = if arr_num_dims <> arr_num_indices
then raise (E.ArrayAccess "Number Indices != Number Dimensions")
in
SArrayAccess(se, se_l, data_t)
and check_array_create d e_l env =
let se_l = expr_list_to_sexpr_list e_l env in
let check_access_params = List.map se_l
~f:(fun se -> match (sexpr_to_type_exn se) with
Datatype(Int_t) -> ()
| _ -> raise (E.NonIntegerArraySize))
in
let arr_num_indices = List.length e_l in
let convert_d_to_arraytype = function
Datatype(x) -> Arraytype(x, arr_num_indices)
| _ -> raise (E.NonArrayTypeCreate)
in
let sexpr_type = convert_d_to_arraytype d in
SArrayCreate(d, se_l, sexpr_type)
and check_function_literal fdecl env =
let f = StringMap.find_exn env.env_fmap (get_fname_exn env.env_fname) in
let link_type = Some(Datatype(Object_t(f.fname ^ ".record"))) in
let sfdecl = convert_fdecl_to_sfdecl env.env_fmap env.env_cmap fdecl env.env_named_vars link_type env.env_record_to_pass in
higher_order_sfdecls := StringMap.add !higher_order_sfdecls ~key:fdecl.fname ~data:sfdecl;
SFunctionLit(sfdecl.sfname, sfdecl.sftype)
and check_obj_access e1 e2 env =
let get_cname_exn = function
Some(cname) -> cname
| None -> raise E.CannotUseThisKeywordOutsideOfClass
in
let check_lhs = function
This -> SId("this", Datatype(Object_t(get_cname_exn env.env_cname)))
| Id(s) -> check_record_access s env
| _ as e -> raise E.LHSofObjectAccessMustBeAccessible
in
let check_rhs e2 =
let id = match e2 with
Id s -> s
| _ -> raise E.RHSofObjectAccessMustBeAccessible
in
let cname = match (check_lhs e1) with
SId(_, data_t) -> (match data_t with
Datatype(Object_t(name)) -> name)
| SObjAccess(_, _, data_t) -> (match data_t with
Datatype(Object_t(name)) -> name)
| _ -> raise E.RHSofObjectAccessMustBeAccessible
in
let crecord = StringMap.find_exn env.env_cmap cname in
try
match StringMap.find_exn crecord.field_map id with
Field(_, s, data_t) -> SId(s, data_t)
with | Not_found -> raise E.UnknownClassVar
in
let lhs = check_lhs e1 in
let lhs_type = sexpr_to_type_exn lhs in
let rhs = check_rhs e2 in
let rhs_t = match rhs with
SId(_, data_t) -> data_t
in
SObjAccess(lhs, rhs, rhs_t)
and check_record_access s env =
let fname = get_fname_exn env.env_fname in
let rec build_lhs_helper fname inner =
let record_type_name = fname ^ ".record" in
let record_class = StringMap.find_exn env.env_cmap record_type_name in
if StringMap.mem record_class.field_map s then
inner
else
let access_link_name = fname ^ "_@link" in
let access_link_type = Hashtbl.find_exn access_link_types fname in
let outer_fname = Hashtbl.find_exn access_link_fnames fname in
let inner = SObjAccess(inner, SId(access_link_name, access_link_type), access_link_type) in
build_lhs_helper outer_fname inner
in
let build_lhs fname =
let record_name = fname ^ "_record" in
let record_type_name = fname ^ ".record" in
let record_class = StringMap.find_exn env.env_cmap record_type_name in
let record_type = Datatype(Object_t(record_type_name)) in
try
let _ = StringMap.find_exn record_class.field_map s in
let result = SId(record_name, record_type) in
result
with | Not_found ->
let access_link_name = fname ^ "_@link" in
let access_link_type = Hashtbl.find_exn access_link_types fname in
let outer_fname = Hashtbl.find_exn access_link_fnames fname in
build_lhs_helper outer_fname
(SObjAccess(SId(record_name, record_type), SId(access_link_name, access_link_type), access_link_type))
in
let lhs = build_lhs fname in
let rhs_type = StringMap.find_exn env.env_named_vars s in
let rhs = SId(s, rhs_type) in
SObjAccess(lhs, rhs, rhs_type)
and arraytype_to_access_type data_t = match data_t with
Arraytype(p, _) -> Datatype(p)
| _ -> raise E.UnexpectedType
and sexpr_to_type sexpr = match sexpr with
SIntLit(_) -> Some(Datatype(Int_t))
| SFloatLit(_) -> Some(Datatype(Float_t))
| SBoolLit(_) -> Some(Datatype(Bool_t))
| SCharLit(_) -> Some(Datatype(Char_t))
| SStringLit(_) -> Some(Arraytype(Char_t, 1))
| SFunctionLit(_, data_t) -> Some(data_t)
| SId(_, data_t) -> Some(data_t)
| SBinop(_, _, _, data_t) -> Some(data_t)
| SUnop(_, _, data_t) -> Some(data_t)
| SCall(_, _, data_t, _) -> Some(data_t)
| SObjAccess(_, _, data_t) -> Some(data_t)
| SAssign(_, _, data_t) -> Some(data_t)
| SArrayAccess(_, _, data_t) -> Some(arraytype_to_access_type data_t)
| SArrayCreate(_, _, data_t) -> Some(data_t)
| SThis(data_t) -> Some(data_t)
| SNoexpr -> None
and sexpr_to_type_exn sexpr = match (sexpr_to_type sexpr) with
Some(t) -> t
| None -> raise E.UnexpectedNoexpr
and check_sblock sl env = match sl with
[] -> ([SBlock([SExpr(SNoexpr, Datatype(Unit_t))])], env)
| _ -> let (sl,_) = convert_stmt_list_to_sstmt_list sl env in
([SBlock(sl)], env)
and check_expr_stmt e env =
let se, env = expr_to_sexpr e env in
let data_t = sexpr_to_type_exn se in
([SExpr(se, data_t)], env)
and check_return e env =
let (se, _) = expr_to_sexpr e env in
let data_t = sexpr_to_type_exn se in
match data_t, env.env_return_t with
(* TODO: See if this makes sense for Unit_t... *)
Datatype(Unit_t), Datatype(Object_t(_))
| Datatype(Unit_t), Arraytype(_, _) -> ([SReturn(se, data_t)], env)
| _ ->
if data_t = env.env_return_t
then ([SReturn(se, data_t)], env)
else raise (E.ReturnTypeMismatch
(U.string_of_datatype data_t,
U.string_of_datatype env.env_return_t,
env.env_fname))
and local_handler s data_t e env =
if StringMap.mem env.env_named_vars s
then raise (E.DuplicateVar(s))
else
let (se, _) = expr_to_sexpr e env in
if se = SNoexpr then
let named_vars = StringMap.add env.env_named_vars
~key:s
~data:data_t;
in
let record_vars = StringMap.add env.env_record_vars
~key:s
~data:data_t;
in
let new_env = {
env_cname = env.env_cname;
env_crecord = env.env_crecord;
env_cmap = env.env_cmap;
env_fname = env.env_fname;
env_fmap = env.env_fmap;
env_named_vars = named_vars;
env_record_vars = record_vars;
env_record_to_pass = env.env_record_to_pass;
env_return_t = env.env_return_t;
env_in_for = env.env_in_for;
env_in_while = env.env_in_while;
}
in
let save_obj_with_storage =
let var_name = ".tmp_malloc_var"^ (string_of_int !seed_index) in
let var_type = data_t in
let sstmt_l = [SLocal(var_name, var_type, SNoexpr)] in
let sstmt_id = SId(var_name, var_type) in
let sstmt_record_var = check_record_access s new_env in
let sexpr = SAssign(sstmt_record_var, sstmt_id, var_type) in
let sstmt_l = SExpr(sexpr, var_type) :: sstmt_l in
(List.rev sstmt_l, new_env)
in
seed_index := !seed_index + 1;
match data_t with
Datatype(Object_t(_)) -> save_obj_with_storage
| _ -> ([SExpr(SNoexpr, Datatype(Unit_t))], new_env)
else
let se_data_t = sexpr_to_type_exn se in
let is_assignable = function
NoFunctiontype
| Any -> false
| _ -> true
in
let valid_assignment = function
(Any, _) -> is_assignable se_data_t
| (data_t, se_data_t) -> if data_t = se_data_t
then true else false
in
if valid_assignment (data_t, se_data_t)
then
let named_vars = StringMap.add env.env_named_vars
~key:s
~data:se_data_t;
in
let record_vars = StringMap.add env.env_record_vars
~key:s
~data:se_data_t;
in
let record_to_pass = match se with
SFunctionLit(_,_) ->
let data = (get_fname_exn env.env_fname ^ "_record", Datatype(Object_t(get_fname_exn env.env_fname ^ ".record"))) in
StringMap.add env.env_record_to_pass
~key:s
~data:data
| _ -> env.env_record_to_pass
in
let new_env = {
env_cname = env.env_cname;
env_crecord = env.env_crecord;
env_cmap = env.env_cmap;
env_fname = env.env_fname;
env_fmap = env.env_fmap;
env_named_vars = named_vars;
env_record_vars = record_vars;
env_record_to_pass = record_to_pass;
env_return_t = env.env_return_t;
env_in_for = env.env_in_for;
env_in_while = env.env_in_while;
}
in
let save_object_no_storage =
let lhs = check_record_access s new_env in
let sexpr = SAssign(lhs, se, se_data_t) in
let sstmt = SExpr(sexpr, se_data_t) in
([sstmt], new_env)
in
save_object_no_storage
else
let type1 = U.string_of_datatype data_t in
let type2 = U.string_of_datatype se_data_t in
raise (E.LocalAssignmentTypeMismatch(type1, type2))
and parse_stmt stmt env = match stmt with
Block sl -> check_sblock sl env
| Expr e -> check_expr_stmt e env
| Return e -> check_return e env
| Local(s, data_t, e) -> local_handler s data_t e env
| If(e, s1, s2) -> check_if e s1 s2 env
| For(e1, e2, e3, s) -> check_for e1 e2 e3 s env
| While(e, s) -> check_while e s env
| Break -> check_break env
| Continue -> check_continue env
and convert_stmt_list_to_sstmt_list sl env =
let env_ref = ref(env) in
let rec iter = function
head :: tail ->
let (a_head, env) = parse_stmt head !env_ref in
env_ref := env;
a_head @ (iter tail)
| [] -> []
in
let sstmt_list = ((iter sl), !env_ref) in
sstmt_list
and check_if e s1 s2 env =
let (se, _) = expr_to_sexpr e env in
let t = sexpr_to_type_exn se in
let (ifbody, _) = parse_stmt s1 env in
let (elsebody, _) = parse_stmt s2 env in
if t = Datatype(Bool_t)
then ([SIf(se, SBlock(ifbody), SBlock(elsebody))], env)
else raise E.InvalidIfStatementType
and check_for e1 e2 e3 s env =
let old_in_for = env.env_in_for in
let env = update_call_stack true env.env_in_while env in
let (se1,_) = expr_to_sexpr e1 env in
let (se2,_) = expr_to_sexpr e2 env in
let (se3,_) = expr_to_sexpr e3 env in
let (sbody,_) = parse_stmt s env in
let conditional_t = sexpr_to_type_exn se2 in
let sfor =
if conditional_t = Datatype(Bool_t)
then SFor(se1, se2, se3, SBlock(sbody))
else raise E.InvalidForStatementType
in
let env = update_call_stack old_in_for env.env_in_while env in
([sfor], env)
and check_while e s env =
let old_in_while = env.env_in_while in
let env = update_call_stack env.env_in_for true env in
let (se,_) = expr_to_sexpr e env in
let conditional_t = sexpr_to_type_exn se in
let (sbody,_) = parse_stmt s env in
let swhile =
if conditional_t = Datatype(Bool_t)
then SWhile(se, SBlock(sbody))
else raise E.InvalidWhileStatementType
in
let env = update_call_stack env.env_in_for old_in_while env in
([swhile], env)
and check_break env =
if env.env_in_for || env.env_in_while then
([SBreak], env)
else raise E.BreakOutsideOfLoop
and check_continue env =
if env.env_in_for || env.env_in_while then
([SContinue], env)
else raise E.ContinueOustideOfLoop
and build_crecord_map fmap cdecls fdecls =
let helper m (cdecl : Ast.cdecl) =
let check_fields m field = match field with
Field(scope, s, data_t) ->
if StringMap.mem m s then raise (E.DuplicateField s)
else StringMap.add m ~key:s ~data:(Field(scope, s, data_t))
in
let method_name = get_method_name cdecl.cname in
let check_methods m fdecl =
if StringMap.mem m (method_name fdecl)
then raise (E.DuplicateFunctionName (method_name fdecl))
else if (StringMap.mem fmap fdecl.fname)
then raise (E.FunctionNameReserved fdecl.fname)
else StringMap.add m ~key:(method_name fdecl) ~data:fdecl
in
if (StringMap.mem m cdecl.cname) then raise (E.DuplicateClassName(cdecl.cname))
else StringMap.add m
~key:cdecl.cname
~data:({
field_map = List.fold_left cdecl.cbody.fields
~f:check_fields
~init:StringMap.empty;
method_map = List.fold_left cdecl.cbody.methods
~f:check_methods
~init:StringMap.empty;
cdecl = cdecl
})
in
let crecord_map = List.fold_left cdecls
~f:helper
~init:StringMap.empty
in
let discover_named_vars fdecl =
let field_map = List.fold fdecl.formals
~f:(fun m formal -> match formal with
Formal(s, d) -> (StringMap.add m ~key:s ~data:(Field(Public, s, d))))
~init:StringMap.empty
in
let helper stmt = match stmt with
Local(s, d, _) -> Some(s, Field(Public, s, d))
| _ -> None
in
List.fold fdecl.body
~f:(fun m stmt -> match (helper stmt) with
Some(t) -> StringMap.add m ~key:(fst t) ~data:(snd t)
| None -> m)
~init:field_map
in
let fhelper m (fdecl : Ast.fdecl) =
let field_map = discover_named_vars fdecl in
let field_map =
try
let link_type = Hashtbl.find_exn access_link_types fdecl.fname in
let link_name = fdecl.fname ^ "_@link" in
let field = Field(Public, link_name, link_type) in
StringMap.add field_map ~key:link_name ~data:field
with | Not_found -> field_map
in
let temp_class = ({
field_map = field_map;
method_map = StringMap.empty;
cdecl = ({
cname = fdecl.fname ^ ".record";
extends = NoParent;
cbody = ({ fields = []; methods = []; })
})
})
in
StringMap.add m
~key:(fdecl.fname ^ ".record")
~data:temp_class
in
List.fold_left fdecls
~f:fhelper
~init:crecord_map
and build_fdecl_map reserved_sfdecl_map first_order_fdecls =
let check_functions m fdecl =
if StringMap.mem m fdecl.fname
then raise (E.DuplicateFunctionName fdecl.fname)
else if StringMap.mem reserved_sfdecl_map fdecl.fname
then raise (E.FunctionNameReserved fdecl.fname)
else StringMap.add m ~key:(fdecl.fname) ~data:fdecl
in
let map = List.fold_left first_order_fdecls
~f:check_functions
~init:StringMap.empty;
in
let rec discover_higher_order l fdecl =
let check_higher_order_helper l stmt = match stmt with
Local(_, _, e) -> (match e with
FunctionLit(nested_fdecl) ->
let link_t = Datatype(Object_t(fdecl.fname ^ ".record")) in
Hashtbl.add_exn access_link_types
~key:nested_fdecl.fname
~data:link_t;
Hashtbl.add_exn access_link_fnames
~key:nested_fdecl.fname
~data:fdecl.fname;
nested_fdecl :: discover_higher_order l nested_fdecl
| _ -> l)
| _ -> l
in
List.fold_left fdecl.body
~f:check_higher_order_helper
~init:l
in
let higher_order_fdecls = List.fold_left first_order_fdecls
~f:discover_higher_order
~init:[]
in
let map = List.fold_left higher_order_fdecls
~f:check_functions
~init:map;
in
let add_reserved_fdecls m key =
let sfdecl = StringMap.find_exn reserved_sfdecl_map key in
let fdecl = {
fname = key;
ftype = sfdecl.sftype;
return_t = sfdecl.sreturn_t;
formals = sfdecl.sformals;
body = [];
scope = Public;
overrides = false;
root_cname = None;
}
in
StringMap.add m ~key:key ~data:fdecl
in
let fdecl_map = List.fold_left (StringMap.keys reserved_sfdecl_map)
~f:add_reserved_fdecls
~init:map
in
let fdecls_to_generate = first_order_fdecls @ higher_order_fdecls
in
(fdecl_map, fdecls_to_generate, first_order_fdecls, higher_order_fdecls)
and convert_method_to_sfdecl fmap cmap cname fdecl =
let crecord = StringMap.find_exn cmap cname
in
let root_cname = match fdecl.root_cname with
Some(c) -> c
| None -> cname
in
let class_formal =
if fdecl.overrides then
Ast.Formal("this", Datatype(Object_t(root_cname)))
else
Ast.Formal("this", Datatype(Object_t(cname)))
in
let env_param_helper m formal = match formal with
Formal(s, data_t) -> (StringMap.add m ~key:s ~data:formal)
| _ -> m
in
let env_params = List.fold_left (class_formal :: fdecl.formals)
~f:env_param_helper
~init:StringMap.empty
in
let env = {
env_cname = Some(cname);
env_crecord = Some(crecord);
env_cmap = cmap;
env_fname = None;
env_fmap = fmap;
env_named_vars = StringMap.empty;
env_record_vars = StringMap.empty;
env_record_to_pass = StringMap.empty;
env_return_t = fdecl.return_t;
env_in_for = false;
env_in_while = false;
}
in
let fname = get_method_name cname fdecl
in
let fdecl_formals = class_formal :: fdecl.formals
in
let (fbody, env) = convert_stmt_list_to_sstmt_list fdecl.body env
in
let record_vars = StringMap.fold env.env_record_vars
~f:(fun ~key:k ~data:data_t l -> (k,data_t) :: l)
~init:[]
in
{
sfname = fname;
sreturn_t = fdecl.return_t;
srecord_vars = record_vars;
sformals = fdecl_formals;
sbody = fbody;
fgroup = Sast.User;
overrides = fdecl.overrides;
source = Some(cname);
sftype = fdecl.ftype;
}
and convert_fdecl_to_sfdecl fmap cmap fdecl named_vars link_type record_to_pass =
let sformals = match link_type with
Some(t) -> let access_link = Formal(fdecl.fname ^ "_@link", t) in access_link :: fdecl.formals
| None -> fdecl.formals
in
let env_param_helper m formal = match formal with
Formal(s, data_t) ->
if StringMap.mem named_vars s
then raise (E.DuplicateVar s)
else StringMap.add m ~key:s ~data:data_t
| _ -> m
in
let named_vars = List.fold_left sformals
~f:env_param_helper
~init:named_vars
in
let record_vars = List.fold_left sformals
~f:env_param_helper
~init:StringMap.empty
in
let env = {
env_cname = None;
env_crecord = None;
env_cmap = cmap;
env_fname = Some(fdecl.fname);
env_fmap = fmap;
env_named_vars = named_vars;
env_record_vars = record_vars;
env_record_to_pass = record_to_pass;
env_return_t = fdecl.return_t;
env_in_for = false;
env_in_while = false;
}
in
let (sfbody, env) = convert_stmt_list_to_sstmt_list fdecl.body env
in
let record_vars = StringMap.fold env.env_record_vars
~f:(fun ~key:k ~data:data_t l -> (k,data_t) :: l)
~init:[]
in
let srecord_vars = match link_type with
Some(t) -> let access_link = (fdecl.fname ^ "_@link", t) in access_link :: record_vars
| None -> record_vars
in
let field_helper l f = match f with
Formal(s, data_t) ->
let sstmt_id = SId(s, data_t) in
let sstmt_record_var = check_record_access s env in
let sexpr = SAssign(sstmt_record_var, sstmt_id, data_t) in
SExpr(sexpr, data_t) :: l
| _ -> l
in
let sfbody = List.fold_left sformals
~f:field_helper
~init:sfbody
in
let record_type = Datatype(Object_t(fdecl.fname ^ ".record")) in
let record_name = fdecl.fname ^ "_record" in
let sfbody = SLocal(record_name, record_type, SNoexpr) :: sfbody in
let sftype = match link_type with
Some(t) -> (match fdecl.ftype with
Functiontype(dt_l, dt) -> Functiontype(t :: dt_l, dt)
| _ -> raise E.FTypeMustBeFunctiontype)
| None -> fdecl.ftype
in
{
sfname = fdecl.fname;
sreturn_t = fdecl.return_t;
srecord_vars = record_vars;
sformals = sformals;
sbody = sfbody;
fgroup = Sast.User;
overrides = fdecl.overrides;
source = None;
sftype = sftype;
}
let generate_sfdecl_records sfdecl =
let fields = List.map sfdecl.srecord_vars
~f:(function (s, data_t) -> Field(Public, s, data_t))
in
{
scname = sfdecl.sfname ^ ".record";
sfields = fields;
sfdecls = [];
}
let convert_cdecl_to_scdecl sfdecls (c:Ast.cdecl) =
{
scname = c.cname;
sfields = c.cbody.fields;
sfdecls = sfdecls;
}
let convert_ast_to_sast
crecord_map (cdecls : cdecl list)
fdecl_map (first_order_fdecls : fdecl list) (higher_order_fdecls : fdecl list) =
let is_main = (fun f -> match f.sfname with s -> s = "main") in
let get_main fdecls =
let mains = (List.filter ~f:is_main fdecls)
in
if List.length mains < 1 then
raise E.MissingMainFunction
else if List.length mains > 1 then
raise E.MultipleMainFunctions
else
List.hd_exn mains
in
let remove_main fdecls =
List.filter ~f:(fun f -> not (is_main f)) fdecls
in
let handle_cdecl cdecl =
let crecord = StringMap.find_exn crecord_map cdecl.cname in
let sfdecls = List.fold_left cdecl.cbody.methods
~f:(fun l f -> (convert_method_to_sfdecl fdecl_map crecord_map cdecl.cname f) :: l)
~init:[]
in
let sfdecls = remove_main sfdecls in
let scdecl = convert_cdecl_to_scdecl sfdecls cdecl in
(scdecl, sfdecls)
in
let iter_cdecls t c =
let scdecl = handle_cdecl c in
(fst scdecl :: fst t, snd scdecl @ snd t)
in
let (scdecl_list, sfdecl_list) = List.fold_left cdecls
~f:iter_cdecls
~init:([], [])
in
let sfdecls = List.fold_left first_order_fdecls
~f:(fun l f -> (convert_fdecl_to_sfdecl fdecl_map crecord_map f StringMap.empty None StringMap.empty) :: l)
~init:[]
in
let sfdecls = StringMap.fold !higher_order_sfdecls
~f:(fun ~key:k ~data:sfdecl l -> sfdecl :: l)
~init:sfdecls
in
let (scdecl_list, sfdecl_list) = (scdecl_list, sfdecls @ sfdecl_list) in
let scdecls = List.fold_left sfdecl_list
~f:(fun l f -> (generate_sfdecl_records f) :: l)
~init:[]
in
let (scdecl_list, sfdecl_list) = (scdecls @ scdecl_list, sfdecl_list) in
let main = get_main sfdecl_list in
let sfdecl_list = remove_main sfdecl_list in
{
classes = scdecl_list;
functions = sfdecl_list;
main = main;
}
let analyze filename ast = match ast with
Program(includes, specs, cdecls, fdecls) ->
let reserved_map = build_reserved_map in
let (fdecl_map, fdecls, first, higher) = build_fdecl_map reserved_map fdecls in
let crecord_map = build_crecord_map reserved_map cdecls fdecls in
let sast = convert_ast_to_sast crecord_map cdecls fdecl_map first higher in
sast
exceptions.ml
exception InvalidOption of string
exception InvalidArgc
exception NoFileArgument
exception IllegalCharacter of string * string * int
exception CannotDefineVariableLengthArgFunction
exception MissingEOF
exception FTypeMustBeFunctiontype
exception ThisUsedOutsideClass
exception MissingMainFunction
exception MultipleMainFunctions
exception InvalidUnaryOperation
exception UnexpectedNoexpr
exception UnexpectedType
exception UnexpectedNoFname
exception UnexpectedDatatype
exception UnexpectedNonBodyStmt
exception InvalidBinaryOperation
exception LHSofObjectAccessMustBeAccessible
exception RHSofObjectAccessMustBeAccessible
exception UnknownClassVar
exception CannotUseThisKeywordOutsideOfClass
exception InvalidIfStatementType
exception InvalidForStatementType
exception InvalidWhileStatementType
exception NonIntegerArraySize
exception NonArrayTypeCreate
exception CallFailedOnType of string
exception InvalidEqualityBinop of string * string
exception UndefinedId of string
exception DuplicateField of string
exception DuplicateClassName of string
exception DuplicateVar of string
exception DuplicateFunctionName of string
exception FunctionNameReserved of string
exception ReturnTypeMismatch of string * string * string option
exception AssignmentTypeMismatch of string * string
exception LocalAssignmentTypeMismatch of string * string
exception LocalAssignmentTypeNotAssignable of string
exception ArrayAccess of string
exception UndefinedFunction of string
exception BreakOutsideOfLoop
exception ContinueOustideOfLoop
exception UtilsError of string
exception FieldIndexNotFound
exception PrintfFirstArgNotString
exception PrintfMissingArgs
exception NotImplemented
exception FloatOpNotSupported
exception IntOpNotSupported
exception UnopNotSupported
exception InvalidUnopEvaluationType
exception InvalidBinopEvaluationType
exception InvalidObjAccessType
exception InvalidStructType of string
exception InvalidStructType of string
exception InvalidDatatype of string
exception LLVMFunctionNotFound of string
exception FunctionWithoutBasicBlock of string
exception AssignmentLhsMustBeAssignable
exception ArrayLargerThan1Unsupported