diff options
| -rw-r--r-- | doc.txt | 19 | ||||
| -rw-r--r-- | src/Makefile | 2 | ||||
| -rw-r--r-- | src/codegen.ml | 344 | ||||
| -rw-r--r-- | src/main.ml | 3 | ||||
| -rw-r--r-- | src/pretty_typing.ml | 23 | ||||
| -rwxr-xr-x | src/test.sh | 73 | ||||
| -rw-r--r-- | src/typing.ml | 155 |
7 files changed, 524 insertions, 95 deletions
@@ -0,0 +1,19 @@ +Pour une fonction f(x, y) on a sur la pile : + + | ..... | + | y | construit par + | x | l'appelant + ---------------------------------- + | sauv. $fp | construit par + $fp--> | sauv. $ra | l'appelé + | z | + | ..... | + +La valeur renvoyée par une fonction est passée dans le registre a0. + + +--- + +Tous les calculs se font en utilisant a0 comme sommet de pile (les seuls valeurs +plus grosses qu'un registre ne sont jamais manipulées en tant que valeurs mais toujours +en tant qu'adresses... donc tout va bien) diff --git a/src/Makefile b/src/Makefile index c7ff839..47e2e48 100644 --- a/src/Makefile +++ b/src/Makefile @@ -2,7 +2,7 @@ BIN=minic++ all: $(BIN) -$(BIN): main.ml ast.ml parser.mly lexer.mll pretty.ml typing.ml pretty_typing.ml +$(BIN): main.ml ast.ml parser.mly lexer.mll pretty.ml typing.ml pretty_typing.ml codegen.ml ocamlbuild main.byte mv main.byte $(BIN) diff --git a/src/codegen.ml b/src/codegen.ml index 2709526..b1501fd 100644 --- a/src/codegen.ml +++ b/src/codegen.ml @@ -1,6 +1,346 @@ open Mips +open Typing + +exception Very_bad_error of string + +(* Environnement pour accéder aux variables *) +type whereis_var = + | VGlobal + | VStack of int (* position relative à $fp *) + | VStackByRef of int + +type cg_env = { + c_penv : env; + c_names : whereis_var Smap.t; + c_ret_ref : bool; + c_fp_used : int; +} + +let globals_env = ref Smap.empty + +let strings = Hashtbl.create 12 (* string -> label *) + +(* Identifiants uniques pour les machins - essentiellement labels *) +let id = + let last = ref 0 in + fun prefix -> (last := !last + 1; prefix ^ (string_of_int !last)) + + +(* Génération de code des machins *) + +let cr a = if a then lw a0 areg (0, a0) else nop (* conditionnally read *) + +(* Convention : doit garder $sp invariant *) +let rec gen_expr env e = match e.te_desc with + | TEInt(k) -> li a0 k, false + | TENull -> move a0 zero, false + | TEThis -> (* convention : this is always the last-pushed argument *) + lw a0 areg (8, fp), false + | TEIdent(i) -> + begin match Smap.find i env.c_names with + | VGlobal -> la a0 alab i, true + | VStack(i) -> la a0 areg (i, fp), true + | VStackByRef(i) -> lw a0 areg (i, fp), true + end + | TEAssign(e1, e2) -> + let t1, ae1 = gen_expr env e1 in + assert ae1; + let t2, ae2 = gen_expr env e2 in + t1 ++ push a0 ++ t2 ++ cr ae2 ++ pop a1 ++ sw a0 areg (0, a1), false + | TECallFun(id, args, b) -> + let code = List.fold_left + (fun code (arg, byref) -> + let c, r = gen_expr env arg in + assert (r || not byref); + c ++ cr (r && not byref) ++ push a0 ++ code) nop args in + code ++ jal id ++ popn (4 * (List.length args)), b + | TECallVirtual(obj, fi, args, b) -> + let code = List.fold_left + (fun code (arg, byref) -> + let c, r = gen_expr env arg in + assert (r || not byref); + c ++ cr (r && not byref) ++ push a0 ++ code) nop args in + let code2, a = gen_expr env obj in + assert a; + code ++ code2 ++ push a0 ++ lw a0 areg (0, a0) ++ lw a0 areg (fi, a0) + ++ jalr a0 ++ popn (4 * (1 + List.length args)), b + | TEUnary (x, e) -> + let t, a = gen_expr env e in + begin match x with + | Ast.Deref -> t ++ cr a, true + | Ast.Ref -> assert a; t, false + | Ast.Plus -> t ++ cr a, false + | Ast.Minus -> t ++ cr a ++ neg a0 a0, false + | Ast.Not -> t ++ cr a ++ not_ a0 a0, false + | Ast.PreIncr -> assert a; t ++ lw a1 areg (0, a0) ++ add a1 a1 oi 1 ++ sw a1 areg (0, a0), true + | Ast.PreDecr -> assert a; t ++ lw a1 areg (0, a0) ++ sub a1 a1 oi 1 ++ sw a1 areg (0, a0), true + | Ast.PostIncr -> assert a; t ++ move a1 a0 ++ lw a2 areg(0, a1) ++ move a0 a2 ++ + add a2 a2 oi 1 ++ sw a2 areg(0, a1), false + | Ast.PostDecr -> assert a; t ++ move a1 a0 ++ lw a2 areg(0, a1) ++ move a0 a2 ++ + sub a2 a2 oi 1 ++ sw a2 areg(0, a1), false + end + | TEBinary(e1, op, e2) -> + let t1, ae1 = gen_expr env e1 in + let t2, ae2 = gen_expr env e2 in + let t1 = t1 ++ cr ae1 in + let t2 = t2 ++ cr ae2 in + ( + match op with + | Ast.Add -> t1 ++ push a0 ++ t2 ++ pop a1 ++ add a0 a1 oreg a0 + | Ast.Sub -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sub a0 a1 oreg a0 + | Ast.Mul -> t1 ++ push a0 ++ t2 ++ pop a1 ++ mul a0 a1 oreg a0 + | Ast.Div -> t1 ++ push a0 ++ t2 ++ pop a1 ++ div a0 a1 oreg a0 + | Ast.Modulo -> t1 ++ push a0 ++ t2 ++ pop a1 ++ rem a0 a1 oreg a0 + | Ast.Equal -> t1 ++ push a0 ++ t2 ++ pop a1 ++ seq a0 a1 a0 + | Ast.NotEqual -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sne a0 a1 a0 + | Ast.Lt -> t1 ++ push a0 ++ t2 ++ pop a1 ++ slt a0 a1 a0 + | Ast.Le -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sle a0 a1 a0 + | Ast.Gt -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sgt a0 a1 a0 + | Ast.Ge -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sge a0 a1 a0 + | Ast.Land -> + let lazy_lbl = id "_lazy" in + t1 ++ beqz a0 lazy_lbl ++ t2 ++ label lazy_lbl ++ sne a0 a0 zero + | Ast.Lor -> + let lazy_lbl = id "_lazy" in + t1 ++ bnez a0 lazy_lbl ++ t2 ++ label lazy_lbl ++ sne a0 a0 zero + ), false + | TEMember(e, i) -> + let c, a = gen_expr env e in + if i <> 0 then begin + assert a; + c ++ la a0 areg (i, a0), true + end else + c, a + | TEPointerCast(e, i) -> + let c, a = gen_expr env e in + c ++ cr a ++ (if i = 0 then nop else la a0 areg (i, a0)), false + | TENew(cls, constr, args) -> + let args_code = List.fold_left + (fun code (arg, byref) -> + let c, r = gen_expr env arg in + assert (r || not byref); + c ++ cr (r && not byref) ++ push a0 ++ code) nop args in + let alloc = li v0 9 ++ li a0 cls.tc_size ++ syscall in + args_code ++ alloc ++ push v0 ++ jal constr + ++ pop a0 ++ popn (4 * List.length args), false + + +let rec gen_stmt env = function + | TSEmpty -> nop, nop, env + | TSExpr(e) -> + comment "expr" ++ (fst (gen_expr env e)), nop, env + | TSIf(cond, s1, s2) -> + let c, a = gen_expr env cond in + let l_else = id "_cond_then" in + let l_end = id "_cond_end" in + let c_then, d_then, _ = gen_stmt env s1 in + let c_else, d_else, _ = gen_stmt env s2 in + comment "if" ++ c ++ cr a ++ beqz a0 l_else ++ c_then ++ b l_end ++ + label l_else ++ c_else ++ label l_end, d_then ++ d_else, env + | TSWhile(cond, body) -> + let c, a = gen_expr env cond in + let l_begin = id "_while_begin" in + let l_cond = id "_while_cond" in + let c_body, d_body, _ = gen_stmt env body in + comment "while" ++ b l_cond ++ label l_begin ++ c_body ++ + label l_cond ++ c ++ cr a ++ bnez a0 l_begin, d_body, env + | TSFor(before, cond, after, body) -> + let l_begin = id "_for_begin" in + let l_cond = id "_for_cond" in + let c_before = List.fold_left + (fun code expr -> let c, _ = gen_expr env expr in code ++ c) nop before in + let c_after = List.fold_left + (fun code expr -> let c, _ = gen_expr env expr in code ++ c) nop after in + let c_cond = match cond with + | None -> b l_begin + | Some x -> let c, a = gen_expr env x in + c ++ cr a ++ bnez a0 l_begin in + let c_body, d_body, _ = gen_stmt env body in + comment "for" ++ c_before ++ b l_cond ++ label l_begin ++ c_body ++ c_after ++ label l_cond + ++ c_cond, d_body, env + | TSBlock(b) -> + let c, d = gen_block env b in + comment "block" ++ c, d, env + | TSReturn (None) -> + comment "return" ++ b "_return", nop, env + | TSReturn (Some e) -> + let c, a = gen_expr env e in + assert (a || not env.c_ret_ref); + comment "return" ++ c ++ cr (not env.c_ret_ref && a) ++ b "_return", nop, env + | TSDeclare (ty, id) -> + let s = type_size env.c_penv ty in + let new_fp_used = env.c_fp_used + s in + let pos = - new_fp_used in + let code = match ty with + | TClass(i) -> + let c = get_c env.c_penv i in + let cproto = List.find (fun p -> p.tp_ret_type = None && p.tp_name = i && p.tp_args = []) c.tc_methods in + sub sp sp oi s ++ + la a0 areg (pos, fp) ++ + push a0 ++ + jal cproto.tp_unique_ident + | _ -> push zero + in + comment ("declare " ^ id) ++ code, nop, { + c_penv = env.c_penv; + c_names = Smap.add id (VStack pos) env.c_names; + c_ret_ref = env.c_ret_ref; + c_fp_used = new_fp_used } + | TSDeclareAssignConstructor(cls, id, constr, args) -> + let new_fp_used = env.c_fp_used + cls.tc_size in + let pos = - new_fp_used in + let code = + let args_code = List.fold_left + (fun code (arg, byref) -> + let c, r = gen_expr env arg in + assert (r || not byref); + c ++ cr (r && not byref) ++ push a0 ++ code) nop args in + sub sp sp oi cls.tc_size ++ args_code ++ la a0 areg(pos, fp) ++ push a0 ++ jal constr ++ + popn (4 * (List.length args + 1)) + in + comment ("declare " ^ id) ++ code, nop, { + c_penv = env.c_penv; + c_names = Smap.add id (VStack pos) env.c_names; + c_ret_ref = env.c_ret_ref; + c_fp_used = new_fp_used; } + | TSDeclareAssignExpr ((ty, r), id, e) -> + let s = if r then 4 else type_size env.c_penv ty in + assert (s = 4); + let new_fp_used = env.c_fp_used + 4 in + let pos = - new_fp_used in + let code, a = gen_expr env e in + assert (a || not r); + comment ("declare " ^ id) ++ sub sp sp oi 4 ++ code ++ cr (a && not r) ++ sw a0 areg (pos, fp), nop, { + c_penv = env.c_penv; + c_names = Smap.add id (if r then VStackByRef pos else VStack pos) env.c_names; + c_ret_ref = env.c_ret_ref; + c_fp_used = new_fp_used } + | TSWriteCout(sl) -> + let text1, data1 = List.fold_left + (fun (text, data) s -> + match s with + | TSEExpr(e) -> + let t, a = gen_expr env e in + text ++ t ++ cr a ++ li v0 1 ++ syscall, data + | TSEStr(s) -> + let l, d = + if Hashtbl.mem strings s then + Hashtbl.find strings s, nop + else + let l = id "_s" in Hashtbl.add strings s l; + l, label l ++ asciiz s + in + text ++ la a0 alab l ++ li v0 4 ++ syscall, data ++ d) (nop, nop) sl in + comment "cout<<..." ++ text1, data1, env +and gen_block env b = + let text, data, fin_env = + List.fold_left (fun (t, d, e) s -> + let tt, dd, e = gen_stmt e s in + t ++ tt, d ++ dd, e) + (nop, nop, env) b + in + let n = (fin_env.c_fp_used - env.c_fp_used) in + text ++ (if n = 0 then nop else popn n), data + +let gen_decl tenv decl = match decl with + | TDGlobal(ty, id) -> + globals_env := Smap.add id VGlobal !globals_env; + let bytes = type_size tenv ty in + nop, (label id) ++ (dword (let rec a n = if n > 0 then 0::(a (n-4)) else [] in a bytes)) + | TDFunction(proto, block) -> + let names, _ = List.fold_left + (fun (env, p) ((ty, r), id) -> + Smap.add id (if r then VStackByRef p else VStack p) env, p + (type_size tenv ty)) + (!globals_env, (match proto.tp_class with | None -> 8 | Some k -> 12)) proto.tp_args in + let env = { + c_penv = tenv; + c_names = names; + c_ret_ref = (match proto.tp_ret_type with | None -> false | Some(_, r) -> r); + c_fp_used = 0; + } in + let code_for_constructor = match proto.tp_ret_type with + | Some _ -> nop + | None -> let cls_name = (match proto.tp_class with | Some k -> k | None -> assert false) in + lw v0 areg (8, fp) ++ jal ("_c_" ^ cls_name) in + let code_for_virtual = match proto.tp_virtual with + | Some (c, _) when c.h_pos <> 0 -> + lw a0 areg (8, fp) ++ la a0 areg (-c.h_pos, a0) ++ sw a0 areg (8, fp) + | _ -> nop + in + let text, data = gen_block env block in + label proto.tp_unique_ident ++ + push fp ++ push ra ++ move fp sp ++ code_for_constructor ++ code_for_virtual ++ + text ++ b "_return", data + | TDClass(c) -> + (* Call default constructor of parent classes *) + let code_parents = List.fold_left + (fun code parent -> + let cn = parent.h_class in + let c = get_c tenv cn in + let proto = List.find (fun p -> p.tp_ret_type = None && p.tp_args = [] && p.tp_name = cn) c.tc_methods in + code ++ lw v0 areg(0, sp) ++ la v0 areg(parent.h_pos, v0) ++push v0 ++ jal proto.tp_unique_ident ++ popn 4) + nop c.tc_hier.h_supers in + let code_parents = if code_parents <> nop then push v0 ++ code_parents ++ pop v0 else nop in + (* Build vtables and build constructor *) + let rec make_vtables hh = + (* calculate vtable contents *) + let vtable_size = List.fold_left (fun k (p, _) -> max k (p+4)) 0 hh.h_vtable in + let vtable_as_array = Array.make (vtable_size / 4) "_nothing" in + List.iter (fun (p, s) -> vtable_as_array.(p/4) <- s.tp_unique_ident) hh.h_vtable; + let vt_l = Array.to_list vtable_as_array in + (* code for vtable initialization *) + let vtable = + if vt_l = [] + then nop + else label ("_vt_" ^ c.tc_name ^ "_as_" ^ hh.h_class) ++ address vt_l in + let constructor_code = + if vt_l = [] + then sw zero areg (hh.h_pos, v0) + else la a0 alab ("_vt_" ^ c.tc_name ^ "_as_" ^ hh.h_class) + ++ sw a0 areg (hh.h_pos, v0) in + (* code for subclasses initialization *) + List.fold_left + (fun (vt, cc) sup -> + let mvt, mcc = make_vtables sup in + vt ++ mvt, cc ++ mcc) + (vtable, constructor_code) hh.h_supers + in + let vtables, vtable_init_code = make_vtables c.tc_hier in + let init_code_proper = Smap.fold + (fun _ (ty, pos) code -> + (match ty with + | TClass(s) -> + let cs = get_c tenv s in + let proto = List.find (fun p -> p.tp_ret_type = None && p.tp_args = [] && p.tp_name = s) cs.tc_methods in + push v0 ++ + la a0 areg (pos, v0) ++ push a0 ++ + jal proto.tp_unique_ident ++ popn 4 ++ pop v0 + | _ -> sw zero areg (pos, v0) + ) ++ code) c.tc_members nop + in + label (c.tc_name ^ "0") ++ lw v0 areg (0, sp) ++ label ("_c_" ^ c.tc_name) + ++ push ra ++ code_parents ++ vtable_init_code ++ init_code_proper ++ pop ra ++ jr ra, vtables let generate p = - { text = nop; - data = nop } + try + let text, data = List.fold_left (fun (text, data) decl -> + let more_text, more_data = gen_decl p.prog_env decl in + text ++ more_text, data ++ more_data) (nop, nop) p.prog_decls in + let text = + label "main" ++ jal p.prog_main ++ + li v0 10 ++ syscall ++ + label "_return" ++ move sp fp ++ pop ra ++ pop fp ++ + label "_nothing" ++ jr ra ++ + text in + { text = text; + data = data } + with + | Assert_failure (k, a, b) -> raise (Very_bad_error ( + "(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b))) + | Not_found -> raise (Very_bad_error ("(unexpected) Not found")) + | Invalid_argument(k) -> raise (Very_bad_error ("(unexpected) Invalid argument: "^k)) + | Match_failure(k, a, b) -> raise (Very_bad_error ( + "(unexpected) Match failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b))) + | Stack_overflow -> raise (Very_bad_error ("(unexpected) Stack overflow")) + | _ -> raise (Very_bad_error ("(unexpected) Other error")) diff --git a/src/main.ml b/src/main.ml index 976586f..a087cb5 100644 --- a/src/main.ml +++ b/src/main.ml @@ -78,6 +78,9 @@ let () = localisation2 loc; eprintf "%s@." msg; exit 2 + | Codegen.Very_bad_error(msg) -> + eprintf "Very bad error: %s@." msg; + exit 3; | _ -> eprintf "Unexpected error...@."; diff --git a/src/pretty_typing.ml b/src/pretty_typing.ml index f9e69ff..a6ec2eb 100644 --- a/src/pretty_typing.ml +++ b/src/pretty_typing.ml @@ -42,20 +42,21 @@ let rec expr_string e = match e.te_desc with | TEThis -> "this" | TEIdent(i) -> i | TEAssign(k, p) -> "(" ^ (expr_string k) ^ " = " ^ (expr_string p) ^ ")" - | TECallFun(i, f) -> i ^ "(" ^ (csl expr_string f) ^ ")" + | TECallFun(i, f, _) -> i ^ "(" ^ (csl expr_string (List.map fst f)) ^ ")" (* ici, le second ast a changé par rapport au premier *) | TEUnary(e, f) -> (unop_str e) ^ (expr_string f) | TEBinary(e1, o, e2) -> "(" ^ (expr_string e1) ^ " " ^ (binop_str o) ^ " " ^ (expr_string e2) ^ ")" | TEMember(e1, i) -> "(" ^ (expr_string e1) ^ ")@" ^ (string_of_int i) + | TEPointerCast(e1, i) -> "(" ^ (expr_string e1) ^ ")+" ^ (string_of_int i) | TENew(c, proto, arg) -> "new " ^ c.tc_name - ^ (match proto with | None -> "" | Some p -> " ." ^ p.tp_unique_ident) - ^ " (" ^ (csl expr_string arg) ^ ")" - | TECallVirtual(exp, pos1, pos2, args) -> - "(" ^ (expr_string exp) ^ ")@" ^ (string_of_int pos1) ^ "#" ^ (string_of_int pos2) ^ "(" ^ (csl expr_string args) ^ ")" + ^ " ." ^ proto + ^ " (" ^ (csl expr_string (List.map fst arg)) ^ ")" + | TECallVirtual(exp, pos2, args, _) -> + "(" ^ (expr_string exp) ^ ")#" ^ (string_of_int pos2) ^ "(" ^ (csl expr_string (List.map fst args)) ^ ")" let rec print_stmt l x = for i = 1 to l do print_string " " done; - match x.ts_desc with + match x with | TSEmpty -> print_string ";\n" | TSExpr(e) -> print_string ((expr_string e) ^ "\n") | TSIf(e, a, b) -> print_string ("if " ^ (expr_string e) ^ "\n"); @@ -74,13 +75,11 @@ let rec print_stmt l x = | TSBlock(b) -> print_block l b | TSReturn(None) -> print_string "return\n" | TSReturn(Some k) -> print_string ("return " ^ (expr_string k) ^ "\n") - | TSDeclare((ty,b), i) -> let addr = (if b then "&" else "") in - print_string (addr ^ i ^ " : " ^ (var_type_str ty) ^ "\n") + | TSDeclare(ty, i) -> print_string (i ^ " : " ^ (var_type_str ty) ^ "\n") | TSDeclareAssignExpr((ty,b), i, e) -> let addr = (if b then "&" else "") in print_string (addr ^ i ^ " : " ^ (var_type_str ty) ^ " = " ^ (expr_string e) ^ "\n") - | TSDeclareAssignConstructor(t, i, _, c, a) -> () (*print_string - (i ^ " : " ^ (var_type_str t) ^ " = " ^ c ^ "(" ^ - (csl expr_string a) ^ ")\n")*) + | TSDeclareAssignConstructor(cls, i, c, a) -> + print_string (i ^ " : " ^ cls.tc_name ^ " = ." ^ c ^ " (" ^(csl expr_string (List.map fst a)) ^ ")\n") | TSWriteCout(k) -> print_string ("std::cout" ^ (List.fold_left (fun x k -> x ^ " << " ^ (match k with | TSEExpr e -> expr_string e @@ -104,7 +103,7 @@ let proto_str p = p.tp_args) ^ ") : " ^ (match p.tp_ret_type with | Some (ty,b) -> var_type_str ty | None -> "constructor") ^ " ." ^ p.tp_unique_ident - ^ (match p.tp_virtual with | None -> "" | Some (k, l) -> " @" ^ (string_of_int k) ^ "#" ^ (string_of_int l)) + ^ (match p.tp_virtual with | None -> "" | Some (k, l) -> " @" ^ (string_of_int k.h_pos) ^ "#" ^ (string_of_int l)) let print_class_decl c = print_string ("class " ^ c.tc_name ^ " (size : " ^ (string_of_int c.tc_size) ^ ") {\n"); diff --git a/src/test.sh b/src/test.sh index 090dc6f..eaec94a 100755 --- a/src/test.sh +++ b/src/test.sh @@ -4,58 +4,75 @@ echo "Testing SYNTAX/" for a in ../tests/syntax/good/*.cpp; do - if ./minic++ --parse-only $a; - then echo "OK $a"; - else echo "FAIL $a"; - fi; + if ./minic++ --parse-only $a; + then echo "OK $a"; + else echo "FAIL $a"; + fi; done; for a in ../tests/syntax/bad/*.cpp; do - if ./minic++ --parse-only $a 2> /dev/null; - then echo "FAIL $a"; - else echo "OK $a"; - fi; + if ./minic++ --parse-only $a 2> /dev/null; + then echo "FAIL $a"; + else echo "OK $a"; + fi; done; echo "---" echo "Testing TYPING/ only against parsing" for a in ../tests/typing/*/*.cpp; do - if ./minic++ --parse-only $a; - then echo "OK $a"; - else echo "FAIL $a"; - fi; + if ./minic++ --parse-only $a; + then echo "OK $a"; + else echo "FAIL $a"; + fi; done; echo "---" echo "Testing EXEC/ only against parsing" for a in ../tests/exec/*.cpp; do - if ./minic++ --parse-only $a; - then echo "OK $a"; - else echo "FAIL $a"; - fi; + if ./minic++ --parse-only $a; + then echo "OK $a"; + else echo "FAIL $a"; + fi; done; echo "---" echo "Testing TYPING/" for a in ../tests/typing/good/*.cpp; do - if ./minic++ --type-only $a; - then echo "OK $a"; - else echo "FAIL $a"; - fi; + if ./minic++ --type-only $a; + then echo "OK $a"; + else echo "FAIL $a"; + fi; done; for a in ../tests/typing/bad/*.cpp; do - if ./minic++ --type-only $a 2> /dev/null; - then echo "FAIL $a"; - else echo "OK $a"; - fi; + if ./minic++ --type-only $a 2> /dev/null; + then echo "FAIL $a"; + else echo "OK $a"; + fi; done; echo "---" echo "Testing EXEC/ only against typing" for a in ../tests/exec/*.cpp; do - if ./minic++ --type-only $a; - then echo "OK $a"; - else echo "FAIL $a"; - fi; + if ./minic++ --type-only $a; + then echo "OK $a"; + else echo "FAIL $a"; + fi; done; + +echo "---" +echo "Testing EXEC/" +for a in ../tests/exec/*.cpp; do + if ./minic++ $a; + then + mars-mips nc se1 ../tests/exec/`basename -s .cpp $a`.s > /tmp/mips_out.txt + if diff -B /tmp/mips_out.txt ../tests/exec/`basename -s .cpp $a`.out > /dev/null + then echo "OK $a" + else echo "FAIL $a" + fi + else echo "TODO $a"; + fi; +done; + + + diff --git a/src/typing.ml b/src/typing.ml index 6b1c801..4c105da 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -48,25 +48,25 @@ and texpr_desc = | TEThis | TEIdent of ident | TEAssign of texpression * texpression - | TECallFun of ident * texpression list (* changé : te -> ident *) + | TECallFun of ident * (texpression * bool) list * bool (* changé : te -> ident *) (* calls to non-virtual methods are compiled using TECallFun, with the object cons'ed at the begining of the arguments expression list *) - | TECallVirtual of texpression * int * int * texpression list (* object * index in vtable * arguments *) + (* for each argument, bool is is argument passed by reference ? *) + (* final bool : is returned value a reference ? *) + | TECallVirtual of texpression * int * (texpression * bool) list * bool + (* object * index in vtable * arguments * is return value a reference? *) | TEUnary of unop * texpression | TEBinary of texpression * binop * texpression | TEMember of texpression * int (* object * position of member *) - | TENew of tcls * tproto option * texpression list + | TEPointerCast of texpression * int (* object * position of member *) + | TENew of tcls * ident * (texpression * bool) list and tstr_expression = | TSEExpr of texpression | TSEStr of string -and tstatement = { - ts_loc: loc; - ts_desc: ts_desc; - } -and ts_desc = +and tstatement = | TSEmpty | TSExpr of texpression | TSIf of texpression * tstatement * tstatement @@ -74,18 +74,15 @@ and ts_desc = | TSFor of texpression list * texpression option * texpression list * tstatement | TSBlock of tblock | TSReturn of texpression option - | TSDeclare of type_ref * ident + | TSDeclare of typ * ident | TSDeclareAssignExpr of type_ref * ident * texpression - | TSDeclareAssignConstructor of typ * ident * tproto option * tident * texpression list (* a faire *) -(* Type of variable, variable name, constructor class name, constructor arguments *) + | TSDeclareAssignConstructor of tcls * ident * ident * (texpression * bool) list +(* Class name of variable, variable name, constructor name, constructor arguments *) | TSWriteCout of tstr_expression list and tblock = tstatement list and tproto = { - tp_virtual : (int * int) option; (* only used for class methods ; if none then not virtual, - if some then gives the index of the method in the vtable (same for all classes - of the hierarchy that have that method) *) - tp_loc : loc; + tp_virtual : (tcls_hier * int) option; (* only used for class methods ; if none then not virtual *) tp_name : ident; tp_unique_ident : ident; (* label de la fonction dans le code assembleur *) tp_class : tident option; (* p_class = none : standalone function *) @@ -136,6 +133,7 @@ type tdeclaration = type tprogram = { prog_decls : tdeclaration list; prog_env : env; + prog_main : ident; } (* Quelques fonctions utiles : *) @@ -182,10 +180,45 @@ let rec subtype env a b = match a, b with let c = get_c env i in let rec find_in_hier h = h.h_class = j || - (List.exists find_in_hier h.h_supers) + (List.length (List.filter find_in_hier h.h_supers) = 1) in find_in_hier c.tc_hier | _ -> false +let relative_class_position env i j = + let c = get_c env i in + let rec find_in_hier h = + h.h_class = j || + (List.length (List.filter find_in_hier h.h_supers) = 1) + and get_in_hier h = + if h.h_class = j + then h.h_pos + else match List.filter find_in_hier h.h_supers with + | [a] -> get_in_hier a + | _ -> assert false + in get_in_hier c.tc_hier + +let rec upcast env exp dt = (* présupposé : exp.type_expr <= dt *) + match exp.type_expr, dt with + | (T_Int, _, _), T_Int -> exp + | (T_Void, _, _), T_Void -> exp + | (Typenull, _, _), TPoint(_) -> exp + | (TClass(i), a, b), TClass(j) when a||b -> + begin match relative_class_position env i j with + | 0 -> exp + | pos -> + { type_expr = (TClass(j), false, true); te_loc = exp.te_loc; + te_desc = TEMember(exp, pos) } + end + | (TPoint(TClass(i)), a, b), TPoint(TClass(j)) -> + begin match relative_class_position env i j with + | 0 -> exp + | pos -> + { type_expr = (TPoint(TClass(j)), false, true); te_loc = exp.te_loc; + te_desc = TEPointerCast(exp, pos) } + end + | (TPoint(ka), _, _), TPoint(kb) -> exp + | _ -> assert false + let type_size env t = match t with | T_Int | Typenull | TPoint(_) -> 4 | T_Void -> 0 @@ -290,7 +323,7 @@ and compute_type env e = ty_assert (num ty1) "Cannot assign to non-numeric type (pointer type is numeric)"; ty_assert (subtype env.b_pe ty2 ty1) "Incompatible types in assign"; (* type num et ref compatibles ?*) - (TEAssign (te1,te2) ),(ty1,false,false) + (TEAssign (te1,upcast env.b_pe te2 ty1) ),(ty1,false,false) | EUnary (op,e) -> let te,(ty,b1,b2) = get_expr0 env e in (match op with | PreIncr | PostIncr | PreDecr | PostDecr -> @@ -315,14 +348,17 @@ and compute_type env e = | Equal | NotEqual -> ty_assert ((subtype env.b_pe ty1 ty2) || (subtype env.b_pe ty2 ty1)) "Can only apply == or != to two values of compatible type"; - ty_assert (num ty1) "Can only apply == or != to pointers" + ty_assert (num ty1) "Can only apply == or != to pointers"; + let te1 = if subtype env.b_pe ty1 ty2 then upcast env.b_pe te1 ty2 else te1 in + let te2 = if subtype env.b_pe ty2 ty1 then upcast env.b_pe te2 ty1 else te2 in + TEBinary(te1,op,te2),(T_Int,false,false) | Lt | Le | Gt | Ge | Add | Sub | Mul | Div | Modulo | Land | Lor -> ty_assert (ty1 = T_Int) "Left operand of binop is not integer"; - ty_assert (ty2 = T_Int) "Right operand of binop is not integer" - ); (* vérifs *) - TEBinary(te1,op,te2),(T_Int,false,false) + ty_assert (ty2 = T_Int) "Right operand of binop is not integer"; + TEBinary(te1,op,te2),(T_Int,false,false) + ) | ECall (e,e_list) -> (* TODO : look also within parent classes *) let args_values = List.map (get_expr0 env) e_list in @@ -334,8 +370,12 @@ and compute_type env e = begin match env.b_class with | None -> None, closest_proto env.b_pe args_types funs | Some k -> - begin try Some e_this_not_ptr, - closest_proto env.b_pe args_types (find_protos_in_class env.b_pe k.tc_name i) + begin try + let proto = closest_proto env.b_pe args_types (find_protos_in_class env.b_pe k.tc_name i) in + let upcasted = if proto.tp_virtual = None then e_this_not_ptr + else upcast env.b_pe e_this_not_ptr + (TClass (match proto.tp_class with | None -> assert false | Some k -> k)) in + Some upcasted, proto with NoCorrespondingPrototype -> None, closest_proto env.b_pe args_types funs end @@ -344,21 +384,26 @@ and compute_type env e = let e = type_expr env e in begin match e.type_expr with | TClass(k), a, b when a || b -> - Some e, closest_proto env.b_pe args_types (find_protos_in_class env.b_pe k i) + let proto = closest_proto env.b_pe args_types (find_protos_in_class env.b_pe k i) in + let upcasted = if proto.tp_virtual = None then e + else upcast env.b_pe e + (TClass (match proto.tp_class with | None -> assert false | Some k -> k)) in + Some upcasted, proto | _ -> ty_error "Invalid argument type for method call (not a class, or not a lvalue)" end | _ -> ty_error "Calling something that is neither a function nor a method") in let l_te = List.map fst args_values in + let l_te = List.map2 (fun k ((ty, r), _) -> upcast env.b_pe k ty, r) l_te tproto.tp_args in let ty,b = match tproto.tp_ret_type with | None -> ty_error "Constructor cannot be called as function" | Some (ty,b) -> ty,b in begin match tproto.tp_virtual, obj with | None, None -> - TECallFun(tproto.tp_unique_ident,l_te),(ty,b,false) + TECallFun(tproto.tp_unique_ident,l_te,b),(ty,b,false) | None, Some(obj)-> - TECallFun(tproto.tp_unique_ident,obj::l_te),(ty,b,false) - | Some(idx), Some(obj) -> - TECallVirtual(obj, fst idx, snd idx, l_te),(ty,b,false) + TECallFun(tproto.tp_unique_ident,(obj, true)::l_te,b),(ty,b,false) + | Some(hier, idx), Some(obj) -> + TECallVirtual(upcast env.b_pe obj (TClass hier.h_class), idx, l_te,b),(ty,b,false) | _ -> ty_error "(should not happen) Virtual function applied to no object..." end | EMember (e, id) -> @@ -377,14 +422,13 @@ and compute_type env e = let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in let candidates = List.filter (fun p -> p.tp_ret_type = None) c.tc_methods in begin match candidates with - | [] -> - ty_assert (args = []) "Only default constructor exists and it has 0 arguments"; - TENew(c, None, []), (TPoint(TClass(cls_name)), false, false) + | [] -> assert false (* default constructor should always be in list *) | _ -> let p = closest_proto env.b_pe args_types candidates in (* closest_proto makes sure the prototypes match, no problem here *) let l_te = List.map fst args_values in - TENew(c, Some p, l_te), (TPoint(TClass(cls_name)), false, false) + let l_te = List.map2 (fun k ((ty, r), _) -> upcast env.b_pe k ty, r) l_te p.tp_args in + TENew(c, p.tp_unique_ident, l_te), (TPoint(TClass(cls_name)), false, false) end | EThis -> begin match env.b_class with @@ -396,9 +440,7 @@ and compute_type env e = (* Statements *) let rec type_stm ret_type env s = - err_add_loc s.s_loc (fun () -> - let d, ty = compute_type_stm ret_type env s in - { ts_loc = s.s_loc; ts_desc = d }, ty) + err_add_loc s.s_loc (fun () -> compute_type_stm ret_type env s) and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_desc,stm_type *) | SEmpty -> TSEmpty,env @@ -438,12 +480,13 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des (* pq while n'est pas dans les règles données ? *) | SDeclare(vt,i) -> let ty,b = build_type_or_ref vt in ty_assert (bf env.b_pe ty) "Malformed type"; + ty_assert (not b) "Reference must be assigned at declaration"; ty_assert (not (Smap.mem i env.b_locals) ) "Variable redefinition"; let env0 = { b_pe = env.b_pe; b_locals = Smap.add i (ty,b) env.b_locals; b_class = env.b_class } in - TSDeclare( (ty,b) ,i) , env0 + TSDeclare( ty ,i) , env0 | SDeclareAssignExpr(vt,i,e) -> let ty,b = build_type_or_ref vt in ty_assert (bf env.b_pe ty) "Malformed type"; ty_assert (not (Smap.mem i env.b_locals)) "Variable redefinition"; @@ -454,7 +497,7 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des { b_pe = env.b_pe; b_locals = Smap.add i (ty,b) env.b_locals; b_class = env.b_class } in - TSDeclareAssignExpr( (ty,b) ,i,te) , env0 + TSDeclareAssignExpr( (ty,b) ,i,upcast env.b_pe te ty) , env0 | SDeclareAssignConstructor(vt,i,ti,e_l) -> let ty, b = build_type_or_ref vt in ty_assert (bf env.b_pe ty) "Malformed type"; @@ -466,18 +509,17 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in let candidates = List.filter (fun p -> p.tp_ret_type = None) c.tc_methods in begin match candidates with - | [] -> - ty_assert (e_l = []) "Only default constructor exists and it has 0 arguments"; - TSDeclareAssignConstructor(ty, i, None, ti, []), env + | [] -> assert false (* ... *) | _ -> let p = closest_proto env.b_pe args_types candidates in (* closest_proto makes sure the prototypes match, no problem here *) let l_te = List.map fst args_values in + let l_te = List.map2 (fun k ((ty, r), _) -> upcast env.b_pe k ty, r) l_te p.tp_args in let env0 = { b_pe = env.b_pe; b_locals = Smap.add i (ty,b) env.b_locals; b_class = env.b_class } in - TSDeclareAssignConstructor(ty, i, Some p, ti, l_te), env0 + TSDeclareAssignConstructor(c, i, p.tp_unique_ident, l_te), env0 end | SWriteCout(str_e_list) -> let args = @@ -536,7 +578,6 @@ let get_fun env p b = (* p : proto b : block -> tp, tb, env2*) (* Add to env *) let tproto = { - tp_loc = p.p_loc ; tp_name = name ; tp_unique_ident = name ^ (tproto_unique_number()); tp_class = None ; @@ -633,22 +674,19 @@ let compute_tclass env c = | None -> List.fold_left (fun f (i, p) -> if (p.tp_name = proto.p_name && (List.map fst p.tp_args) = (List.map fst args)) - then Some (i, s) + then Some (s, i) else f) None s.h_vtable in let super = match check_in_super hier with | None -> if virt then (* allocate new spot in vtable of this object *) - Some (List.fold_left (fun n (x, _) -> max n (x+4)) 0 hier.h_vtable, hier) + Some (hier, List.fold_left (fun n (x, _) -> max n (x+4)) 0 hier.h_vtable) else None | Some k -> Some k in (* Build proto *) let tproto = - { tp_virtual = (match super with - | Some(i, c) -> Some(c.h_pos, i) - | None -> None); - tp_loc = proto.p_loc; + { tp_virtual = super; tp_name = proto.p_name; tp_unique_ident = proto.p_name ^ (tproto_unique_number()) ; tp_class = Some(cls_name); @@ -658,12 +696,24 @@ let compute_tclass env c = (* Add to vtable *) begin match super with | None -> () - | Some (i, c) -> + | Some (c, i) -> c.h_vtable <- (i, tproto)::(List.remove_assoc i c.h_vtable) end; tproto) in (mem, mem_u), m::meth ) ((Smap.empty, used), []) c.c_members in + (* make sure class has default constructor *) + let meth = + if List.exists (fun p -> p.tp_ret_type = None && p.tp_name = cls_name) meth + then meth + else + { tp_virtual = None; + tp_name = cls_name; + tp_unique_ident = cls_name ^ "0"; + tp_class = Some cls_name; + tp_ret_type = None; + tp_args = [] }::meth + in { tc_name = cls_name; tc_size = mem_u; tc_hier = hier; @@ -739,11 +789,12 @@ let prog p = ([],{ e_globals = Smap.empty; e_funs = []; e_classes = Smap.empty }) p ) in - ty_assert (List.exists + let p = try List.find (fun tp -> tp.tp_class = None && tp.tp_name = "main" && tp.tp_args = [] && tp.tp_ret_type = Some (T_Int,false)) - env.e_funs) "No 'int main()' function defined in program..."; - { prog_decls = List.rev decls; prog_env = env } + env.e_funs + with Not_found -> ty_error "No correct main function in program." in + { prog_decls = List.rev decls; prog_env = env; prog_main = p.tp_unique_ident } |