summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc.txt19
-rw-r--r--src/Makefile2
-rw-r--r--src/codegen.ml344
-rw-r--r--src/main.ml3
-rw-r--r--src/pretty_typing.ml23
-rwxr-xr-xsrc/test.sh73
-rw-r--r--src/typing.ml163
7 files changed, 530 insertions, 97 deletions
diff --git a/doc.txt b/doc.txt
new file mode 100644
index 0000000..44d3bd7
--- /dev/null
+++ b/doc.txt
@@ -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 51b57aa..619fac9 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.native
mv main.native $(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 c5a44e3..a62eb55 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 *)
@@ -130,6 +127,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
@@ -313,7 +346,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 ->
@@ -338,14 +371,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) ->
let args_values = List.map (get_expr0 env) e_list in
let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in
@@ -356,8 +392,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
@@ -366,7 +406,11 @@ 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
| EQIdent(c, i) ->
@@ -374,22 +418,27 @@ and compute_type env e =
| Some k ->
let sc = try find_cls_superclass env.b_pe k.tc_name c
with Not_found -> ty_error (c ^ " is no superclass of current class " ^ k.tc_name) in
- Some e_this_not_ptr,
- closest_proto env.b_pe args_types (find_protos_in_class env.b_pe sc.h_class i)
+ let proto = closest_proto env.b_pe args_types (find_protos_in_class env.b_pe sc.h_class i) in
+ let upcasted = if proto.tp_virtual = None
+ then upcast env.b_pe e_this_not_ptr (TClass(c))
+ 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
| None -> ty_error "Qualified identifier in a function belonging to no class."
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) ->
@@ -408,14 +457,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
@@ -427,9 +475,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
@@ -469,9 +515,10 @@ 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 = { env with b_locals = Smap.add i (ty,b) env.b_locals } 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";
@@ -479,7 +526,7 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des
ty_assert (if b then r || l else true) "Can only assigne lvalue/reference to reference type var";
ty_assert (subtype env.b_pe tye ty) "Invalid data type for assign.";
let env0 = { env with b_locals = Smap.add i (ty,b) env.b_locals } 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";
@@ -491,15 +538,14 @@ 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 = { env with b_locals = Smap.add i (ty,b) env.b_locals } 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 =
@@ -558,7 +604,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 ;
@@ -648,22 +693,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);
@@ -673,12 +715,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;
@@ -750,11 +804,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 }
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 12:28:27 +0000