diff --git a/expr_grammar_action.g b/expr_grammar_action.g
index 60a5b346c730e1e52747422107298a79f1a451a2..0ccce0ebe6406a10f46a3fc9ebc710b6f7c673e5 100644
--- a/expr_grammar_action.g
+++ b/expr_grammar_action.g
@@ -2,6 +2,7 @@ tokens SYM_EOF SYM_IDENTIFIER<string> SYM_INTEGER<int> SYM_PLUS SYM_MINUS SYM_AS
tokens SYM_LPARENTHESIS SYM_RPARENTHESIS SYM_LBRACE SYM_RBRACE
tokens SYM_ASSIGN SYM_SEMICOLON SYM_RETURN SYM_IF SYM_WHILE SYM_ELSE SYM_COMMA
tokens SYM_EQUALITY SYM_NOTEQ SYM_LT SYM_LEQ SYM_GT SYM_GEQ
+tokens SYM_INT SYM_CHAR SYM_VOID SYM_CHARACTER<char>
non-terminals S INSTR<tree> INSTRS<tree list> LINSTRS ELSE EXPR FACTOR
non-terminals LPARAMS REST_PARAMS
non-terminals IDENTIFIER INTEGER
@@ -12,6 +13,7 @@ non-terminals CMP_EXPRS CMP_EXPR
non-terminals EQ_EXPRS EQ_EXPR
non-terminals AFTER_IDENTIFIER_INSTR AFTER_IDENTIFIER_FACTOR LARGS REST_ARGS
+non-terminals TYPE AFTER_IDENTIFIER_DEC CHARACTER
axiom S
{
@@ -40,11 +42,15 @@ rules
S -> FUNDEFS SYM_EOF { Node(Tlistglobdef, $1) }
FUNDEFS -> FUNDEF FUNDEFS { $1::$2 }
FUNDEFS -> { [] }
-FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS INSTR { Node(Tfundef, [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$5])]) }
+FUNDEF -> TYPE IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS INSTR { Node(Tfundef, [Node(Tfuntype, [$1]); Node(Tfunname, [$2]); Node(Tfunargs, $4); Node(Tfunbody, [$6])]) }
-LPARAMS -> IDENTIFIER REST_PARAMS { Node(Targ, [$1])::$2 }
+TYPE -> SYM_INT { TypeLeaf Tint }
+TYPE -> SYM_CHAR { TypeLeaf Tchar }
+TYPE -> SYM_VOID { TypeLeaf Tvoid }
+
+LPARAMS -> TYPE IDENTIFIER REST_PARAMS { Node(Targ, [$1; $2])::$3 }
LPARAMS -> { [] }
-REST_PARAMS -> SYM_COMMA IDENTIFIER REST_PARAMS { Node(Targ, [$2])::$3 }
+REST_PARAMS -> SYM_COMMA TYPE IDENTIFIER REST_PARAMS { Node(Targ, [$2; $3])::$4 }
REST_PARAMS -> { [] }
LARGS -> EXPR REST_ARGS { $1::$2 }
@@ -66,11 +72,20 @@ INSTR -> IDENTIFIER AFTER_IDENTIFIER_INSTR SYM_SEMICOLON {
| Funcall args -> Node(Tcall, [$1; Node(Targs, args)])
| _ -> $1
}
+INSTR -> TYPE IDENTIFIER AFTER_IDENTIFIER_DEC SYM_SEMICOLON {
+ match $3 with
+ | Assign exp -> Node(Tblock, [Node(Tdeclare, [$1; $2]); Node(Tassign, [$2; exp])])
+ | Nothing -> Node(Tdeclare, [$1; $2])
+ | _ -> $1
+}
INSTR -> SYM_LBRACE LINSTRS SYM_RBRACE { $2 }
AFTER_IDENTIFIER_INSTR -> SYM_ASSIGN EXPR { Assign $2 }
AFTER_IDENTIFIER_INSTR -> SYM_LPARENTHESIS LARGS SYM_RPARENTHESIS { Funcall $2 }
+AFTER_IDENTIFIER_DEC -> SYM_ASSIGN EXPR { Assign $2 }
+AFTER_IDENTIFIER_DEC -> { Nothing }
+
ELSE -> SYM_ELSE SYM_LBRACE LINSTRS SYM_RBRACE { $3 }
ELSE -> { NullLeaf }
@@ -109,9 +124,11 @@ FACTOR -> IDENTIFIER AFTER_IDENTIFIER_FACTOR {
| _ -> $1
}
FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS { $2 }
+FACTOR -> CHARACTER { $1 }
IDENTIFIER -> SYM_IDENTIFIER {StringLeaf $1}
INTEGER -> SYM_INTEGER {IntLeaf $1}
+CHARACTER -> SYM_CHARACTER {CharLeaf $1}
AFTER_IDENTIFIER_FACTOR -> { Nothing }
AFTER_IDENTIFIER_FACTOR -> SYM_LPARENTHESIS LARGS SYM_RPARENTHESIS { Funcall $2 }
diff --git a/src/ast.ml b/src/ast.ml
index 7560fa685835d10dadbf5fdafbd046d46869061c..f8b7689cb10a616932442a94d94d149174843163 100644
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -1,4 +1,5 @@
open Batteries
+open Prog
(* Les AST sont des arbres, du type [tree], étiquetés par des [tag].
@@ -22,14 +23,14 @@ open Batteries
*)
-type tag = Tassign | Tif | Twhile | Tblock | Treturn
- | Tint
+type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tdeclare
+ | Tint | Tchar | Tvoid
| Tadd | Tmul | Tdiv | Tmod | Txor | Tsub
| Tclt | Tcgt | Tcle | Tcge | Tceq | Tne
| Tneg
| Tlistglobdef
- | Tfundef | Tfunname | Tfunargs | Tfunbody | Tcall
- | Tassignvar
+ | Tfundef | Tfuntype | Tfunname | Tfunargs | Tfunbody | Tcall
+ | Tassignvar (*never used*)
| Targ | Targs
type tree = | Node of tag * tree list
@@ -37,7 +38,7 @@ type tree = | Node of tag * tree list
| IntLeaf of int
| NullLeaf
| CharLeaf of char
-
+ | TypeLeaf of typ
let string_of_stringleaf = function
| StringLeaf s -> s
| _ -> failwith "string_of_stringleaf called on non-stringleaf nodes."
@@ -74,6 +75,10 @@ let string_of_tag = function
| Targ -> "Targ"
| Tcall -> "Tcall"
| Targs -> "Targs"
+ | Tdeclare -> "Tdeclare"
+ | Tfuntype -> "Tfuntype"
+ | Tchar -> "Tchar"
+ | Tvoid -> "Tvoid"
(* Écrit un fichier .dot qui correspond à un AST *)
let rec draw_ast a next =
@@ -100,7 +105,8 @@ let rec draw_ast a next =
(next, next+1, [ Format.sprintf "n%d [label=\"null\"]\n" next])
| CharLeaf i ->
(next, next+1, [ Format.sprintf "n%d [label=\"%c\"]\n" next i])
-
+ | TypeLeaf t ->
+ (next, next+1, [ Format.sprintf "n%d [label=\"%s\"]\n" next (string_of_typ t)])
let draw_ast_tree oc ast =
let (_, _, s) = draw_ast ast 1 in
let s = String.concat "" s in
@@ -115,3 +121,4 @@ let rec string_of_ast a =
| IntLeaf i -> Format.sprintf "%d" i
| CharLeaf i -> Format.sprintf "%c" i
| NullLeaf -> "null"
+ | TypeLeaf t -> string_of_typ t
\ No newline at end of file
diff --git a/src/cfg_gen.ml b/src/cfg_gen.ml
index f009b7baa4fbec07ee8334469e65bccd2e2ea279..5831632089eee520c8f75837a274ef4672a0bdfe 100644
--- a/src/cfg_gen.ml
+++ b/src/cfg_gen.ml
@@ -28,6 +28,7 @@ let rec cfg_expr_of_eexpr (e: Elang.expr) : expr res =
| Elang.Ecall (f, args) ->
list_map_res cfg_expr_of_eexpr args >>= fun es ->
OK (Ecall (f, es))
+ | Elang.Echar c -> OK (Eint (Char.code c))
(* [cfg_node_of_einstr next cfg succ i] builds the CFG node(s) that correspond
to the E instruction [i].
@@ -73,7 +74,7 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
list_map_res cfg_expr_of_eexpr args >>= fun es ->
Hashtbl.replace cfg next (Ccall (f, es, succ));
OK (next, next + 1)
-
+ | Elang.Ideclare (_, s) -> cfg_node_of_einstr next cfg succ (Elang.Iassign (s, Eint 0))
(* Some nodes may be unreachable after the CFG is entirely generated. The
[reachable_nodes n cfg] constructs the set of node identifiers that are
@@ -100,7 +101,7 @@ let cfg_fun_of_efun { funargs; funbody } =
(* remove unreachable nodes *)
let r = reachable_nodes node cfg in
Hashtbl.filteri_inplace (fun k _ -> Set.mem k r) cfg;
- OK { cfgfunargs = funargs;
+ OK { cfgfunargs = List.map (fun (s, t) -> s) funargs;
cfgfunbody = cfg;
cfgentry = node;
}
diff --git a/src/e_regexp.ml b/src/e_regexp.ml
index e909133d0eed77cdfb9933719dd0ad7c48f32cd7..5bba68fcd0cfd8cf36caa0c67dce9d5df302af3a 100644
--- a/src/e_regexp.ml
+++ b/src/e_regexp.ml
@@ -70,7 +70,7 @@ let list_regexp : (regexp * (string -> token option)) list =
(keyword_regexp "int", fun _ -> Some (SYM_INT));
(* begin TODO *)
(keyword_regexp "void", fun _ -> Some (SYM_VOID));
- (keyword_regexp "void", fun _ -> Some (SYM_CHAR));
+ (keyword_regexp "char", fun _ -> Some (SYM_CHAR));
(keyword_regexp "if", fun _ -> Some (SYM_IF));
(keyword_regexp "else", fun _ -> Some (SYM_ELSE));
(keyword_regexp "return", fun _ -> Some (SYM_RETURN));
diff --git a/src/elang.ml b/src/elang.ml
index 03d287f62c07973da8aa33f72e70b81c18865c5f..f10e95f555781982868b04dc5ea2d79388507006 100644
--- a/src/elang.ml
+++ b/src/elang.ml
@@ -10,6 +10,7 @@ type expr =
| Eint of int
| Evar of string
| Ecall of string * expr list
+ | Echar of char
type instr =
| Iassign of string * expr
@@ -18,10 +19,13 @@ type instr =
| Iblock of instr list
| Ireturn of expr
| Icall of string * expr list
+ | Ideclare of typ * string
type efun = {
- funargs: ( string ) list;
+ funargs: ( string * typ ) list;
funbody: instr;
+ funvartyp : (string, typ) Hashtbl.t;
+ funrettype : typ
}
type eprog = efun prog
diff --git a/src/elang_gen.ml b/src/elang_gen.ml
index 54e92035f2002c236095886d338e539f505993aa..d191bbd922c1552938c3fd4a48bcdbfa152ede61 100644
--- a/src/elang_gen.ml
+++ b/src/elang_gen.ml
@@ -39,80 +39,118 @@ let binop_of_tag =
| Tne -> Ecne
| _ -> assert false
+let remove_local_vars typ_var local_typ_var =
+ Hashtbl.filteri (fun s t -> Hashtbl.mem typ_var s) local_typ_var
+
+let rec type_expr (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string, typ list * typ) Hashtbl.t) (e: expr) : typ res =
+ match e with
+ | Ebinop (b, e1, e2) ->
+ type_expr typ_var typ_fun e1 >>= fun t1 ->
+ type_expr typ_var typ_fun e2 >>= fun t2 ->
+ if t1 != Tvoid && t2 != Tvoid
+ then OK Tint
+ else Error "E: Binop is not defined on void type."
+ | Eunop (u, e) ->
+ type_expr typ_var typ_fun e >>= fun t ->
+ if t != Tvoid
+ then OK Tint
+ else Error "E: Unop is not defined on void type."
+ | Eint i -> OK Tint
+ | Echar c -> OK Tchar
+ | Evar s ->
+ (match Hashtbl.find_option typ_var s with
+ | Some t when t != Tvoid -> OK t
+ | _ -> Error (Format.sprintf "E: Expression %s type is not defined." s))
+ | Ecall (f, _) ->
+ match Hashtbl.find_option typ_fun f with
+ | Some (_, t) when t != Tvoid -> OK t
+ | _ -> Error "E: Function return type is not defined."
+
+let are_compatible (t1 : typ) (t2 : typ) : bool =
+ match t1, t2 with
+ | Tint, Tint
+ | Tchar, Tchar
+ | Tint, Tchar
+ | Tchar, Tint -> true
+ | _ -> false
+
(* [make_eexpr_of_ast a] builds an expression corresponding to a tree [a]. If
the tree is not well-formed, fails with an [Error] message. *)
-let rec make_eexpr_of_ast (a: tree) : expr res =
+let rec make_eexpr_of_ast (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string, typ list * typ) Hashtbl.t) (a: tree) : expr res =
let res =
match a with
(* TODO *)
| IntLeaf i -> OK (Eint i)
| StringLeaf s -> OK (Evar s)
+ | CharLeaf c -> OK (Echar c)
| Node(t, [e1; e2]) when tag_is_binop t ->
- (let res1 = make_eexpr_of_ast e1
- in let res2 = make_eexpr_of_ast e2
- in match res1, res2 with
- | Error msg, _ -> Error msg
- | _, Error msg -> Error msg
- | OK expr1, OK expr2 -> OK (Ebinop (binop_of_tag t, expr1, expr2)))
+ (make_eexpr_of_ast typ_var typ_fun e1 >>= fun expr1 ->
+ make_eexpr_of_ast typ_var typ_fun e2 >>= fun expr2 ->
+ OK (Ebinop (binop_of_tag t, expr1, expr2)))
| Node(Tneg, [e]) ->
- (let res = make_eexpr_of_ast e
- in match res with
- | Error msg -> Error msg
- | OK expr -> OK (Eunop (Eneg, expr)))
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ OK (Eunop (Eneg, expr))
| Node(Tcall, [StringLeaf f; Node(Targs, args)]) ->
- (let res = list_map_res make_eexpr_of_ast args
- in match res with
- | Error msg -> Error msg
- | OK exprs -> OK (Ecall (f, exprs)))
+ list_map_res (make_eexpr_of_ast typ_var typ_fun) args >>= fun exprs ->
+ OK (Ecall (f, exprs))
| _ ->
Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
(string_of_ast a))
in
match res with
- OK o -> res
+ OK o -> type_expr typ_var typ_fun o >>= fun t -> res
| Error msg -> Error (Format.sprintf "In make_eexpr_of_ast %s:\n%s"
(string_of_ast a) msg)
-let rec make_einstr_of_ast (a: tree) : instr res =
+let rec make_einstr_of_ast (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string, typ list * typ) Hashtbl.t) (a: tree) : instr res =
let res =
match a with
(* TODO *)
| Node(Tassign, [StringLeaf s; e]) ->
- (let res_of_e = make_eexpr_of_ast e
- in match res_of_e with
- | OK exp -> OK (Iassign (s, exp))
- | Error msg -> Error msg)
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ type_expr typ_var typ_fun expr >>= fun te ->
+ type_expr typ_var typ_fun (Evar s) >>= fun ts ->
+ if are_compatible te ts
+ then OK (Iassign (s, expr))
+ else Error (Format.sprintf "E: Types %s and %s are not compatible." (string_of_typ ts) (string_of_typ te))
| Node(Tif, [e; i1; i2]) ->
- (let res_of_e = make_eexpr_of_ast e
- in let res_of_i1 = make_einstr_of_ast i1
- in let res_of_i2 = make_einstr_of_ast i2
- in match res_of_e, res_of_i1, res_of_i2 with
- | Error msg, _, _ -> Error msg
- | _, Error msg, _ -> Error msg
- | _, _, Error msg -> Error msg
- | OK exp, OK inst1, OK inst2 -> OK (Iif (exp, inst1, inst2)))
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ type_expr typ_var typ_fun expr >>= fun te ->
+ make_einstr_of_ast typ_var typ_fun i1 >>= fun instr1 ->
+ make_einstr_of_ast typ_var typ_fun i2 >>= fun instr2 ->
+ OK (Iif (expr, instr1, instr2))
| Node(Twhile, [e; i]) ->
- (let res_of_e = make_eexpr_of_ast e
- in let res_of_i = make_einstr_of_ast i
- in match res_of_e, res_of_i with
- | Error msg, _ -> Error msg
- | _, Error msg -> Error msg
- | OK exp, OK inst-> OK (Iwhile (exp, inst)))
- | Node(Tblock, i_list) ->
- (let res_of_i_list = list_map_res make_einstr_of_ast i_list
- in match res_of_i_list with
- | Error msg -> Error msg
- | OK instr_list -> OK (Iblock instr_list))
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ type_expr typ_var typ_fun expr >>= fun te ->
+ make_einstr_of_ast typ_var typ_fun i >>= fun instr ->
+ OK (Iwhile (expr, instr))
+ | Node(Tblock, i_list) ->
+ list_map_res (make_einstr_of_ast typ_var typ_fun) i_list >>= fun instr_list ->
+ OK (Iblock instr_list)
| Node(Treturn, [e]) ->
- (let res_of_e = make_eexpr_of_ast e
- in match res_of_e with
- | OK exp -> OK (Ireturn exp)
- | Error msg -> Error msg)
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ type_expr typ_var typ_fun expr >>= fun te ->
+ OK (Ireturn expr)
| Node(Tcall, [StringLeaf f; Node(Targs, args)]) ->
- (let res = list_map_res make_eexpr_of_ast args
- in match res with
- | Error msg -> Error msg
- | OK exprs -> OK (Icall (f, exprs)))
+ list_map_res (make_eexpr_of_ast typ_var typ_fun) args >>= fun exprs ->
+ list_map_res (type_expr typ_var typ_fun) exprs >>= fun types ->
+ (match Hashtbl.find_option typ_fun f with
+ | None -> Error (Format.sprintf "E: Unknown argument types of function %s." f)
+ | Some (arg_types, ret_type) ->
+ if types = arg_types
+ then OK (Icall (f, exprs))
+ else Error (Format.sprintf "E: Unvalid argument types in function %s calling." f))
+ | Node (Tdeclare, [TypeLeaf t; StringLeaf s]) ->
+ if t != Tvoid
+ then
+ if Hashtbl.mem typ_var s
+ then
+ Error (Format.sprintf "E: Variable %s already declared." s)
+ else
+ (Hashtbl.add typ_var s t;
+ OK (Ideclare (t ,s)))
+ else
+ Error (Format.sprintf "E: Can not declare void variable.")
| NullLeaf -> OK (Iblock [])
| _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s"
(string_of_ast a))
@@ -122,20 +160,22 @@ let rec make_einstr_of_ast (a: tree) : instr res =
| Error msg -> Error (Format.sprintf "In make_einstr_of_ast %s:\n%s"
(string_of_ast a) msg)
-let make_ident (a: tree) : string res =
+let make_ident (a: tree) : (string * typ) res =
match a with
- | Node (Targ, [s]) ->
- OK (string_of_stringleaf s)
+ | Node (Targ, [TypeLeaf t; StringLeaf s]) -> OK (s, t)
| a -> Error (Printf.sprintf "make_ident: unexpected AST: %s"
(string_of_ast a))
-let make_fundef_of_ast (a: tree) : (string * efun) res =
+let make_fundef_of_ast (typ_fun : (string, typ list * typ) Hashtbl.t) (a: tree) : (string * efun) res =
match a with
- | Node (Tfundef, [Node(Tfunname, [StringLeaf fname]); Node (Tfunargs, fargs); Node(Tfunbody, [fbody])]) ->
+ | Node (Tfundef, [Node(Tfuntype, [TypeLeaf t]); Node(Tfunname, [StringLeaf fname]); Node (Tfunargs, fargs); Node(Tfunbody, [fbody])]) ->
list_map_res make_ident fargs >>= fun fargs ->
- (* TODO *)
- make_einstr_of_ast fbody >>= fun fbody ->
- OK (fname, {funargs = fargs; funbody = fbody})
+ (* TODO *)
+ let typ_var = Hashtbl.of_list fargs
+ in let arg_types = List.map (fun (arg, typ) -> typ) fargs
+ in Hashtbl.add typ_fun fname (arg_types, t);
+ make_einstr_of_ast typ_var typ_fun fbody >>= fun fbody ->
+ OK (fname, {funargs = fargs; funbody = fbody; funvartyp = typ_var; funrettype = t})
| _ ->
Error (Printf.sprintf "make_fundef_of_ast: Expected a Tfundef, got %s."
(string_of_ast a))
@@ -143,7 +183,11 @@ let make_fundef_of_ast (a: tree) : (string * efun) res =
let make_eprog_of_ast (a: tree) : eprog res =
match a with
| Node (Tlistglobdef, l) ->
- list_map_res (fun a -> make_fundef_of_ast a >>= fun (fname, efun) -> OK (fname, Gfun efun)) l
+ let fun_typ = Hashtbl.create (List.length l) in
+ Hashtbl.replace fun_typ "print" ([Tint], Tvoid);
+ Hashtbl.replace fun_typ "print_int" ([Tint], Tvoid);
+ Hashtbl.replace fun_typ "print_char" ([Tchar], Tvoid);
+ list_map_res (fun a -> make_fundef_of_ast fun_typ a >>= fun (fname, efun) -> OK (fname, Gfun efun)) l
| _ ->
Error (Printf.sprintf "make_fundef_of_ast: Expected a Tlistglobdef, got %s."
(string_of_ast a))
diff --git a/src/elang_print.ml b/src/elang_print.ml
index 8e4d55d111be23ddb39cf66fccb0453657262e4a..c090ed55b3d993cde2ba0f9bdc5c35fd5ab0d3bd 100644
--- a/src/elang_print.ml
+++ b/src/elang_print.ml
@@ -27,7 +27,7 @@ let rec dump_eexpr = function
| Eint i -> Printf.sprintf "%d" i
| Evar s -> Printf.sprintf "%s" s
| Ecall (f, args) -> Printf.sprintf "%s(%s)" f (String.concat ", " (List.map dump_eexpr args))
-
+ | Echar c -> Printf.sprintf "%c" c
let indent_size = 2
let spaces n =
range (indent_size*n) |> List.map (fun _ -> ' ') |> String.of_list
@@ -59,7 +59,9 @@ let rec dump_einstr_rec indent oc i =
| Icall(f, args) ->
print_spaces oc indent;
Format.fprintf oc "%s(%s);\n" f (String.concat ", " (List.map dump_eexpr args))
-
+ | Ideclare(t, s) ->
+ print_spaces oc indent;
+ Format.fprintf oc "%s %s;\n" (string_of_typ t) s
let dump_einstr oc i = dump_einstr_rec 0 oc i
@@ -67,7 +69,7 @@ let dump_einstr oc i = dump_einstr_rec 0 oc i
let dump_efun oc funname {funargs; funbody} =
Format.fprintf oc "%s(%s) {\n%a\n}\n"
funname
- (String.concat "," funargs)
+ (String.concat "," (List.map (fun (s, t) -> Printf.sprintf "%s %s" (string_of_typ t) s) funargs))
dump_einstr funbody
let dump_eprog oc = dump_prog dump_efun oc
diff --git a/src/elang_run.ml b/src/elang_run.ml
index 4a5bd71713a29230da9cb83f3d4d77635354265e..92b77fb637a6cf4750296b6f2dce21d2d59fd9d6 100644
--- a/src/elang_run.ml
+++ b/src/elang_run.ml
@@ -4,6 +4,10 @@ open Prog
open Utils
open Builtins
+let remove_local_vars st local_st =
+ let filtered_env = Hashtbl.filteri (fun k v -> if Hashtbl.mem st.env k then (Printf.printf "Not removing %s\n" k; true) else (Printf.printf "removing %s\n" k; false) ) local_st.env
+ in {local_st with env = filtered_env}
+
let binop_bool_to_int f x y = if f x y then 1 else 0
(* [eval_binop b x y] évalue l'opération binaire [b] sur les arguments [x]
@@ -39,32 +43,19 @@ let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
| Some i -> OK (i, st)
| None -> Error "Variable is not defined")
| Ebinop (b, ex, ey) ->
- (let res_x = eval_eexpr oc st ep ex
- in match res_x with
- | Error msg -> Error msg
- | OK (x, st') ->
- let res_y = eval_eexpr oc st' ep ey
- in match res_y with
- | Error msg -> Error msg
- | OK (y, st'') -> OK (eval_binop b x y, st''))
+ eval_eexpr oc st ep ex >>= fun (x, st') ->
+ eval_eexpr oc st' ep ey >>= fun (y, st'') ->
+ OK (eval_binop b x y, st'')
| Eunop (u, ex) ->
- (let res_x = eval_eexpr oc st ep ex
- in match res_x with
- | Error msg -> Error msg
- | OK (x, st') -> OK (eval_unop u x, st'))
+ eval_eexpr oc st ep ex >>= fun (x, st') ->
+ OK (eval_unop u x, st')
| Ecall (f, args) ->
- let (res : (int list * int state) res) = List.fold_left (
- fun (acc : (int list * int state) res) (arg : expr) ->
- match acc with
- | Error msg -> Error msg
- | OK (l, st') ->
- match eval_eexpr oc st' ep arg with
- | Error msg -> Error msg
- | OK (i, st'') -> OK ((l@[i]), st'')
- ) (OK([], st)) args
- in match res with
- | Error msg -> Error msg
- | OK (int_args, st') ->
+ (List.fold_left
+ (fun acc arg ->
+ acc >>= fun (l, st') ->
+ eval_eexpr oc st' ep arg >>= fun (i, st'') ->
+ OK ((l@[i]), st''))
+ (OK([], st)) args >>= fun(int_args, st') ->
match find_function ep f with
| OK found_f ->
(match eval_efun oc st' ep found_f f int_args with
@@ -75,9 +66,10 @@ let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
(match do_builtin oc st'.mem f int_args with
| Error msg -> Error msg
| OK None -> Error (Format.sprintf "E: Function %s doesn't have a return value.\n" f)
- | OK (Some ret) -> OK (ret, st'))
+ | OK (Some ret) -> OK (ret, st')))
+ | Echar c -> OK (Char.code c, st)
-(* [eval_einstr oc st ins] évalue l'instrution [ins] en partant de l'état [st].
+(* [eval_einstr oc st ins] évalue l'instruction [ins] en partant de l'état [st].
Le paramètre [oc] est un "output channel", dans lequel la fonction "print"
écrit sa sortie, au moyen de l'instruction [Format.fprintf].
@@ -92,31 +84,33 @@ let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
and eval_einstr oc (st: int state) (ep: eprog) (ins: instr) :
(int option * int state) res =
match ins with
- | Iassign (s, e) ->
- (match eval_eexpr oc st ep e with
- | Error msg -> Error msg
- | OK (v, st') ->
- let replace st s v =
+ | Iassign (s, e) ->
+ if Hashtbl.mem st.env s
+ then
+ (let replace st s v =
let new_env = Hashtbl.copy st.env
in Hashtbl.replace new_env s v;
- {st with env = new_env}
- in OK (None, replace st' s v))
+ {st with env = new_env}
+ in match eval_eexpr oc st ep e with
+ | Error msg -> Error msg
+ | OK (v, st') -> OK (None, replace st' s v))
+ else
+ Error (Format.sprintf "E: Variable %s was not declared." s)
| Iif (e, i1, i2) ->
- (match eval_eexpr oc st ep e with
- | Error msg -> Error msg
- | OK (v, st') -> if v = 0 then eval_einstr oc st' ep i2 else eval_einstr oc st' ep i1)
+ (eval_eexpr oc st ep e >>= fun (v, st') ->
+ if v != 0
+ then eval_einstr oc st' ep i1 >>= fun (r_opt, st'') ->
+ OK (r_opt, remove_local_vars st' st'')
+ else eval_einstr oc st' ep i2 >>= fun (r_opt, st'') ->
+ OK (r_opt, remove_local_vars st' st''))
| Iwhile (e, i) ->
- (match eval_eexpr oc st ep e with
- | Error msg -> Error msg
- | OK (v, st') ->
- if v = 1
- then (let res_i = eval_einstr oc st' ep i
- in match res_i with
- | Error msg -> Error msg
- | OK (r_opt, next_st) -> match r_opt with
- | None -> eval_einstr oc next_st ep (Iwhile (e, i))
- | Some r -> OK (r_opt, next_st))
- else OK(None, st'))
+ (eval_eexpr oc st ep e >>= fun (v, st') ->
+ if v != 0
+ then eval_einstr oc st' ep i >>= fun (r_opt, next_st) ->
+ match r_opt with
+ | None -> eval_einstr oc (remove_local_vars st' next_st) ep (Iwhile (e, i))
+ | Some r -> OK (r_opt, remove_local_vars st' next_st)
+ else OK (None, st'))
| Iblock i_list ->
(match i_list with
| [] -> OK (None, st)
@@ -126,31 +120,26 @@ and eval_einstr oc (st: int state) (ep: eprog) (ins: instr) :
| OK (Some r, next_st) -> OK (Some r, next_st)
| OK (None, next_st) -> eval_einstr oc next_st ep (Iblock rest))
| Ireturn e ->
- (match eval_eexpr oc st ep e with
- | Error msg -> Error msg
- | OK (v, st') -> OK(Some v, st'))
+ eval_eexpr oc st ep e >>= fun (v, st') ->
+ OK(Some v, st')
| Icall (f, args) ->
- let (res : (int list * int state) res) = List.fold_left (
- fun (acc : (int list * int state) res) (arg : expr) ->
- match acc with
- | Error msg -> Error msg
- | OK (l, st') ->
- match eval_eexpr oc st' ep arg with
- | Error msg -> Error msg
- | OK (i, st'') -> OK ((l@[i]), st'')
- ) (OK([], st)) args
- in match res with
- | Error msg -> Error msg
- | OK (int_args, st') ->
+ (List.fold_left
+ (fun acc arg ->
+ acc >>= fun (l, st') ->
+ eval_eexpr oc st' ep arg >>= fun (i, st'') ->
+ OK ((l@[i]), st''))
+ (OK([], st)) args >>= fun(int_args, st') ->
match find_function ep f with
| OK found_f ->
- (match eval_efun oc st' ep found_f f int_args with
- | Error msg -> Error msg
- | OK (_, st'') -> OK (None, st''))
+ (eval_efun oc st' ep found_f f int_args >>= fun (_, st'') ->
+ OK (None, st''))
| Error msg ->
- (match do_builtin oc st'.mem f int_args with
- | OK _ -> OK (None, st')
- | Error msg -> Error msg )
+ (do_builtin oc st'.mem f int_args >>= fun _ ->
+ OK (None, st')))
+ | Ideclare (_, s) ->
+ let new_env = Hashtbl.copy st.env
+ in Hashtbl.add new_env s 0;
+ OK (None, {st with env = new_env})
(* [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].
@@ -167,7 +156,7 @@ and eval_efun oc (st: int state) ep ({ funargs; funbody}: efun)
seulement ses arguments), puis on restore l'environnement de l'appelant. *)
let env_save = Hashtbl.copy st.env in
let env = Hashtbl.create 17 in
- match List.iter2 (fun a v -> Hashtbl.replace env a v) funargs vargs with
+ match List.iter2 (fun (a, t) v -> Hashtbl.replace env a v) funargs vargs with
| () ->
eval_einstr oc { st with env } ep funbody >>= fun (v, st') ->
OK (v, { st' with env = env_save })
diff --git a/src/prog.ml b/src/prog.ml
index 5da26745e8461b83070928a8f3647a567394b2c7..515bbfbfb57586f706fa9b2e82cdcba1fbbbd6fe 100644
--- a/src/prog.ml
+++ b/src/prog.ml
@@ -6,6 +6,17 @@ type mem_access_size =
| MAS4
| MAS8
+type typ =
+ | Tint
+ | Tchar
+ | Tvoid
+
+let string_of_typ t =
+ match t with
+ | Tint -> "int"
+ | Tchar -> "char"
+ | Tvoid -> "void"
+
let string_of_mem_access_size mas =
match mas with
| MAS1 -> "{1}"
diff --git a/tests/Makefile b/tests/Makefile
index ef3fa0a92cb0f08481c60752b7797db738cd6921..5dbb6206ac0f9999921b11a2cd79d3d7bf8017ff 100644
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -1,7 +1,7 @@
# if make is launched with a DIR variable, pass it as the -f option to test.py
# 'make DIR=basic/mul*.e' launches all the files starting with mul in the basic directory
# otherwise, use basic/*.e as a default
-FILES := $(if $(DIR),$(DIR),funcall/*.e)
+FILES := $(if $(DIR),$(DIR),type_basic/*.e)
OPTS := $(if $(OPTS), $(OPTS),)