Commit c6e03578 authored by Armillon Damien's avatar Armillon Damien
Browse files

Function call to cfg

parent 8c2b101f
......@@ -26,3 +26,6 @@ clean:
test: main.native
make -C tests
testFun: main.native
make -C tests DIR=funcall/*.e
\ No newline at end of file
......@@ -11,6 +11,7 @@ non-terminals MUL_EXPRS MUL_EXPR
non-terminals CMP_EXPRS CMP_EXPR
non-terminals EQ_EXPRS EQ_EXPR
non-terminals BLOC
non-terminals IN_INSTR L_CALL_PARAMS REST_CALL_PARAMS FACTORS FUN_CALL_EXPRS FUN_CALL_EXPR FACTOR_IDENTIFIER
axiom S
{
......@@ -37,14 +38,20 @@ LPARAMS -> {[]}
LPARAMS -> SYM_IDENTIFIER REST_PARAMS {(Node(Targ, [StringLeaf($1)])) :: $2}
REST_PARAMS -> SYM_COMMA SYM_IDENTIFIER REST_PARAMS {(Node(Targ, [StringLeaf($2)])):: $3}
REST_PARAMS -> {[]}
L_CALL_PARAMS -> {[]}
L_CALL_PARAMS -> EXPR REST_CALL_PARAMS {[Node(Targs, $1::$2)]}
REST_CALL_PARAMS -> {[]}
REST_CALL_PARAMS -> SYM_COMMA EXPR REST_CALL_PARAMS {$2::$3}
IN_INSTR -> SYM_LPARENTHESIS L_CALL_PARAMS SYM_RPARENTHESIS SYM_SEMICOLON {fun x -> Node(Tcall, (StringLeaf x)::$2)}
IN_INSTR -> SYM_ASSIGN EXPR SYM_SEMICOLON {fun x -> Node(Tassign, [Node(Tassignvar,[StringLeaf(x); $2])])}
INSTRS -> {[]}
INSTRS -> INSTR INSTRS {$1::$2}
INSTR -> BLOC {$1}
INSTR -> SYM_IDENTIFIER IN_INSTR {$2 $1}
INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC ELSE {Node(Tif, $3::$5::$6)}
INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC {Node(Twhile, [$3;$5])}
INSTR -> SYM_RETURN EXPR SYM_SEMICOLON {Node(Treturn, [$2])}
INSTR -> SYM_PRINT SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_SEMICOLON {Node(Tprint, [$3])}
INSTR -> SYM_IDENTIFIER SYM_ASSIGN EXPR SYM_SEMICOLON {Node(Tassign, [Node(Tassignvar,[StringLeaf($1);$3])])}
ELSE -> SYM_ELSE BLOC {[$2]}
ELSE -> {[]}
EXPR -> EQ_EXPR EQ_EXPRS {resolve_associativity $1 $2}
......@@ -66,8 +73,14 @@ MUL_EXPRS -> SYM_ASTERISK MUL_EXPR MUL_EXPRS {(Tmul, [$2])::$3}
MUL_EXPRS -> SYM_DIV MUL_EXPR MUL_EXPRS {(Tdiv, [$2])::$3}
MUL_EXPRS -> SYM_MOD MUL_EXPR MUL_EXPRS {(Tmod, [$2])::$3}
MUL_EXPRS -> {[]}
MUL_EXPR -> FACTOR {$1}
MUL_EXPR -> SYM_MINUS FACTOR {Node(Tneg,[$2])}
MUL_EXPR -> FACTORS { $1 }
FUN_CALL_EXPRS -> SYM_IDENTIFIER SYM_LPARENTHESIS SYM_RPARENTHESIS {[(Tcall,[])]}
FUN_CALL_EXPRS -> {[]}
FUN_CALL_EXPR -> FACTORS {$1}
FACTORS -> FACTOR {$1}
FACTORS -> SYM_MINUS FACTOR {Node(Tneg,[$2])}
FACTOR_IDENTIFIER -> {fun x -> StringLeaf(x)}
FACTOR_IDENTIFIER -> SYM_LPARENTHESIS L_CALL_PARAMS SYM_RPARENTHESIS {fun x -> Node(Tcall, (StringLeaf x)::$2)}
FACTOR -> SYM_INTEGER {Node(Tint,[IntLeaf($1)])}
FACTOR -> SYM_IDENTIFIER {StringLeaf($1)}
FACTOR -> SYM_IDENTIFIER FACTOR_IDENTIFIER {$2 $1}
FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS {$2}
......@@ -31,7 +31,7 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tprint
| Tlistglobdef
| Tfundef | Tfunname | Tfunargs | Tfunbody
| Tassignvar
| Targ
| Targ | Tcall | Targs
type tree = | Node of tag * tree list
| StringLeaf of string
......@@ -74,6 +74,8 @@ let string_of_tag = function
| Tfunbody -> "Tfunbody"
| Tassignvar -> "Tassignvar"
| Targ -> "Targ"
| Tcall -> "Tcall"
| Targs -> "Targs"
(* Écrit un fichier .dot qui correspond à un AST *)
......
......@@ -9,6 +9,7 @@ type expr =
| Eunop of unop * expr
| Eint of int
| Evar of string
| Ecall of string * expr list
type cfg_node =
| Cassign of string * expr * int
......@@ -16,6 +17,7 @@ type cfg_node =
| Cprint of expr * int
| Ccmp of expr * int * int
| Cnop of int
| Ccall of string * expr list * int
type cfg_fun = {
cfgfunargs: string list;
......@@ -36,6 +38,7 @@ let succs cfg n =
| Some (Creturn _) -> Set.empty
| Some (Ccmp (_, s1, s2)) -> Set.of_list [s1;s2]
| Some (Cnop s) -> Set.singleton s
| Some (Ccall (_,_,s)) -> Set.singleton s
(* [preds cfg n] donne l'ensemble des prédécesseurs d'un nœud [n] dans un CFG [cfg]
......@@ -45,6 +48,7 @@ let preds cfgfunbody n =
match m' with
| Cassign (_, _, s)
| Cprint (_, s)
| Ccall (_,_,s)
| Cnop s -> if s = n then Set.add m acc else acc
| Creturn _ -> acc
| Ccmp (_, s1, s2) -> if s1 = n || s2 = n then Set.add m acc else acc
......@@ -63,6 +67,7 @@ let rec size_expr (e: expr) : int =
| Eunop (u, e) -> size_unop u (size_expr e)
| Eint _ -> 1
| Evar v -> 1
| Ecall (n, el) -> 1 + List.fold_left (fun acc e -> acc + (size_expr e)) 0 el
let rec size_instr (i: cfg_node) : int =
match (i : cfg_node) with
......@@ -71,6 +76,7 @@ let rec size_instr (i: cfg_node) : int =
| Cprint (e, s) -> 1 + (size_expr e)
| Ccmp (e, s1, s2) -> 1 + size_expr e
| Cnop s -> 1
| Ccall (n, el, s) -> 1 + List.fold_left (fun acc e -> acc + (size_expr e)) 0 el
let size_fun f =
Hashtbl.fold (fun k v acc -> acc + size_instr v) f 0
......
......@@ -11,10 +11,20 @@ open Options
(* [simple_eval_eexpr e] evaluates an expression [e] with no variables. Raises
an exception if the expression contains variables. *)
let rec simple_eval_eexpr (e: expr) : int =
let st = init_state 0 in
match eval_cfgexpr st e with
| OK result -> Printf.printf "%d\n" result;result
| Error s -> failwith "There was a var"
match e with
| Ebinop(b, e1, e2) ->
let v1 = simple_eval_eexpr e1 in
let v2 = simple_eval_eexpr e2 in
let v = eval_binop b v1 v2 in
v
| Eunop(u, e) ->
let v1 = simple_eval_eexpr e in
let v = (eval_unop u v1) in
v
| Eint i -> i
| Ecall (name,_) -> failwith (Printf.sprintf "tried to call %s" name)
| _ -> failwith "unevaluable expr (const propagation)"
(* If an expression contains variables, we cannot simply evaluate it. *)
......@@ -25,6 +35,7 @@ let rec has_vars (e: expr) =
| Evar(str) -> true
| Eunop(_,e') -> has_vars e'
| Ebinop(_,e',e'') -> has_vars e' || has_vars e''
| Ecall(_,el) -> true
let const_prop_binop b e1 e2 =
let e = Ebinop (b, e1, e2) in
......@@ -42,7 +53,12 @@ let const_prop_unop u e =
let rec const_prop_expr (e: expr) =
if has_vars e
then e
else Eint (simple_eval_eexpr e)
else match e with
| Ebinop(_,_,_)
| Eunop(_,_)
| Eint(_) -> Eint (simple_eval_eexpr e)
| Ecall(name,el) -> Ecall(name, List.map const_prop_expr el)
| _ -> e
let constant_propagation_instr (i: cfg_node) : cfg_node =
match i with
......@@ -51,6 +67,7 @@ let constant_propagation_instr (i: cfg_node) : cfg_node =
| Cprint(e, n) -> Cprint(const_prop_expr e, n)
| Ccmp(e,n,n') -> Ccmp(const_prop_expr e, n, n')
| Cnop(n) -> Cnop(n)
| Ccall(str, el, n) -> Ccall(str, List.map const_prop_expr el, n)
let constant_propagation_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
let ht = Hashtbl.map (fun n m ->
......
......@@ -25,7 +25,9 @@ let rec cfg_expr_of_eexpr (e: Elang.expr) : expr res =
| Elang.Eint i -> OK (Eint i)
| Elang.Evar v ->
OK (Evar v)
| Elang.Ecall(name, elist) ->
let* args_expr = list_map_res (cfg_expr_of_eexpr) elist in
OK(Cfg.Ecall(name, args_expr))
(* [cfg_node_of_einstr next cfg succ i] builds the CFG node(s) that correspond
to the E instruction [i].
......@@ -55,7 +57,7 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
Hashtbl.replace cfg next (Ccmp(c, nthen, nelse)); OK (next, next + 1)
| Elang.Iwhile (c, i) ->
cfg_expr_of_eexpr c >>= fun c ->
let (cmp, next) = (next, next+1) in
let (cmp, next) = (next, next + 1) in
cfg_node_of_einstr next cfg cmp i >>= fun (nthen, next) ->
Hashtbl.replace cfg cmp (Ccmp(c, nthen, succ)); OK (cmp, next + 1)
| Elang.Iblock il ->
......@@ -70,6 +72,11 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
cfg_expr_of_eexpr e >>= fun e ->
Hashtbl.replace cfg next (Cprint (e,succ));
OK (next, next + 1)
| Elang.Icall(name, elist) ->
let* args_expr = list_map_res (cfg_expr_of_eexpr) elist in
Hashtbl.replace cfg next (Ccall(name, args_expr, succ));
OK (next,next+1)
(* Some nodes may be unreachable after the CFG is entirely generated. The
[reachable_nodes n cfg] constructs the set of node identifiers that are
......@@ -82,6 +89,7 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) =
| None -> reach
| Some (Cnop succ)
| Some (Cprint (_, succ))
| Some (Ccall(_,_,succ))
| Some (Cassign (_, _, succ)) -> reachable_aux succ reach
| Some (Creturn _) -> reach
| Some (Ccmp (_, s1, s2)) ->
......
......@@ -12,6 +12,7 @@ let rec vars_in_expr (e: expr) =
| Eint(i) -> Set.empty
| Eunop(_,e1) -> vars_in_expr e1
| Ebinop(_,e1,e2) -> Set.union (vars_in_expr e1) (vars_in_expr e2)
| Ecall(_,el) -> List.fold_left (fun acc expr -> Set.union acc (vars_in_expr expr)) Set.empty el
(* [live_cfg_node node live_after] renvoie l'ensemble des variables vivantes
avant un nœud [node], étant donné l'ensemble [live_after] des variables
......@@ -20,9 +21,11 @@ let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
match node with
| Cnop(n) -> live_after
| Cassign(str, e,n) -> Set.union (vars_in_expr e) (Set.diff live_after (Set.singleton str))
| Creturn(e) -> Set.union (vars_in_expr e) live_after
| Cprint(e,n) -> Set.union (vars_in_expr e) live_after
| Ccmp(e,n,n') -> Set.union (vars_in_expr e) live_after
| Creturn(e)
| Cprint(e,_)
| Ccmp(e,_,_) -> Set.union (vars_in_expr e) live_after
| Ccall(str, el, n) -> List.fold_left (fun acc expr -> Set.union acc (vars_in_expr expr)) live_after el
(* [live_after_node cfg n] renvoie l'ensemble des variables vivantes après le
......
......@@ -9,8 +9,9 @@ let rec dump_cfgexpr : expr -> string = function
| Eunop(u, e) -> Format.sprintf "(%s %s)" (dump_unop u) (dump_cfgexpr e)
| Eint i -> Format.sprintf "%d" i
| Evar s -> Format.sprintf "%s" s
| Ecall (name,el) -> Format.sprintf "%s(%s)" name (dump_list_cfgexpr el)
let dump_list_cfgexpr l =
and dump_list_cfgexpr l =
l |> List.map dump_cfgexpr |> String.concat ", "
......@@ -18,6 +19,7 @@ let dump_arrows oc fname n (node: cfg_node) =
match node with
| Cassign (_, _, succ)
| Cprint (_, succ)
| Ccall (_,_,succ)
| Cnop succ ->
Format.fprintf oc "n_%s_%d -> n_%s_%d\n" fname n fname succ
| Creturn _ -> ()
......@@ -33,6 +35,7 @@ let dump_cfg_node oc (node: cfg_node) =
| Creturn e -> Format.fprintf oc "return %s" (dump_cfgexpr e)
| Ccmp (e, _, _) -> Format.fprintf oc "%s" (dump_cfgexpr e)
| Cnop _ -> Format.fprintf oc "nop"
| Ccall (n,el,_) -> Format.fprintf oc "%s(%s)" n (dump_list_cfgexpr el)
let dump_liveness_state oc ht state =
......
......@@ -7,52 +7,76 @@ open Cfg
open Utils
open Builtins
let rec eval_cfgexpr st (e: expr) : int res =
let rec eval_cfgexpr oc cp st (e: expr) : (int * int Prog.state) res =
match e with
| Ebinop(b, e1, e2) ->
eval_cfgexpr st e1 >>= fun v1 ->
eval_cfgexpr st e2 >>= fun v2 ->
let* (v1, st) = eval_cfgexpr oc cp st e1 in
let* (v2, st) = eval_cfgexpr oc cp st e2 in
let v = eval_binop b v1 v2 in
OK v
OK (v, st)
| Eunop(u, e) ->
eval_cfgexpr st e >>= fun v1 ->
let* (v1,st) = eval_cfgexpr oc cp st e in
let v = (eval_unop u v1) in
OK v
| Eint i -> OK i
OK (v, st)
| Eint i -> OK (i, st)
| Evar s ->
begin match Hashtbl.find_option st.env s with
| Some v -> OK v
| Some v -> OK (v, st)
| None -> Error (Printf.sprintf "Unknown variable %s\n" s)
end
| Ecall(name,el) ->
let* f = find_function cp name in
let* (params, st) = List.fold_left (fun acc expr ->
let* (expr_list,st) = acc in
let* (new_expr, st) = eval_cfgexpr oc cp st expr in
OK(expr_list@[new_expr], st)
) (OK([],st)) el in
let* (i,st) = eval_cfgfun cp oc st name f params in
match i with
| None -> Error (Printf.sprintf "Error while runing %s" name)
| Some(i) -> OK(i,st)
let rec eval_cfginstr oc st ht (n: int): (int * int state) res =
and eval_cfginstr cp oc st ht (n: int): (int * int state) res =
match Hashtbl.find_option ht n with
| None -> Error (Printf.sprintf "Invalid node identifier\n")
| Some node ->
match node with
| Cnop succ ->
eval_cfginstr oc st ht succ
eval_cfginstr cp oc st ht succ
| Cassign(v, e, succ) ->
eval_cfgexpr st e >>= fun i ->
let* (i, st) = eval_cfgexpr oc cp st e in
Hashtbl.replace st.env v i;
eval_cfginstr oc st ht succ
eval_cfginstr cp oc st ht succ
| Ccmp(cond, i1, i2) ->
eval_cfgexpr st cond >>= fun i ->
if i = 0 then eval_cfginstr oc st ht i2 else eval_cfginstr oc st ht i1
let* (i,st) = eval_cfgexpr oc cp st cond in
if i = 0 then eval_cfginstr cp oc st ht i2 else eval_cfginstr cp oc st ht i1
| Creturn(e) ->
eval_cfgexpr st e >>= fun e ->
let* (e,st) = eval_cfgexpr oc cp st e in
OK (e, st)
| Cprint(e, succ) ->
eval_cfgexpr st e >>= fun e ->
let* (e, st) = eval_cfgexpr oc cp st e in
Format.fprintf oc "%d\n" e;
eval_cfginstr oc st ht succ
eval_cfginstr cp oc st ht succ
| Ccall(name, el, s) ->
let* f = find_function cp name in
let* (params, st) = List.fold_left (fun acc expr ->
let* (expr_list,st) = acc in
let* (new_expr, st) = eval_cfgexpr oc cp st expr in
OK(expr_list@[new_expr], st)
) (OK([],st)) el in
let* (i,st) = eval_cfgfun cp oc st name f params in
match i with
| None -> Error (Printf.sprintf "Error while runing %s" name)
| Some(i) -> OK(i,st)
let eval_cfgfun oc st cfgfunname { cfgfunargs;
and eval_cfgfun cp oc st cfgfunname { cfgfunargs;
cfgfunbody;
cfgentry} vargs =
let st' = { st with env = Hashtbl.create 17 } in
match List.iter2 (fun a v -> Hashtbl.replace st'.env a v) cfgfunargs vargs with
| () -> eval_cfginstr oc st' cfgfunbody cfgentry >>= fun (v, st') ->
| () -> eval_cfginstr cp oc st' cfgfunbody cfgentry >>= fun (v, st') ->
OK (Some v, {st' with env = st.env})
| exception Invalid_argument _ ->
Error (Format.sprintf "CFG: Called function %s with %d arguments, expected %d.\n"
......@@ -64,7 +88,7 @@ let eval_cfgprog oc cp memsize params =
find_function cp "main" >>= fun f ->
let n = List.length f.cfgfunargs in
let params = take n params in
eval_cfgfun oc st "main" f params >>= fun (v, st) ->
eval_cfgfun cp oc st "main" f params >>= fun (v, st) ->
OK v
......@@ -74,7 +74,7 @@ let list_regexp : (regexp * (string -> token option)) list =
(keyword_regexp "if", fun s -> Some (SYM_IF));
(keyword_regexp "else", fun s -> Some (SYM_ELSE));
(keyword_regexp "return", fun s -> Some (SYM_RETURN));
(keyword_regexp "print", fun s -> Some (SYM_PRINT));
(* (keyword_regexp "print", fun s -> Some (SYM_PRINT)); *)
(keyword_regexp "struct", fun s -> Some (SYM_STRUCT));
(keyword_regexp ".", fun s -> Some (SYM_POINT));
(keyword_regexp "+", fun s -> Some (SYM_PLUS));
......
......@@ -12,6 +12,7 @@ type expr =
| Eunop of unop * expr
| Eint of int
| Evar of string
| Ecall of string * expr list
type instr =
| Iassign of string * expr
......@@ -20,6 +21,7 @@ type instr =
| Iblock of instr list
| Ireturn of expr
| Iprint of expr
| Icall of string * expr list
type efun = {
funargs: ( string ) list;
......
......@@ -45,7 +45,7 @@ let tag_is_unary_inst =
| Tprint -> true
| _ -> false
let uniinst_of_tag e=
let uniinst_of_tag e =
function
Treturn -> Ireturn e
| Tprint -> Iprint e
......@@ -57,6 +57,14 @@ let uniinst_of_tag e=
let rec make_eexpr_of_ast (a: tree) : expr res =
let res =
match a with
| Node(Tcall, StringLeaf(name)::r) ->
let args_list = (match r with
| Node(Targs, l )::[] -> l
| _ -> []
) in
list_map_res (fun e -> make_eexpr_of_ast e) args_list >>= fun args_expr ->
OK (Ecall(name, args_expr))
| Node(t, [e1; e2]) when tag_is_binop t ->
make_eexpr_of_ast e1 >>= fun expr1 ->
make_eexpr_of_ast e2 >>= fun expr2 ->
......@@ -77,6 +85,16 @@ let rec make_eexpr_of_ast (a: tree) : expr res =
let rec make_einstr_of_ast (a: tree) : instr res =
let res =
match a with
| Node(Tcall, StringLeaf(name)::r) ->
let args_list = (match r with
| Node(Targs, l )::[] -> l
| _ -> []
) in
list_map_res (fun e -> make_eexpr_of_ast e) args_list >>= fun args_expr ->
(match name with
| "print" when List.length args_expr = 1 -> OK(Iprint(List.hd args_expr))
| _ -> OK (Icall(name, args_expr)))
| Node(t, e1::i1::i2) when t = Tif ->
make_eexpr_of_ast e1 >>= fun expr1 ->
make_einstr_of_ast i1 >>= fun inst1 ->
......@@ -84,20 +102,26 @@ let rec make_einstr_of_ast (a: tree) : instr res =
| [] -> OK (Iif(expr1,inst1,Iblock([])))
| [i2'] -> make_einstr_of_ast (i2') >>= fun inst2 -> OK (Iif(expr1, inst1 , inst2))
| _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s" (string_of_ast a)))
| Node(t,[i1]) when t = Tassign -> make_einstr_of_ast i1
| Node(t,[StringLeaf(str);e1]) when t = Tassignvar ->
make_eexpr_of_ast e1 >>= fun expr1 ->
OK(Iassign(str,expr1))
| Node(t,[e1;i1]) when t = Twhile ->
make_eexpr_of_ast e1 >>= fun expr1 ->
make_einstr_of_ast i1 >>= fun inst1 ->
OK(Iwhile(expr1, inst1))
| Node(t,li) when t = Tblock ->
list_map_res (fun i -> make_einstr_of_ast i) li >>= fun inst_res ->
OK(Iblock(inst_res))
| Node(t,[e1]) when tag_is_unary_inst t ->
make_eexpr_of_ast e1 >>= fun expr1 ->
OK(uniinst_of_tag expr1 t)
| _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s"
(string_of_ast a))
in
......
......@@ -26,6 +26,8 @@ let rec dump_eexpr = function
| Eunop(u, e) -> Printf.sprintf "(%s %s)" (dump_unop u) (dump_eexpr e)
| Eint i -> Printf.sprintf "%d" i
| Evar s -> Printf.sprintf "%s" s
| Ecall (name,expr_list) -> Printf.sprintf "%s(%s)" name (String.concat ", " (List.map dump_eexpr expr_list))
let indent_size = 2
let spaces n =
......@@ -58,6 +60,8 @@ let rec dump_einstr_rec indent oc i =
| Iprint(e) ->
print_spaces oc indent;
Format.fprintf oc "print %s;\n" (dump_eexpr e)
| Icall (name,expr_list) -> Format.fprintf oc "%s(%s)\n" name (String.concat ", " (List.map dump_eexpr expr_list))
let dump_einstr oc i = dump_einstr_rec 0 oc i
......
......@@ -30,21 +30,35 @@ let eval_unop (u: unop) : int -> int =
match u with
| Eneg -> fun x -> -x
(* [eval_eexpr st e] évalue l'expression [e] dans l'état [st]. Renvoie une
(* [eval_eexpr oc ep st e] évalue l'expression [e] dans l'état [st]. Renvoie une
erreur si besoin. *)
let rec eval_eexpr st (e : expr) : int res =
let {env} = st in
let rec eval_eexpr oc (ep: eprog) st (e : expr) : (int * int Prog.state) res =
match e with
| Ebinop(op,expr1,expr2) ->
eval_eexpr st expr1 >>= fun value1 ->
eval_eexpr st expr2 >>= fun value2 ->
OK(eval_binop op value1 value2)
| Eunop(op,expr) -> eval_eexpr st expr >>= fun value -> OK(eval_unop op value)
let* (value1, st) = eval_eexpr oc ep st expr1 in
let* (value2, st) = eval_eexpr oc ep st expr2 in
OK((eval_binop op value1 value2), st)
| Eunop(op,expr) ->
let* (value,st) = eval_eexpr oc ep st expr in
OK((eval_unop op value), st)
| Evar(str) ->
(match Hashtbl.find_option env str with
(match Hashtbl.find_option st.env str with
| None -> Error (Format.sprintf "Unknown variable %s\n" str)
| Some(n) -> OK(n))
| Eint(n) -> OK(n)
| Some(name) -> OK(name, st))
| Eint(n) -> OK(n, st)
| Ecall(name,expr_list) ->
let* (args, st) = List.fold_left (fun acc expr ->
let* (expr_l, st) = acc in
let* (arg_expr, st) = eval_eexpr oc ep st expr in
OK(expr_l@[arg_expr], st)
) (OK([], st)) expr_list in
let* f = find_function ep name in
let* (res,st) = eval_efun oc ep st f name args in
match res with
| Some(n) -> OK(n, st)
| None -> Error (Format.sprintf "Error with function %s" name)
(* [eval_einstr oc st ins] évalue l'instrution [ins] en partant de l'état [st].
......@@ -58,41 +72,63 @@ let rec eval_eexpr st (e : expr) : int res =
lieu et que l'exécution doit continuer.
- [st'] est l'état mis à jour. *)
let rec eval_einstr oc (st: int state) (ins: instr) :
and eval_einstr oc (ep: eprog) (st: int state) (ins: instr) :
(int option * int state) res =
let {env} = st in
let rec eval_list_instrs st li : (int option * int state) res =
match li with
| [] -> OK(None,st)
| instr::next_instrs -> eval_einstr oc st instr >>= fun result ->
| instr::next_instrs -> eval_einstr oc ep st instr >>= fun result ->
match result with
| (None, st) -> eval_list_instrs st next_instrs
| (Some(n), st) -> OK(result)
in
let rec eval_while st e i: (int option * int state) res =
eval_eexpr st e >>= fun condition ->
if condition=1 then
eval_einstr oc st i >>= fun result_loop ->
let* (condition,st) = eval_eexpr oc ep st e in
if condition = 1 then
eval_einstr oc ep st i >>= fun result_loop ->
match result_loop with
| (None, st)-> (eval_while st e i)
| (Some(n), st) -> OK(result_loop)
else OK(None, st)
in
match ins with
| Iassign(str, expr) -> eval_eexpr st expr >>= fun value -> Hashtbl.replace env str value; OK(None,st)
| Iif(expr,instr1,instr2) -> eval_eexpr st expr >>=
fun condition -> if condition=1 then eval_einstr oc st instr1 else eval_einstr oc st instr2
| Iassign(str, expr) ->
let* (value, st) = eval_eexpr oc ep st expr in
Hashtbl.replace st.env str value;
OK(None,st)
| Iif(expr,instr1,instr2) ->
let* (condition,st) = eval_eexpr oc ep st expr in
if condition=1 then eval_einstr oc ep st instr1 else eval_einstr oc ep st instr2
| Iwhile(expr,instr) -> eval_while st expr instr
| Iblock(instrs) -> eval_list_instrs st instrs
| Ireturn(expr) -> eval_eexpr st expr >>= fun result -> OK(Some(result), st)
| Iprint(expr) -> eval_eexpr st expr >>= fun result -> Format.fprintf oc "%d\n" result; OK(None, st)
| Ireturn(expr) ->
let* (result,st) = eval_eexpr oc ep st expr
in OK(Some(result), st)
| Iprint(expr) ->
let* (result, st) = eval_eexpr oc ep st expr in
Format.fprintf oc "%d\n" result; OK(None, st)
| Icall(name,expr_list) ->
let* (args, st) = List.fold_left (fun acc expr ->
let* (expr_l, st) = acc in
let* (arg_expr, st) = eval_eexpr oc ep st expr in
OK(expr_l@[arg_expr], st)
) (OK([], st)) expr_list in
let* f = find_function ep name in
eval_efun oc ep st f name args
(* [eval_efun oc st f fname vargs] évalue la fonction [f] (dont le nom est
[fname]) en partant de l'état [st], avec les arguments [vargs].