summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Makefile2
-rw-r--r--src/codegen.ml706
-rw-r--r--src/main.ml3
-rw-r--r--src/mips.ml6
-rw-r--r--src/mips.mli6
-rw-r--r--src/pretty_typing.ml23
-rwxr-xr-xsrc/test.sh73
-rw-r--r--src/typing.ml177
8 files changed, 898 insertions, 98 deletions
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..3849bfa 100644
--- a/src/codegen.ml
+++ b/src/codegen.ml
@@ -1,6 +1,708 @@
open Mips
+open Typing
+
+exception Very_bad_error of string
+
+exception Reference_register of register
+
+(* Convention pour les registres :
+ - a0, a1, a2, a3 : contiennent les (éventuels) 4 premiers arguments de la fonction
+ - v0 : contient la valeur de retour des fonctions (rien de particulier pour un constructeur)
+ - v0-v1, t0-t9, s0-s1 : utilisés pour les calculs
+ - fp contient un pointeur de frame mis à jour pour chaque appel
+ de fonction
+ - sp n'est pas tenu à jour en fonction de l'état de la pile, par contre il est
+ utilisé lors d'un appel de fonction pour pouvoir définir le nouvea fp,
+ il est donc mis à jour avant chaque appel de fonction pour effectivement refléter
+ l'état d'utilisation de la pile (pile sur laquelle il peut d'ailleurs y avoir
+ des arguments excedentaires)
+ Tous les registres doivent être sauvés par l'appellant sauf fp
+ Les registres a0, a1, a2, a3 sont susceptibles d'être modifiés par la fonction appellée.
+ **sauf dans le cas où a0 représente this** !!
+*)
+
+(* Environnement pour accéder aux variables *)
+type whereis_var =
+ | VGlobal
+ | VStack of int (* position relative à $fp *)
+ | VStackByRef of int
+ | VRegister of register
+ | VRegisterByRef of register
+
+type cg_env = {
+ c_penv : env;
+ c_names : whereis_var Smap.t;
+ c_ret_ref : bool;
+ c_ret_lbl : string;
+ c_fp_used : int;
+ c_need_fp : bool ref;
+ c_save_regs : register list;
+ c_free_regs : register list;
+}
+
+let env_push n e =
+ if n <> 0 then e.c_need_fp := true;
+ let kk = e.c_fp_used + n in
+ { e with c_fp_used = kk }, -kk
+
+let env_add_var vid vv e =
+ { e with c_names = Smap.add vid vv e.c_names }
+
+let env_get_free_reg e =
+ let r, more = List.hd e.c_free_regs, List.tl e.c_free_regs in
+ { e with
+ c_free_regs = more;
+ c_save_regs = r::e.c_save_regs }, r
+
+let globals_env = ref Smap.empty
+
+(* Chaînes de caractères utilisées dans le programme *)
+let strings = Hashtbl.create 12 (* string -> label *)
+
+(* Identifiants uniques pour divers objets - essentiellement labels *)
+let id =
+ let last = ref 0 in
+ fun prefix -> (last := !last + 1; prefix ^ (string_of_int !last))
+
+(* Doit-on se préparer à faire des appels de fonction ? Ie sauvegarder $ra *)
+let rec expr_does_call e = match e.te_desc with
+ | TEInt _ | TENull | TEThis | TEIdent _ -> false
+ | TEAssign(a, b) -> expr_does_call a || expr_does_call b
+ | TECallFun (_, _, _) -> true
+ | TECallVirtual (_, _, _, _) -> true
+ | TEUnary (_, e) -> expr_does_call e
+ | TEBinary (a, _, b) -> expr_does_call a || expr_does_call b
+ | TEMember (e, _) -> expr_does_call e
+ | TEPointerCast(e, _) -> expr_does_call e
+ | TENew(_, _, _) -> true
+let rec stmt_does_call = function
+ | TSEmpty | TSReturn(None) -> false
+ | TSExpr(e) -> expr_does_call e
+ | TSIf (e, sa, sb) -> expr_does_call e || stmt_does_call sa || stmt_does_call sb
+ | TSWhile(e, s) -> expr_does_call e || stmt_does_call s
+ | TSFor(e, f, g, s) -> (List.exists expr_does_call e) || (match f with | None -> false | Some k -> expr_does_call k)
+ || (List.exists expr_does_call g) || stmt_does_call s
+ | TSBlock(k) -> List.exists stmt_does_call k
+ | TSReturn(Some k) -> expr_does_call k
+ | TSDeclare(TClass _, _) -> true
+ | TSDeclare (_, _) -> false
+ | TSDeclareAssignExpr(_, _, e) -> expr_does_call e
+ | TSDeclareAssignConstructor(_, _, _, _) -> true
+ | TSWriteCout(l) -> List.exists (function | TSEExpr e -> expr_does_call e | TSEStr _ -> false) l
+
+
+(* La génération de code, enfin ! *)
+
+(* Arguments de la fonction gen_expr :
+ - un environnement : permet de savoir plein de choses, par exemple combien de place est
+ utilisée sur la pile en-dessous de $fp
+ - une liste de registres disponnibles pour faire le calcul
+ *qui doit toujours contenir au moins un registre*
+ - une liste de registres à sauvegarder dans tous les cas
+ - l'expression pour laquelle on veut générer du code
+
+ À l'issue d'un appel à gen_expr, il y a plusieurs possibilités, exprimées
+ par le type union expr_type décrit ci-dessus :
+ - le premier registre de la liste des registres disponnibles (noté r) contient
+ une adresse qui est l'adresse de la valeur dénotée par l'expression
+ - la valeur dénotée est stockée dans x(reg) pour un certain reg et un certain x
+ - la valeur est stockée dans un certain registre a, qui est son
+ "registre de référence", ie si on doit affecter à cette valeur on peut
+ modifier ce registre
+ - la valeur est stockée dans le registre r
+ Dans tous les cas sauf le dernier, on peut modifier la valeur dénotée par
+ l'expression (par exemple lors d'une affectation).
+ Si le typage nous garantit que l'expression ne peut pas être affectée, on peut
+ utiliser l'artifice de dire qu'une valeur est placée dans un registre comme
+ "registre de référence" même lorsque ce n'est pas le cas (= jouer avec le feu).
+*)
+
+(* possibilités pour ce qui est généré par gen_expr *)
+type expr_type =
+ | Addr (* top register contains address of value *)
+ | AddrByReg of int * register (* value at int(register) *)
+ | Value of register (* other register is home to the value *)
+ | Copy (* top register contains copy of value *)
+
+(* on a fait un appel à gen_expr, maintenant on veut être sûr d'avoir
+ soit l'adresse soit la valeur dans tel ou tel registre *)
+let cla r a = match a with
+ | Addr -> nop
+ | AddrByReg(x, rg) -> la r areg (x, rg)
+ | Value r -> raise (Reference_register r)
+ | _ -> assert false
+let cr r a = match a with (* conditionnally read *)
+ | Addr -> lw r areg (0, r)
+ | AddrByReg(x, rg) -> lw r areg (x, rg)
+ | Copy -> nop
+ | Value k -> if r <> k then move r k else nop
+let crb r q a = match a with
+ | Value k -> q, k
+ | _ -> q ++ cr r a, r
+
+let spare_reg = s0
+let spare_reg2 = s1
+
+(* Cette fonction prévoit de l'espace sur la pile pour enregistrer les
+ valeurs de tous les registres save_regs à sauvegarder (elle donne un nouvel
+ environnement où la place nécessaire est réservée) et génère le code
+ nécessaire à la sauvegarde et à la restauration.
+ Le nouvel environnement est également modifié de manière à ce que de futurs
+ appels à des valeurs qui devaient être enregistrées dans des registres sauvegardés
+ soient maintenant fait en prenant en compte la relocalisation de ces valeurs
+ sur la pile. *)
+let saver env save_regs =
+ List.fold_left
+ (fun (code, more_code, env) r ->
+ let new_fp_used = env.c_fp_used + 4 in
+ let pos = - new_fp_used in
+ env.c_need_fp := true;
+ code ++ sw r areg (pos, fp), lw r areg (pos, fp) ++ more_code,
+ { env with
+ c_names = Smap.map
+ (function
+ | VRegister k when k = r -> VStack (pos)
+ | VRegisterByRef k when k = r -> VStackByRef(pos)
+ | a -> a) env.c_names;
+ c_fp_used = new_fp_used;
+ c_save_regs = (List.filter ((<>) r) env.c_save_regs) }
+ )
+ (nop, nop, env) save_regs
+
+(*
+ renvoie le résultat dans le premier registre de free_regs
+ ou autre (cf ci-dessus)
+*)
+let rec gen_expr env free_regs save_regs e =
+ (* register management *)
+ let r = List.hd free_regs in (* register where to put result *)
+ let more = List.tl free_regs in
+ (* generate the code... *)
+ match e.te_desc with
+ | TEInt(k) -> li r k, Copy
+ | TENull -> nop, Value zero
+ | TEThis -> (* convention : this is always the first argument, so in a0 *)
+ begin match Smap.find "this" env.c_names with
+ | VRegister(k) when k <> r -> nop, Value k
+ | VStack(i) -> nop, AddrByReg(i, fp)
+ | _ -> assert false
+ end
+ | TEIdent(i) ->
+ begin match Smap.find i env.c_names with
+ | VGlobal -> la r alab i, Addr
+ | VStack(i) -> nop, AddrByReg(i, fp)
+ | VStackByRef(i) -> lw r areg (i, fp), Addr
+ | VRegister(k) -> nop, Value k
+ | VRegisterByRef(k) -> nop, AddrByReg(0, k)
+ end
+ | TEAssign(e1, e2) ->
+ begin match more with
+ | [] ->
+ let t1, ae1 = gen_expr env free_regs save_regs e1 in
+ let env2, tspot = env_push 4 env in
+ let t2, ae2 = gen_expr env2 free_regs save_regs e2 in
+ let t2 = t2 ++ cr r ae2 in
+ begin match ae1 with
+ | Addr -> t1 ++ sw r areg (tspot, fp) ++ t2 ++ lw spare_reg areg (tspot, fp) ++ sw r areg (0, spare_reg), Copy
+ | AddrByReg (x, rg) when t1 = nop -> t2 ++ sw r areg (x, rg), Copy
+ | Value k when t1 = nop && k <> r -> t2 ++ move k r, Copy
+ | _ -> assert false
+ end
+ | b::_ ->
+ let t1, ae1 = gen_expr env more (r::save_regs) e1 in
+ let t2, ae2 = gen_expr env free_regs save_regs e2 in
+ let t2, r2 = crb r t2 ae2 in
+ let tr = if r2 = r then Copy else Value r2 in
+ begin match ae1 with
+ | Addr -> t2 ++ t1 ++ sw r2 areg (0, b), tr
+ | AddrByReg (x, rg) when t1 = nop -> t2 ++ sw r2 areg (x, rg), tr
+ | Value k when t1 = nop && k <> r2 -> t2 ++ move k r2, tr
+ | _ -> assert false
+ end
+ end
+ | TECallFun(id, args, b) ->
+ let keep_result_in_v0 = (not (List.mem v0 save_regs)) || r = v0 in
+ let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in
+ let args_code, _, env_args = code_for_args env_regs_saved args [ a0; a1; a2; a3 ] in
+ code_save_regs
+ ++ args_code
+ ++ la sp areg (-env_args.c_fp_used, fp) ++ jal id
+ ++ (if keep_result_in_v0 then nop else move r v0)
+ ++ code_restore_regs,
+ if b
+ then (if keep_result_in_v0 then AddrByReg (0, v0) else Addr)
+ else (if keep_result_in_v0 then Value(v0) else Copy)
+ | TECallVirtual(obj, fi, args, b) ->
+ let keep_result_in_v0 = (not (List.mem v0 save_regs)) || r = v0 in
+ let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in
+ let args_code, sr, env_args = code_for_args env_regs_saved ((obj, true)::args) [ a0; a1; a2; a3 ] in
+ code_save_regs
+ ++ args_code
+ ++ lw v0 areg (0, a0) ++ lw v0 areg (fi, v0)
+ ++ la sp areg (-env_args.c_fp_used, fp) ++ jalr v0
+ ++ (if keep_result_in_v0 then nop else move r v0)
+ ++ code_restore_regs,
+ if b
+ then (if keep_result_in_v0 then AddrByReg (0, v0) else Addr)
+ else (if keep_result_in_v0 then Value(v0) else Copy)
+ | TEUnary (x, e) ->
+ let t, a = gen_expr env free_regs save_regs e in
+ begin match x with
+ | Ast.Deref ->
+ begin match a with
+ | Value r -> t, AddrByReg (0, r)
+ | _ -> t ++ cr r a, Addr
+ end
+ | Ast.Ref ->
+ t ++ cla r a, Copy
+ | Ast.Plus -> t ++ cr r a, Copy
+ | Ast.Minus -> t ++ cr r a ++ neg r r, Copy
+ | Ast.Not -> t ++ cr r a ++ not_ r r, Copy
+ | Ast.PreIncr | Ast.PreDecr ->
+ let delta = if x = Ast.PreIncr then 1 else -1 in
+ begin match a with
+ | Addr ->
+ t ++ move spare_reg r ++ lw r areg (0, spare_reg)
+ ++ add r r oi delta ++ sw r areg (0, spare_reg), Copy
+ | AddrByReg (k, rg) when t = nop && r <> rg ->
+ lw r areg (k, rg)
+ ++ add r r oi delta ++ sw r areg (k, rg), Copy
+ | Value v when t = nop && v <> r ->
+ add v v oi delta ++ move r v, Copy
+ | _ -> assert false
+ end
+ | Ast.PostIncr | Ast.PostDecr ->
+ let delta = if x = Ast.PostIncr then 1 else -1 in
+ begin match a with
+ | Addr ->
+ t ++ move spare_reg r
+ ++ lw r areg(0, spare_reg)
+ ++ add spare_reg2 r oi delta
+ ++ sw spare_reg2 areg(0, spare_reg), Copy
+ | AddrByReg (k, rg) when t = nop && r <> rg ->
+ lw r areg (k, rg)
+ ++ add spare_reg r oi delta
+ ++ sw spare_reg areg (k, rg), Copy
+ | Value v when t = nop && v <> r ->
+ move r v ++ add v v oi delta, Copy
+ | _ -> assert false
+ end
+ end
+ | TEBinary(e1, op, e2) when op <> Ast.Lor && op <> Ast.Land ->
+ let rs, rb, precode = match more with
+ | [] ->
+ let env2, tspot = env_push 4 env in
+ let t1, ae1 = gen_expr env2 free_regs save_regs e1 in
+ let t2, ae2 = gen_expr env free_regs save_regs e2 in
+ let t1, r1 = crb r t1 ae1 in
+ let t2, r2 = crb r t2 ae2 in
+ r1, spare_reg, t2 ++ sw r2 areg (tspot, fp) ++ t1 ++ lw spare_reg areg (tspot, fp)
+ | b::_ ->
+ let t1, ae1 = gen_expr env free_regs save_regs e1 in
+ let t2, ae2 = gen_expr env more (r::save_regs) e2 in
+ let t1, rs = crb r t1 ae1 in
+ let t2, rb = crb b t2 ae2 in
+ rs, rb, t1 ++ t2
+ in
+ precode ++ (match op with
+ | Ast.Add -> add r rs oreg rb
+ | Ast.Sub -> sub r rs oreg rb
+ | Ast.Mul -> mul r rs oreg rb
+ | Ast.Div -> div r rs oreg rb
+ | Ast.Modulo -> rem r rs oreg rb
+ | Ast.Equal -> seq r rs rb
+ | Ast.NotEqual -> sne r rs rb
+ | Ast.Lt -> slt r rs rb
+ | Ast.Le -> sle r rs rb
+ | Ast.Gt -> sgt r rs rb
+ | Ast.Ge -> sge r rs rb
+ | _ -> assert false
+ ), Copy
+ | TEBinary(e1, op, e2) (* when op = Ast.Lor || op = Ast.Land *) ->
+ let t1, ae1 = gen_expr env free_regs save_regs e1 in
+ let t2, ae2 = gen_expr env free_regs save_regs e2 in
+ let t1 = t1 ++ cr r ae1 in
+ let t2 = t2 ++ cr r ae2 in
+ let lazy_lbl = id "_lazy" in
+ t1 ++ (if op = Ast.Lor then bnez r lazy_lbl else beqz r lazy_lbl)
+ ++ t2 ++ label lazy_lbl ++ sne r r zero, Copy
+ | TEMember(e, i) ->
+ let c, a = gen_expr env free_regs save_regs e in
+ if i <> 0 then begin
+ match a with
+ | Addr -> c ++ la r areg (i, r), Addr
+ | AddrByReg (k, rg) when c = nop -> nop, AddrByReg (k + i, rg)
+ | _ -> assert false
+ end else
+ c, a
+ | TEPointerCast(e, i) ->
+ let c, a = gen_expr env free_regs save_regs e in
+ c ++ cr r a ++ (if i = 0 then nop else la r areg (i, r)), Copy
+ | TENew(cls, constr, args) ->
+ let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in
+ let args_code, _, env_args = code_for_args env_regs_saved args [ a1; a2; a3 ] in
+ code_save_regs ++ args_code
+ ++ li v0 9 ++ li a0 cls.tc_size ++ syscall ++ move a0 v0
+ ++ la sp areg (-env_args.c_fp_used, fp) ++ jal constr
+ ++ (if r <> a0 then move r a0 else nop) ++ code_restore_regs, Copy
+and code_for_args env arg_list regs =
+ (* assigne registers to possibly in-register arguments *)
+ let args_in_regs, args_in_stack, _ = List.fold_left
+ (fun (ir, is, fr) (arg, byref) ->
+ match fr with
+ | [] -> ir, (arg, byref)::is, []
+ | r::nfr -> (r, (arg, byref))::ir, is, nfr)
+ ([], [], regs) arg_list in
+ (* allocate stack for remaining args *)
+ let stack_use = 4 * List.length args_in_stack in
+ let kenv, _ = env_push stack_use env in
+ (* make code for in-stack arguments *)
+ let args_in_stack = List.rev args_in_stack in
+ let code_for_stack, _ = List.fold_left
+ (fun (code, u) (arg, byref) ->
+ let c, addr = gen_expr kenv (v0::kenv.c_free_regs) [] arg in
+ (if byref then
+ c ++ cla v0 addr ++ sw v0 areg (-kenv.c_fp_used + u, fp) ++ code, u+4
+ else
+ let c, freg = crb v0 c addr in
+ c ++ sw freg areg (-kenv.c_fp_used + u, fp) ++ code, u+4
+ )
+ ) (nop, 0) args_in_stack in
+ (* make code for in-register arguments *)
+ let arg_reg_do_call, arg_reg_dont_call =
+ List.partition (fun (_, (e, _)) -> expr_does_call e) args_in_regs in
+ let rec mk_code_callz e = function
+ | [] -> nop
+ | (reg, (expr, byref))::more_args ->
+ let c, addr = gen_expr e (reg::kenv.c_free_regs) [] expr in
+ if more_args = [] then
+ c ++ (if byref then cla reg addr else cr reg addr)
+ else
+ let e2, pos = env_push 4 e in
+ (if byref then
+ c ++ cla reg addr ++ sw reg areg (pos, fp)
+ else
+ let tt, r2 = crb reg c addr in
+ tt ++ sw r2 areg (pos, fp))
+ ++ (mk_code_callz e2 more_args) ++ lw reg areg (pos, fp)
+ in
+ let code_reg_do_call = mk_code_callz kenv arg_reg_do_call in
+ let code_reg_dont_call, _ =
+ List.fold_left
+ (fun (code, ur) (reg, (expr, byref)) ->
+ let c, addr = gen_expr kenv (reg::kenv.c_free_regs) ur expr in
+ code ++ c ++ (if byref then cla reg addr else cr reg addr), reg::ur)
+ (nop, []) arg_reg_dont_call
+ in
+ let code = code_for_stack ++ code_reg_do_call ++ code_reg_dont_call
+ in code, (List.map fst args_in_regs), kenv
+
+
+let gen_expr_dr dr env = gen_expr env (dr::env.c_free_regs) env.c_save_regs
+let gen_expr_v0 = gen_expr_dr v0
+
+let rec gen_stmt alloc_vars_in_regs env = function
+ | TSEmpty -> nop, env
+ | TSExpr(e) ->
+ comment "expr" ++ (fst (gen_expr_v0 env e)), env
+ | TSIf(cond, s1, s2) ->
+ let c, a = gen_expr_v0 env cond in
+ let c, reg = crb v0 c a in
+ let l_else = id "_cond_else" in
+ let l_end = id "_cond_end" in
+ let c_then = gen_block env [s1] in
+ let c_else = gen_block env [s2] in
+ comment "if"
+ ++ c ++ beqz reg l_else
+ ++ c_then ++ b l_end
+ ++ label l_else ++ c_else
+ ++ label l_end, env
+ | TSWhile(cond, body) ->
+ let c, a = gen_expr_v0 env cond in
+ let c, reg = crb v0 c a in
+ let l_begin = id "_while_begin" in
+ let l_cond = id "_while_cond" in
+ let c_body = gen_block env [body] in
+ comment "while" ++ b l_cond
+ ++ label l_begin ++ c_body
+ ++ label l_cond ++ c ++ bnez reg l_begin, 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_v0 env expr in code ++ c) nop before in
+ let c_after = List.fold_left
+ (fun code expr -> let c, _ = gen_expr_v0 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_v0 env x in
+ let c, reg = crb v0 c a in
+ c ++ bnez reg l_begin in
+ let c_body = gen_block env [body] in
+ comment "for"
+ ++ c_before ++ b l_cond
+ ++ label l_begin ++ c_body ++ c_after
+ ++ label l_cond ++ c_cond, env
+ | TSBlock(b) ->
+ let c = gen_block env b in
+ comment "block" ++ c, env
+ | TSReturn (None) ->
+ comment "return" ++ b env.c_ret_lbl, env
+ | TSReturn (Some e) ->
+ let c, a = gen_expr_v0 env e in
+ comment "return"
+ ++ c ++ (if env.c_ret_ref then cla v0 a else cr v0 a)
+ ++ b env.c_ret_lbl, env
+ | TSDeclare (ty, id) ->
+ if num ty && alloc_vars_in_regs && List.length env.c_free_regs > 5 then
+ (* allocate variable in register *)
+ let env2, reg = env_get_free_reg env in
+ comment ("declare " ^ id) ++ move reg zero,
+ env_add_var id (VRegister reg) env2
+ else
+ let s = type_size env.c_penv ty in
+ let env2, pos = env_push s env 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
+ let code_save_regs, code_restore_regs, env_regs_saved = saver env2 env.c_save_regs in
+ code_save_regs
+ ++ la a0 areg (pos, fp)
+ ++ la sp areg (-env_regs_saved.c_fp_used, fp) ++ jal cproto.tp_unique_ident
+ ++ code_restore_regs
+ | _ -> sw zero areg (pos, fp)
+ in
+ comment ("declare " ^ id) ++ code,
+ env_add_var id (VStack pos) env2
+ | TSDeclareAssignConstructor(cls, id, constr, args) ->
+ let env2, pos = env_push cls.tc_size env in
+ let code =
+ let code_save_regs, code_restore_regs, env_regs_saved = saver env2 env.c_save_regs in
+ let args_code, _, env_args = code_for_args env_regs_saved args [ a1; a2; a3 ] in
+ code_save_regs
+ ++ args_code ++ la a0 areg(pos, fp)
+ ++ la sp areg (-env_args.c_fp_used, fp) ++ jal constr
+ ++ code_restore_regs
+ in
+ comment ("declare " ^ id) ++ code,
+ env_add_var id (VStack pos) env2
+ | TSDeclareAssignExpr ((ty, ref), id, e) ->
+ assert (ref || num ty);
+ if alloc_vars_in_regs && List.length env.c_free_regs > 5 then
+ (* allocate variable in register *)
+ let env2, reg = env_get_free_reg env in
+ let code, a = gen_expr env (reg::env2.c_free_regs) env.c_save_regs e in
+ comment ("declare " ^ id)
+ ++ code ++ (if ref then cla reg a else cr reg a),
+ env_add_var id (if ref then VRegisterByRef reg else VRegister reg) env2
+ else
+ let code, a = gen_expr_v0 env e in
+ let env2, pos = env_push 4 env in
+ comment ("declare " ^ id)
+ ++ (if ref then
+ code ++ cla v0 a ++ sw v0 areg (pos, fp)
+ else
+ let k, b = crb v0 code a in
+ k ++ sw b areg (pos, fp)
+ ),
+ env_add_var id (if ref then VStackByRef pos else VStack pos) env2
+ | TSWriteCout(sl) ->
+ let save_code, restore_code, env2 = saver env
+ (if List.mem a0 env.c_save_regs then [a0] else []) in
+ let text1 = List.fold_left
+ (fun text -> function
+ | TSEExpr(e) ->
+ let t, a = gen_expr_dr a0 env2 e in
+ text ++ t ++ cr a0 a ++ li v0 1 ++ syscall
+ | TSEStr(s) ->
+ let l =
+ if Hashtbl.mem strings s then
+ Hashtbl.find strings s
+ else
+ let l = id "_s" in Hashtbl.add strings s l;
+ l
+ in
+ text ++ la a0 alab l ++ li v0 4 ++ syscall)
+ nop sl in
+ comment "cout<<..."
+ ++ save_code ++ text1 ++ restore_code, env
+and gen_block env b =
+ let rec fold env = function
+ | [] -> nop
+ | stmt::next ->
+ let does_call_after = List.exists stmt_does_call next in
+ try
+ let tt, ee = gen_stmt (not does_call_after) env stmt in
+ let more_code = fold ee next in
+ tt ++ more_code
+ with Reference_register _ ->
+ let tt, ee = gen_stmt false env stmt in
+ let more_code = fold ee next in
+ tt ++ more_code
+ in
+ fold env b
+
+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 regs_for_args, env0 = match proto.tp_class with
+ | None -> [ a0; a1; a2; a3 ], !globals_env
+ | Some k -> [ a1; a2; a3 ], Smap.add "this" (VRegister a0) !globals_env
+ in
+ let need_fp = ref false in
+ let names, _, free_regs = List.fold_left
+ (fun (env, p, regs) ((ty, r), id) ->
+ assert (r || type_size tenv ty = 4);
+ match regs with
+ | reg::more_regs ->
+ Smap.add id (if r then VRegisterByRef reg else VRegister reg) env, p, more_regs
+ | [] -> need_fp := true;
+ Smap.add id (if r then VStackByRef p else VStack p) env, p + 4, regs
+ )
+ (env0, 0, regs_for_args) 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_ret_lbl = "_return_" ^ proto.tp_unique_ident;
+ c_fp_used = 8;
+ c_need_fp = need_fp;
+ c_free_regs = [ t0; t1; t2; t3; t4; t5; t6; t7; t8; t9; v1 ];
+ c_save_regs = List.filter (fun r -> not (List.mem r free_regs)) [a0; a1; a2; a3];
+ } in
+ let code_for_constructor, does_calls = match proto.tp_ret_type with
+ | Some _ -> nop, (List.exists stmt_does_call block)
+ | None -> let cls_name = (match proto.tp_class with | Some k -> k | None -> assert false) in
+ la sp areg (-8, fp) ++ jal (cls_name ^ "0"), true
+ in
+ let code_for_virtual = match proto.tp_virtual with
+ | Some (c, _) when c.h_pos <> 0 ->
+ la a0 areg (-c.h_pos, a0)
+ | _ -> nop
+ in
+ if does_calls
+ then
+ let save_code, unsave_code, env2 =
+ saver env (List.filter (fun x -> x <> a0 || proto.tp_class = None) env.c_save_regs)
+ in
+ let text = gen_block env2 block in
+ label proto.tp_unique_ident
+ ++ sw fp areg (-4, sp) ++ sw ra areg (-8, sp) ++ move fp sp
+ ++ code_for_virtual ++ save_code ++ code_for_constructor ++ text
+ ++ label env.c_ret_lbl ++ move sp fp ++ lw fp areg (-4, sp) ++ lw ra areg (-8, sp)
+ ++ jr ra, nop
+ else
+ let rec bb_fp e =
+ try
+ gen_block e block
+ with Reference_register r ->
+ let save_code, _, env2 = saver env [r] in
+ save_code ++ bb_fp env2
+ in
+ let text = bb_fp env in
+ label proto.tp_unique_ident
+ ++ (if !need_fp then sw fp areg (-4, sp) ++ move fp sp else nop)
+ ++ code_for_virtual ++ text
+ ++ label env.c_ret_lbl ++ (if !need_fp then move sp fp ++ lw fp areg (-4, sp) else nop)
+ ++ jr ra, nop
+ | TDClass(c) ->
+ let constructor_calls_something = ref false in
+ (* 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
+ constructor_calls_something := true;
+ code ++ (if parent.h_pos <> 0 then la a0 areg(parent.h_pos, a0) else nop)
+ ++ jal proto.tp_unique_ident ++ (if parent.h_pos <> 0 then lw a0 areg (-12, fp) else nop))
+ nop c.tc_hier.h_supers 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 nop
+ else la a1 alab ("_vt_" ^ c.tc_name ^ "_as_" ^ hh.h_class)
+ ++ sw a1 areg (hh.h_pos, a0) in
+ (* code for subclasses vtable 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
+ (* Initialize members *)
+ let init_code_proper = Smap.fold
+ (fun _ (ty, pos) code ->
+ 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
+ constructor_calls_something := true;
+ (if pos <> 0 then la a0 areg (pos, a0) else nop)
+ ++ la sp areg (-12, fp)
+ ++ jal proto.tp_unique_ident
+ ++ (if pos <> 0 then lw a0 areg (-12, fp) else nop)
+ | _ -> sw zero areg (pos, a0)))
+ c.tc_members nop
+ in (* Put it all together *)
+ label (c.tc_name ^ "0")
+ ++ (if !constructor_calls_something then
+ sw fp areg (-4, sp) ++ move fp sp ++ sw ra areg (-8, fp)
+ ++ sw a0 areg (-12, fp) ++ la sp areg (-12, fp)
+ else nop)
+ ++ code_parents ++ vtable_init_code ++ init_code_proper
+ ++ (if !constructor_calls_something then
+ lw ra areg (-8, fp) ++ move sp fp ++ lw fp areg (-4, sp)
+ else nop)
+ ++ 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 "_nothing" ++ jr ra
+ ++ text in
+ let str = Hashtbl.fold
+ (fun str lbl data -> data ++ label lbl ++ asciiz str)
+ strings nop in
+ { text = text;
+ data = data ++ str }
+ 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/mips.ml b/src/mips.ml
index 5fe310c..0359728 100644
--- a/src/mips.ml
+++ b/src/mips.ml
@@ -17,6 +17,12 @@ let t0 : register = "$t0"
let t1 : register = "$t1"
let t2 : register = "$t2"
let t3 : register = "$t3"
+let t4 : register = "$t4"
+let t5 : register = "$t5"
+let t6 : register = "$t6"
+let t7 : register = "$t7"
+let t8 : register = "$t8"
+let t9 : register = "$t9"
let s0 : register = "$s0"
let s1 : register = "$s1"
let ra : register = "$ra"
diff --git a/src/mips.mli b/src/mips.mli
index a42f1ce..f1e39d6 100644
--- a/src/mips.mli
+++ b/src/mips.mli
@@ -57,6 +57,12 @@ val t0 : register
val t1 : register
val t2 : register
val t3 : register
+val t4 : register
+val t5 : register
+val t6 : register
+val t7 : register
+val t8 : register
+val t9 : register
val s0 : register
val s1 : register
val ra : register
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 c76c042..7a76b69 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 *)
@@ -96,7 +93,7 @@ and tproto = {
and tcls_supers = tcls_hier list
and tcls_hier = {
h_class : tident;
- h_pos : int;
+ mutable h_pos : int;
mutable h_vtable : (int * tproto) list; (* only to be muted during class definition parsing *)
h_supers : tcls_supers
}
@@ -130,6 +127,7 @@ type tdeclaration =
type tprogram = {
prog_decls : tdeclaration list;
prog_env : env;
+ prog_main : ident;
}
(* Quelques fonctions utiles : *)
@@ -183,10 +181,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
@@ -314,7 +347,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 ->
@@ -339,14 +372,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
@@ -357,8 +393,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
@@ -367,7 +407,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) ->
@@ -375,22 +419,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) ->
@@ -409,14 +458,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
@@ -428,9 +476,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
@@ -470,9 +516,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";
@@ -480,7 +527,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";
@@ -492,15 +539,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 =
@@ -559,7 +605,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 ;
@@ -649,22 +694,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);
@@ -674,12 +716,36 @@ 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
+ (* if vtable is empty, remove it *)
+ let mem, mem_u =
+ if hier.h_vtable = [] then
+ let rec mv_h h =
+ h.h_pos <- h.h_pos - 4;
+ List.iter mv_h h.h_supers
+ in
+ List.iter mv_h hier.h_supers;
+ Smap.map (fun (ty, pos) -> (ty, pos-4)) mem, mem_u - 4
+ else
+ mem, mem_u
+ in
{ tc_name = cls_name;
tc_size = mem_u;
tc_hier = hier;
@@ -751,11 +817,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 18:00:01 +0000