diff --git a/expr_grammar_action.g b/expr_grammar_action.g
index 7a39b82f90ec8ed90367048be50f41f9b0d49720..8eb98dda3e5410d40e0df22fb2c57d2f2973dd05 100644
--- a/expr_grammar_action.g
+++ b/expr_grammar_action.g
@@ -3,6 +3,7 @@ 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>
+tokens SYM_AMPERSAND
non-terminals S INSTR<tree> INSTRS<tree list> LINSTRS ELSE EXPR FACTOR
non-terminals LPARAMS REST_PARAMS
non-terminals IDENTIFIER INTEGER
@@ -14,6 +15,7 @@ non-terminals EQ_EXPRS EQ_EXPR
non-terminals AFTER_IDENTIFIER_INSTR AFTER_IDENTIFIER_FACTOR LARGS REST_ARGS
non-terminals TYPE AFTER_IDENTIFIER_DEC CHARACTER FUN_INSTR
+non-terminals ASTERIKS MEM_OPS
axiom S
{
@@ -24,6 +26,7 @@ axiom S
open BatBuffer
open Batteries
open Utils
+ open Prog
type after_id =
| Assign of tree
@@ -36,6 +39,14 @@ axiom S
match List.rev other with
| [] -> term
| (high_tag, right_side)::rest -> Node(high_tag, [resolve_associativity term (List.rev rest); right_side])
+
+ let rec make_type_ast (l : string list) : typ =
+ match List.rev l with
+ | ["int"] -> Tint
+ | ["char"] -> Tchar
+ | ["void"] -> Tvoid
+ | "*"::rest -> Tptr (make_type_ast (List.rev rest))
+ | _ -> Tvoid
}
rules
@@ -44,9 +55,12 @@ FUNDEFS -> FUNDEF FUNDEFS { $1::$2 }
FUNDEFS -> { [] }
FUNDEF -> TYPE IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS FUN_INSTR { Node(Tfundef, [Node(Tfuntype, [$1]); Node(Tfunname, [$2]); Node(Tfunargs, $4); Node(Tfunbody, [$6])]) }
-TYPE -> SYM_INT { TypeLeaf Tint }
-TYPE -> SYM_CHAR { TypeLeaf Tchar }
-TYPE -> SYM_VOID { TypeLeaf Tvoid }
+TYPE -> SYM_INT ASTERIKS { TypeLeaf (make_type_ast ("int"::$2)) }
+TYPE -> SYM_CHAR ASTERIKS { TypeLeaf (make_type_ast ("char"::$2)) }
+TYPE -> SYM_VOID ASTERIKS { TypeLeaf (make_type_ast ("void"::$2)) }
+
+ASTERIKS -> SYM_ASTERISK ASTERIKS { "*"::$2 }
+ASTERIKS -> { [] }
LPARAMS -> TYPE IDENTIFIER REST_PARAMS { Node(Targ, [$1; $2])::$3 }
LPARAMS -> { [] }
@@ -69,17 +83,17 @@ INSTRS -> { [] }
INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE ELSE { Node(Tif, [$3; $6; $8]) }
INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS INSTR { Node(Twhile, [$3; $5]) }
INSTR -> SYM_RETURN EXPR SYM_SEMICOLON { Node(Treturn, [$2]) }
-INSTR -> IDENTIFIER AFTER_IDENTIFIER_INSTR SYM_SEMICOLON {
- match $2 with
- | Assign exp -> Node(Tassign, [$1; exp])
- | Funcall args -> Node(Tcall, [$1; Node(Targs, args)])
- | _ -> $1
+INSTR -> MEM_OPS IDENTIFIER AFTER_IDENTIFIER_INSTR SYM_SEMICOLON {
+ match $3 with
+ | Assign exp -> Node(Tassign, [Node(Tmem, [MemopsLeaf $1; $2]); exp])
+ | Funcall args -> Node(Tmem, [MemopsLeaf $1; Node(Tcall, [$2; Node(Targs, args)])])
+ | _ -> $2
}
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
+ | _ -> $2
}
INSTR -> SYM_LBRACE LINSTRS SYM_RBRACE { $2 }
@@ -120,18 +134,22 @@ MUL_EXPRS -> SYM_MOD MUL_EXPR MUL_EXPRS { (Tmod, $2)::$3 }
MUL_EXPRS -> { [] }
FACTOR -> INTEGER { $1 }
-FACTOR -> IDENTIFIER AFTER_IDENTIFIER_FACTOR {
- match $2 with
- | Funcall args -> Node(Tcall, [$1; Node(Targs, args)])
- | Nothing -> $1
- | _ -> $1
+FACTOR -> MEM_OPS IDENTIFIER AFTER_IDENTIFIER_FACTOR {
+ match $3 with
+ | Funcall args -> Node(Tmem, [MemopsLeaf $1; Node(Tcall, [$2; Node(Targs, args)])])
+ | Nothing -> Node(Tmem, [MemopsLeaf $1; $2])
+ | _ -> Node(Tmem, [MemopsLeaf $1; $2])
}
FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS { $2 }
FACTOR -> CHARACTER { $1 }
-IDENTIFIER -> SYM_IDENTIFIER {StringLeaf $1}
+IDENTIFIER -> SYM_IDENTIFIER { StringLeaf $1 }
INTEGER -> SYM_INTEGER {IntLeaf $1}
CHARACTER -> SYM_CHARACTER {CharLeaf $1}
+MEM_OPS -> SYM_AMPERSAND MEM_OPS { Ampersand::$2 }
+MEM_OPS -> SYM_ASTERISK MEM_OPS { Asterik::$2 }
+MEM_OPS -> { [] }
+
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 f8b7689cb10a616932442a94d94d149174843163..c366d589f8622e7f87a8e473108748718448e4bb 100644
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -24,7 +24,6 @@ open Prog
*)
type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tdeclare
- | Tint | Tchar | Tvoid
| Tadd | Tmul | Tdiv | Tmod | Txor | Tsub
| Tclt | Tcgt | Tcle | Tcge | Tceq | Tne
| Tneg
@@ -32,6 +31,10 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tdeclare
| Tfundef | Tfuntype | Tfunname | Tfunargs | Tfunbody | Tcall
| Tassignvar (*never used*)
| Targ | Targs
+ | Tmem
+
+type mem_op = | Asterik
+ | Ampersand
type tree = | Node of tag * tree list
| StringLeaf of string
@@ -39,10 +42,15 @@ type tree = | Node of tag * tree list
| NullLeaf
| CharLeaf of char
| TypeLeaf of typ
+ | MemopsLeaf of mem_op list
let string_of_stringleaf = function
| StringLeaf s -> s
| _ -> failwith "string_of_stringleaf called on non-stringleaf nodes."
+let string_of_memop = function
+ | Asterik -> "*"
+ | Ampersand -> "&"
+
type astfun = (string list * tree)
type ast = (string * astfun) list
@@ -52,7 +60,6 @@ let string_of_tag = function
| Twhile -> "Twhile"
| Tblock -> "Tblock"
| Treturn -> "Treturn"
- | Tint -> "Tint"
| Tadd -> "Tadd"
| Tmul -> "Tmul"
| Tdiv -> "Tdiv"
@@ -77,8 +84,7 @@ let string_of_tag = function
| Targs -> "Targs"
| Tdeclare -> "Tdeclare"
| Tfuntype -> "Tfuntype"
- | Tchar -> "Tchar"
- | Tvoid -> "Tvoid"
+ | Tmem -> "Tmem"
(* Écrit un fichier .dot qui correspond à un AST *)
let rec draw_ast a next =
@@ -96,7 +102,6 @@ let rec draw_ast a next =
] @ List.map (fun n ->
Format.sprintf "n%d -> n%d\n" next n
)nodes)
-
| StringLeaf s ->
(next, next+1, [ Format.sprintf "n%d [label=\"%s\"]\n" next s])
| IntLeaf i ->
@@ -107,6 +112,9 @@ let rec draw_ast a next =
(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)])
+ | MemopsLeaf memops ->
+ (next, next+1, [ Format.sprintf "n%d [label=\"%s\"]\n" next (String.concat "" (List.map string_of_memop memops))])
+
let draw_ast_tree oc ast =
let (_, _, s) = draw_ast ast 1 in
let s = String.concat "" s in
@@ -121,4 +129,5 @@ 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
+ | TypeLeaf t -> string_of_typ t
+ | MemopsLeaf memops -> String.concat "" (List.map string_of_memop memops)
\ No newline at end of file
diff --git a/src/e_regexp.ml b/src/e_regexp.ml
index 5bba68fcd0cfd8cf36caa0c67dce9d5df302af3a..62c5c8fcb1c7854d2eb659d78ddc2d52254c5ef0 100644
--- a/src/e_regexp.ml
+++ b/src/e_regexp.ml
@@ -90,6 +90,7 @@ let list_regexp : (regexp * (string -> token option)) list =
(char_regexp ';', fun _ -> Some (SYM_SEMICOLON));
(char_regexp ',', fun _ -> Some (SYM_COMMA));
(char_regexp '=', fun _ -> Some (SYM_ASSIGN));
+ (char_regexp '&', fun _ -> Some (SYM_AMPERSAND));
(Cat(char_regexp '=', char_regexp '='), fun _ -> Some (SYM_EQUALITY));
(Cat(char_regexp '!', char_regexp '='), fun _ -> Some (SYM_NOTEQ));
(char_regexp '<', fun _ -> Some (SYM_LT));
diff --git a/src/elang.ml b/src/elang.ml
index f10e95f555781982868b04dc5ea2d79388507006..f28fc573735eecfbb8b92aab8b8d97c682a4c38c 100644
--- a/src/elang.ml
+++ b/src/elang.ml
@@ -11,6 +11,8 @@ type expr =
| Evar of string
| Ecall of string * expr list
| Echar of char
+ | Eaddrof of expr
+ | Eload of expr
type instr =
| Iassign of string * expr
@@ -20,12 +22,15 @@ type instr =
| Ireturn of expr
| Icall of string * expr list
| Ideclare of typ * string
+ | Istore of expr * expr
type efun = {
funargs: ( string * typ ) list;
funbody: instr;
funvartyp : (string, typ) Hashtbl.t;
- funrettype : typ
+ funrettype : typ;
+ funvarinmem : (string, int) Hashtbl.t;
+ funstksz : int
}
type eprog = efun prog
diff --git a/src/elang_gen.ml b/src/elang_gen.ml
index a91e073280a94fca6a0e5c830641febb60bf3ddd..675df19008a8c0b0c1bd3c0a197205e27b430037 100644
--- a/src/elang_gen.ml
+++ b/src/elang_gen.ml
@@ -39,6 +39,21 @@ let binop_of_tag =
| Tne -> Ecne
| _ -> assert false
+let binop_is_cmp =
+ function
+ | Ecle
+ | Eclt
+ | Ecge
+ | Ecgt
+ | Eceq
+ | Ecne -> true
+ | _ -> false
+
+let type_is_ptr =
+ function
+ | Tptr ty -> true
+ | _ -> false
+
let remove_local_vars typ_var local_typ_var =
Hashtbl.filteri (fun s t -> Hashtbl.mem typ_var s) local_typ_var
@@ -48,13 +63,34 @@ let rec type_expr (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string, typ lis
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 (* à vérifier *)
+ then
+ match t1, t2 with
+ | Tptr ty, Tint
+ | Tptr ty, Tchar ->
+ (match b with
+ | Eadd -> OK (Tptr ty)
+ | Esub -> OK (Tptr ty)
+ | _ -> Error "E: Binop is not defined on pointer.")
+ | Tchar, Tptr ty
+ | Tint, Tptr ty ->
+ (match b with
+ | Eadd -> OK (Tptr ty)
+ | _ -> Error "E: Binop is not defined on pointer.")
+ | Tptr ty1, Tptr ty2 ->
+ if binop_is_cmp b
+ then
+ if ty1 = ty2
+ then OK Tint
+ else Error "E: Uncomparable pointers."
+ else
+ Error "E: Binop is not defined on pointer type."
+ | _ -> 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
+ if t != Tvoid && t!= Tptr t
then OK Tint
- else Error "E: Unop is not defined on void type."
+ else Error "E: Unop is not defined on void or pointer type."
| Eint i -> OK Tint
| Echar c -> OK Tchar
| Evar s ->
@@ -62,13 +98,46 @@ let rec type_expr (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string, typ lis
| Some t when t != Tvoid -> OK t
| _ -> Error (Format.sprintf "E: Expression %s type is not defined." s))
| Ecall (f, exprs) ->
- match Hashtbl.find_option typ_fun f with
+ (match Hashtbl.find_option typ_fun f with
| Some (arg_types, ret_type) when ret_type != Tvoid ->
list_map_res (type_expr typ_var typ_fun) exprs >>= fun types ->
if types = arg_types
then OK ret_type
else Error (Format.sprintf "E: Unvalid argument types in function %s calling." f)
- | _ -> Error "E: Function return type is not defined."
+ | _ -> Error "E: Function return type is not defined.")
+ | Eaddrof e ->
+ type_expr typ_var typ_fun e >>= fun t ->
+ OK (Tptr t)
+ | Eload e ->
+ type_expr typ_var typ_fun e >>= fun t ->
+ match t with
+ | Tptr ty -> OK ty
+ | _ -> Error "E: Unvalid loading."
+
+let rec addr_taken_expr (e: expr) : string Set.t =
+ match e with
+ | Ebinop (b, e1, e2) -> Set.union (addr_taken_expr e1) (addr_taken_expr e2)
+ | Eunop (b, e) -> addr_taken_expr e
+ | Eint _
+ | Evar _
+ | Echar _ -> Set.empty
+ | Ecall (_, e_list) -> set_concat (List.map addr_taken_expr e_list)
+ | Eaddrof e ->
+ (match e with
+ | Evar s -> Set.singleton s
+ | _ -> Set.empty)
+ | Eload e -> addr_taken_expr e
+
+let rec addr_taken_instr (i: instr) : string Set.t =
+ match i with
+ | Iassign (_, e) -> addr_taken_expr e
+ | Iif (e, i1, i2) -> set_concat ([addr_taken_expr e; addr_taken_instr i1; addr_taken_instr i2])
+ | Iwhile (e, i) -> Set.union (addr_taken_expr e) (addr_taken_instr i)
+ | Iblock i_list -> set_concat (List.map addr_taken_instr i_list)
+ | Ireturn e -> addr_taken_expr e
+ | Icall (_, e_list) -> set_concat (List.map addr_taken_expr e_list)
+ | Ideclare _ -> Set.empty
+ | Istore (e1, e2) -> Set.union (addr_taken_expr e1) (addr_taken_expr e2)
let are_compatible (t1 : typ) (t2 : typ) : bool =
match t1, t2 with
@@ -76,6 +145,7 @@ let are_compatible (t1 : typ) (t2 : typ) : bool =
| Tchar, Tchar
| Tint, Tchar
| Tchar, Tint -> true
+ | Tptr ty1, Tptr ty2 when ty1 = ty2 -> true
| _ -> false
(* [make_eexpr_of_ast a] builds an expression corresponding to a tree [a]. If
@@ -97,6 +167,14 @@ let rec make_eexpr_of_ast (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string,
| Node(Tcall, [StringLeaf f; Node(Targs, args)]) ->
list_map_res (make_eexpr_of_ast typ_var typ_fun) args >>= fun exprs ->
OK (Ecall (f, exprs))
+ | Node(Tmem, [MemopsLeaf memops; e]) ->
+ (match memops with
+ | [] -> make_eexpr_of_ast typ_var typ_fun e
+ | memop::rest ->
+ (make_eexpr_of_ast typ_var typ_fun (Node(Tmem, [MemopsLeaf rest; e])) >>= fun e_rest ->
+ match memop with
+ | Asterik -> OK (Eload e_rest)
+ | Ampersand -> OK (Eaddrof e_rest)))
| _ ->
Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
(string_of_ast a))
@@ -112,53 +190,58 @@ let rec make_einstr_of_ast (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string
(* TODO *)
(* typ_var a été ajouté à la valeur de retour de cette fonction
pour permettre la gestion des variables locales dans les if et while. *)
- | Node(Tassign, [StringLeaf s; e]) ->
+ | Node(Tassign, [id; e]) ->
+ make_eexpr_of_ast typ_var typ_fun id >>= fun id_expr ->
+ type_expr typ_var typ_fun id_expr >>= fun tid ->
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), typ_var)
- 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]) ->
- make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
- make_einstr_of_ast typ_var typ_fun i1 >>= fun (instr1, new_typ_var) ->
- make_einstr_of_ast typ_var typ_fun i2 >>= fun (instr2, new_typ_var) ->
- OK (Iif (expr, instr1, instr2), typ_var)
- | Node(Twhile, [e; i]) ->
- make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
- make_einstr_of_ast typ_var typ_fun i >>= fun (instr, new_typ_var) ->
- OK (Iwhile (expr, instr), typ_var)
- | Node(Tblock, i_list) ->
- List.fold_left (fun acc i ->
- acc >>= fun (cur_i_list, cur_typ_var) ->
- make_einstr_of_ast cur_typ_var typ_fun i >>= fun (instr, new_typ_var) ->
- OK(cur_i_list@[instr], new_typ_var))
- (OK([], typ_var)) i_list >>= fun (instr_list, new_typ_var) ->
- OK(Iblock(instr_list), new_typ_var)
- | Node(Treturn, [e]) ->
- make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
- OK (Ireturn expr, typ_var)
- | Node(Tcall, [StringLeaf f; Node(Targs, args)]) ->
- (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), typ_var)
- 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
- let new_typ_var = Hashtbl.copy typ_var
- in Hashtbl.add new_typ_var s t;
- OK (Ideclare (t ,s), new_typ_var))
- else
- Error (Format.sprintf "E: Can not declare void variable."))
+ (match id_expr with
+ | Evar s ->
+ if are_compatible te tid
+ then OK (Iassign (s, expr), typ_var)
+ else Error (Format.sprintf "E: Types %s and %s are not compatible." (string_of_typ tid) (string_of_typ te))
+ | Eload ptr_expr -> OK (Istore (ptr_expr, expr), typ_var)
+ | _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s" (string_of_ast a)))
+ | Node(Tif, [e; i1; i2]) ->
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ make_einstr_of_ast typ_var typ_fun i1 >>= fun (instr1, new_typ_var) ->
+ make_einstr_of_ast typ_var typ_fun i2 >>= fun (instr2, new_typ_var) ->
+ OK (Iif (expr, instr1, instr2), typ_var)
+ | Node(Twhile, [e; i]) ->
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ make_einstr_of_ast typ_var typ_fun i >>= fun (instr, new_typ_var) ->
+ OK (Iwhile (expr, instr), typ_var)
+ | Node(Tblock, i_list) ->
+ List.fold_left (fun acc i ->
+ acc >>= fun (cur_i_list, cur_typ_var) ->
+ make_einstr_of_ast cur_typ_var typ_fun i >>= fun (instr, new_typ_var) ->
+ OK(cur_i_list@[instr], new_typ_var))
+ (OK([], typ_var)) i_list >>= fun (instr_list, new_typ_var) ->
+ OK(Iblock(instr_list), new_typ_var)
+ | Node(Treturn, [e]) ->
+ make_eexpr_of_ast typ_var typ_fun e >>= fun expr ->
+ OK (Ireturn expr, typ_var)
+ | Node(Tmem, [MemopsLeaf []; Node(Tcall, [StringLeaf f; Node(Targs, args)])]) ->
+ (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), typ_var)
+ 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
+ let new_typ_var = Hashtbl.copy typ_var
+ in Hashtbl.add new_typ_var s t;
+ OK (Ideclare (t ,s), new_typ_var))
+ else
+ Error (Format.sprintf "E: Can not declare void variable."))
| NullLeaf -> OK (Iblock [], typ_var)
| _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s"
(string_of_ast a))
@@ -167,7 +250,7 @@ let rec make_einstr_of_ast (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string
OK o -> 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 * typ) res =
match a with
| Node (Targ, [TypeLeaf t; StringLeaf s]) -> OK (s, t)
@@ -182,8 +265,22 @@ let make_fundef_of_ast (typ_fun : (string, typ list * typ) Hashtbl.t) (a: tree)
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})
+ make_einstr_of_ast typ_var typ_fun fbody >>= fun (fbody, typ_var) ->
+ let ofs = ref 0
+ in let funvarinmem = Hashtbl.create 17
+ in List.iter (fun x ->
+ match Hashtbl.find_option typ_var x with
+ | None -> ()
+ | Some t ->
+ ofs := !ofs + size_type t;
+ Hashtbl.add funvarinmem x !ofs;) (List.rev (Set.to_list (addr_taken_instr fbody)));
+ OK (fname,
+ {funargs = fargs;
+ funbody = fbody;
+ funvartyp = typ_var;
+ funrettype = t;
+ funvarinmem = funvarinmem;
+ funstksz = !ofs})
| _ ->
Error (Printf.sprintf "make_fundef_of_ast: Expected a Tfundef, got %s."
(string_of_ast a))
diff --git a/src/elang_print.ml b/src/elang_print.ml
index b1ed3424f066d76d600d77163c23eec07cd40f3a..9d401ffdf50ed825896a55ee3df1572b557896d1 100644
--- a/src/elang_print.ml
+++ b/src/elang_print.ml
@@ -28,6 +28,8 @@ let rec dump_eexpr = function
| 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
+ | Eaddrof e -> Printf.sprintf "&%s" (dump_eexpr e)
+ | Eload e -> Printf.sprintf "*%s" (dump_eexpr e)
let indent_size = 2
let spaces n =
range (indent_size*n) |> List.map (fun _ -> ' ') |> String.of_list
@@ -49,10 +51,11 @@ let rec dump_einstr_rec indent oc i =
Format.fprintf oc "while (%s) %a\n"
(dump_eexpr cond) (dump_einstr_rec (indent)) i
| Iblock(il) ->
+ print_spaces oc indent;
Format.fprintf oc "{\n";
List.iter (Format.fprintf oc "%a" (dump_einstr_rec (indent + 1))) il;
print_spaces oc indent;
- Format.fprintf oc "}";
+ Format.fprintf oc "}\n";
| Ireturn(e) ->
print_spaces oc indent;
Format.fprintf oc "return %s;\n" (dump_eexpr e)
@@ -62,6 +65,9 @@ let rec dump_einstr_rec indent oc i =
| Ideclare(t, s) ->
print_spaces oc indent;
Format.fprintf oc "%s %s;\n" (string_of_typ t) s
+ | Istore(p, e) ->
+ print_spaces oc indent;
+ Format.fprintf oc "*%s = %s;\n" (dump_eexpr p) (dump_eexpr e)
let dump_einstr oc i = dump_einstr_rec 0 oc i
diff --git a/src/elang_run.ml b/src/elang_run.ml
index ced1357893f77b521028e613603051e77dc9bea2..2dc808e5047dac3cac84411ef7b291c0ec494c16 100644
--- a/src/elang_run.ml
+++ b/src/elang_run.ml
@@ -3,6 +3,7 @@ open Batteries
open Prog
open Utils
open Builtins
+open Elang_gen
let binop_bool_to_int f x y = if f x y then 1 else 0
@@ -31,32 +32,55 @@ let eval_unop (u: unop) : int -> int =
(* [eval_eexpr st e] évalue l'expression [e] dans l'état [st]. Renvoie une
erreur si besoin. *)
-let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
+let rec eval_eexpr oc st (ep: eprog) (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string, typ list * typ) Hashtbl.t) (inmem_var : (string, int) Hashtbl.t) (sp : int) (e : expr) : (int * int state) res =
match e with
| Eint i -> OK (i, st)
- | Evar s -> OK (Hashtbl.find st.env s, st)
+ | Evar s ->
+ (match Hashtbl.find_opt inmem_var s with
+ | None -> OK (Hashtbl.find st.env s, st)
+ | Some ofs ->
+ Mem.read_bytes_as_int st.mem (sp - ofs) (size_type (Hashtbl.find typ_var s)) >>= fun v ->
+ Printf.printf "Read %d in address %d\n" v (sp - ofs); OK (v, st))
| Ebinop (b, ex, ey) ->
- 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'')
+ eval_eexpr oc st ep typ_var typ_fun inmem_var sp ex >>= fun (x, st') ->
+ eval_eexpr oc st' ep typ_var typ_fun inmem_var sp ey >>= fun (y, st'') ->
+ type_expr typ_var typ_fun ex >>= fun tx ->
+ type_expr typ_var typ_fun ey >>= fun ty ->
+ (match tx, ty with
+ | Tptr t, Tint -> OK (eval_binop b x (y * size_type t), st'')
+ | Tint, Tptr t -> OK (eval_binop b (x * size_type t) y, st'')
+ | _ -> OK (eval_binop b x y, st''))
| Eunop (u, ex) ->
- eval_eexpr oc st ep ex >>= fun (x, st') ->
+ eval_eexpr oc st ep typ_var typ_fun inmem_var sp ex >>= fun (x, st') ->
OK (eval_unop u x, st')
| Ecall (f, args) ->
(List.fold_left
(fun acc arg ->
acc >>= fun (l, st') ->
- eval_eexpr oc st' ep arg >>= fun (i, st'') ->
+ eval_eexpr oc st' ep typ_var typ_fun inmem_var sp arg >>= fun (i, st'') ->
OK ((l@[i]), st''))
(OK([], st)) args >>= fun(int_args, st') ->
match find_function ep f with
| OK found_f ->
- eval_efun oc st' ep found_f f int_args >>= fun (ret_opt, st'') ->
+ eval_efun oc st' ep found_f f int_args typ_fun sp >>= fun (ret_opt, st'') ->
OK (Option.get ret_opt, st'')
| Error msg ->
do_builtin oc st'.mem f int_args >>= fun (ret_opt) ->
OK (Option.get ret_opt, st'))
| Echar c -> OK (Char.code c, st)
+ | Eload e ->
+ eval_eexpr oc st ep typ_var typ_fun inmem_var sp e >>= fun (p, st') ->
+ type_expr typ_var typ_fun e >>= fun tp ->
+ Mem.read_bytes_as_int st'.mem p (size_type tp) >>= fun v ->
+ Printf.printf "Read %d in memory address %d\n" v p; OK (v, st')
+ | Eaddrof e ->
+ match e with
+ | Evar s ->
+ (match Hashtbl.find_option inmem_var s with
+ | Some ofs -> Printf.printf "Address of %s evaluated : %d\n" s (sp - ofs); OK (sp - ofs, st)
+ | None -> Error (Format.sprintf "Address of %s not found" s))
+ | Eload p -> eval_eexpr oc st ep typ_var typ_fun inmem_var sp p
+ | _ -> Error "Type cannot have an address"
(* [eval_einstr oc st ins] évalue l'instruction [ins] en partant de l'état [st].
@@ -70,64 +94,90 @@ let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
lieu et que l'exécution doit continuer.
- [st'] est l'état mis à jour. *)
-and eval_einstr oc (st: int state) (ep: eprog) (ins: instr) :
- (int option * int state) res =
+and eval_einstr oc (st: int state) (ep: eprog) (typ_var : (string,typ) Hashtbl.t) (typ_fun : (string, typ list * typ) Hashtbl.t) (inmem_var : (string, int) Hashtbl.t) (sp : int) (ins: instr) :
+ (int option * int state * (string,typ) Hashtbl.t) res =
+ (* typ_var a été ajouté à la valeur de retour de cette fonction
+ pour permettre la gestion des variables locales dans les if et while. *)
match ins with
| Iassign (s, e) ->
(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 match eval_eexpr oc st ep e with
+ in match eval_eexpr oc st ep typ_var typ_fun inmem_var sp e with
| Error msg -> Error msg
- | OK (v, st') -> OK (None, replace st' s v))
+ | OK (v, st') ->
+ match Hashtbl.find_opt inmem_var s with
+ | None -> OK (None, replace st' s v, typ_var)
+ | Some ofs ->
+ Mem.write_bytes st'.mem (sp - ofs) (split_bytes (size_type (Hashtbl.find typ_var s)) v) >>= fun _ ->
+ Printf.printf "Assigning %d in address %d\n" v (sp - ofs); OK (None, st', typ_var))
| Iif (e, i1, i2) ->
- eval_eexpr oc st ep e >>= fun (v, st') ->
+ eval_eexpr oc st ep typ_var typ_fun inmem_var sp e >>= fun (v, st') ->
if v != 0
- then eval_einstr oc st' ep i1
- else eval_einstr oc st' ep i2
+ then
+ eval_einstr oc st' ep typ_var typ_fun inmem_var sp i1 >>= fun (ret_opt, st', new_typ_var) ->
+ OK (ret_opt, st', typ_var)
+ else
+ eval_einstr oc st' ep typ_var typ_fun inmem_var sp i2 >>= fun (ret_opt, st', new_typ_var) ->
+ OK (ret_opt, st', typ_var)
| Iwhile (e, i) ->
- (eval_eexpr oc st ep e >>= fun (v, st') ->
+ (eval_eexpr oc st ep typ_var typ_fun inmem_var sp e >>= fun (v, st') ->
if v != 0
- then eval_einstr oc st' ep i >>= fun (r_opt, next_st) ->
+ then eval_einstr oc st' ep typ_var typ_fun inmem_var sp i >>= fun (r_opt, next_st, new_typ_var) ->
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'))
+ | None -> eval_einstr oc next_st ep typ_var typ_fun inmem_var sp (Iwhile (e, i))
+ | Some r -> OK (r_opt, next_st, typ_var)
+ else OK (None, st', typ_var))
| Iblock i_list ->
(match i_list with
- | [] -> OK (None, st)
+ | [] -> OK (None, st, typ_var)
| i::rest ->
- match eval_einstr oc st ep i with
+ match eval_einstr oc st ep typ_var typ_fun inmem_var sp i with
| Error msg -> Error msg
- | OK (Some r, next_st) -> OK (Some r, next_st)
- | OK (None, next_st) -> eval_einstr oc next_st ep (Iblock rest))
+ | OK (Some r, next_st, new_typ_var) -> OK (Some r, next_st, new_typ_var)
+ | OK (None, next_st, new_typ_var) -> eval_einstr oc next_st ep new_typ_var typ_fun inmem_var sp (Iblock rest))
| Ireturn e ->
- eval_eexpr oc st ep e >>= fun (v, st') ->
- OK(Some v, st')
+ eval_eexpr oc st ep typ_var typ_fun inmem_var sp e >>= fun (v, st') ->
+ OK(Some v, st', typ_var)
| Icall (f, args) ->
(List.fold_left
(fun acc arg ->
acc >>= fun (l, st') ->
- eval_eexpr oc st' ep arg >>= fun (i, st'') ->
+ eval_eexpr oc st' ep typ_var typ_fun inmem_var sp arg >>= fun (i, st'') ->
OK ((l@[i]), st''))
(OK([], st)) args >>= fun(int_args, st') ->
match find_function ep f with
| OK found_f ->
- (eval_efun oc st' ep found_f f int_args >>= fun (_, st'') ->
- OK (None, st''))
+ (eval_efun oc st' ep found_f f int_args typ_fun sp >>= fun (_, st'') ->
+ OK (None, st'', typ_var))
| Error msg ->
(do_builtin oc st'.mem f int_args >>= fun _ ->
- OK (None, st')))
- | Ideclare (_, s) -> OK (None, st)
-
+ OK (None, st', typ_var)))
+ | Ideclare (t, s) ->
+ let new_typ_var = Hashtbl.copy typ_var
+ in Hashtbl.add new_typ_var s t;
+ OK (None, st, new_typ_var)
+ | Istore (p_expr, e) ->
+ eval_eexpr oc st ep typ_var typ_fun inmem_var sp p_expr >>= fun (addr, st') ->
+ eval_eexpr oc st ep typ_var typ_fun inmem_var sp e >>= fun (v, st'') ->
+ type_expr typ_var typ_fun p_expr >>= fun tp ->
+ match tp with
+ | Tptr t ->
+ Mem.write_bytes st''.mem addr (split_bytes (size_type t) v) >>= fun u ->
+ Printf.printf "Storing %d in address %d\n" v addr; OK (None, st'', typ_var)
+ | _ ->
+ Error "Storing in unvalid address"
+and print_hashtbl (tbl : (string, int) Hashtbl.t) sp =
+ Hashtbl.iter (fun key value -> Printf.printf "%s -> %d\n" key (sp - value)) tbl
+
(* [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].
Cette fonction renvoie un couple (ret, st') avec la même signification que
pour [eval_einstr]. *)
-and eval_efun oc (st: int state) ep ({ funargs; funbody}: efun)
- (fname: string) (vargs: int list)
+and eval_efun oc (st: int state) ep ({funargs; funbody; funvartyp; funrettype; funvarinmem; funstksz}: efun)
+ (fname: string) (vargs: int list) (typ_fun : (string, typ list * typ) Hashtbl.t) (sp : int)
: (int option * int state) res =
(* L'environnement d'une fonction (mapping des variables locales vers leurs
valeurs) est local et un appel de fonction ne devrait pas modifier les
@@ -138,13 +188,23 @@ and eval_efun oc (st: int state) ep ({ funargs; funbody}: efun)
let env = Hashtbl.create 17 in
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 })
+ Printf.printf "Stack size = %d\n" funstksz;
+ print_hashtbl funvarinmem (sp + funstksz);
+ eval_einstr oc { st with env } ep funvartyp typ_fun funvarinmem (sp + funstksz) funbody >>= fun (v, st', _) ->
+ OK (v, { st' with env = env_save })
| exception Invalid_argument _ ->
Error (Format.sprintf
"E: Called function %s with %d arguments, expected %d.\n"
fname (List.length vargs) (List.length funargs)
)
+let create_typ_fun (ep: eprog) : (string, typ list * typ) Hashtbl.t =
+ let typ_fun = Hashtbl.create (List.length ep)
+ in List.iter (fun (fname, gfun) ->
+ match gfun with
+ | Gfun efun ->
+ let arg_types = List.map (fun (arg, typ) -> typ) efun.funargs
+ in Hashtbl.add typ_fun fname (arg_types, efun.funrettype)) ep;
+ typ_fun
(* [eval_eprog oc ep memsize params] évalue un programme complet [ep], avec les
arguments [params].
@@ -161,7 +221,7 @@ and eval_efun oc (st: int state) ep ({ funargs; funbody}: efun)
- [OK None] lorsque l'évaluation de la fonction termine sans renvoyer de valeur.
- [Error msg] lorsqu'une erreur survient.
- *)
+ *)
let eval_eprog oc (ep: eprog) (memsize: int) (params: int list)
: int option res =
let st = init_state memsize in
@@ -169,5 +229,6 @@ let eval_eprog oc (ep: eprog) (memsize: int) (params: int list)
(* ne garde que le nombre nécessaire de paramètres pour la fonction "main". *)
let n = List.length f.funargs in
let params = take n params in
- eval_efun oc st ep f "main" params >>= fun (v, _) ->
+ let typ_fun = create_typ_fun ep in
+ eval_efun oc st ep f "main" params typ_fun 0 >>= fun (v, _) ->
OK v
diff --git a/src/prog.ml b/src/prog.ml
index 515bbfbfb57586f706fa9b2e82cdcba1fbbbd6fe..47a60003ea27abce7cdc46fd0eec7d1bc40ae7e6 100644
--- a/src/prog.ml
+++ b/src/prog.ml
@@ -10,12 +10,14 @@ type typ =
| Tint
| Tchar
| Tvoid
+ | Tptr of typ
-let string_of_typ t =
+let rec string_of_typ t =
match t with
| Tint -> "int"
| Tchar -> "char"
| Tvoid -> "void"
+ | Tptr ty -> Format.sprintf "%s*" (string_of_typ ty)
let string_of_mem_access_size mas =
match mas with
@@ -78,3 +80,10 @@ let find_function (ep: 'a prog) fname : 'a res =
match List.assoc_opt fname ep with
| Some (Gfun f) -> OK f
| _ -> Error (Format.sprintf "Unknown function %s\n" fname)
+
+let size_type (t: typ) : int =
+ match t with
+ | Tint -> 4
+ | Tchar -> 1
+ | Tptr _ -> 4
+ | Tvoid -> 0
\ No newline at end of file
diff --git a/src/yaccparser.mly b/src/yaccparser.mly
index f33548304ee38a08febd46d65de15df788cf2bd4..c3449ba9e2ed1249b8b5583c3371c8721768c772 100644
--- a/src/yaccparser.mly
+++ b/src/yaccparser.mly
@@ -86,7 +86,6 @@
| expr SYM_LEQ expr { Node (Tcle, [$1; $3]) }
| expr SYM_GEQ expr { Node (Tcge, [$1; $3]) }
| SYM_MINUS expr %prec UMINUS { Node (Tneg, [$2])}
- | integer { Node(Tint, [$1])}
| identifier { $1 }
| SYM_LPARENTHESIS expr SYM_RPARENTHESIS { $2 }
;
diff --git a/tests/Makefile b/tests/Makefile
index f4bc98ab1a9b31a200dab6f51f1356b4c21f3c04..d6ec16f0043ce0c983741d86351ac6a573c3c937 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),type_funcall/*.e)
+FILES := $(if $(DIR),$(DIR),ptr/*.e)
OPTS := $(if $(OPTS), $(OPTS),)