Skip to content

GitLab

Commit 9b110917 authored by Armillon Damien's avatar Armillon Damien
Browse files

midle struct

parent 4b249c26
Hide whitespace changes
Inline Side-by-side
Makefile
View file @ 9b110917
......@@ -31,4 +31,7 @@ testFun: main.native
make -C tests DIR="type_funcall/*.e type_basic/*.e char/*.e"
testP: main.native
make -C tests DIR=ptr/*.e
\ No newline at end of file
make -C tests DIR=ptr/*.e
testS: main.native
make -C tests DIR=structs/*.e
\ No newline at end of file
expr_grammar_action.g
View file @ 9b110917
......@@ -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_VOID SYM_CHAR SYM_INT SYM_CHARACTER<char> SYM_AMPERSAND
tokens SYM_STRUCT SYM_POINT
non-terminals S INSTR INSTRS LINSTRS ELSE EXPR FACTOR
non-terminals LPARAMS REST_PARAMS
non-terminals IDENTIFIER INTEGER
......@@ -15,6 +16,7 @@ non-terminals BLOC
non-terminals IN_INSTR L_CALL_PARAMS REST_CALL_PARAMS FACTORS FACTOR_IDENTIFIER
non-terminals SYM_TYPE ASSIGN_EXPR FUNBODY
non-terminals VAR TYPE_PT
non-terminals STRUCTCONTENT STRUCTDEF DEFS STRUCTORFUN SYM_TYPE_NO_STRUCT DOTVAR
axiom S
{
......@@ -28,15 +30,20 @@ axiom S
let resolve_associativity term other =
List.fold_left (fun acc (tag, tree) -> Node(tag,acc::tree)) term other
}
rules
S -> FUNDEFS SYM_EOF { Node (Tlistglobdef, $1) }
S -> DEFS SYM_EOF { Node (Tlistglobdef, $1) }
DEFS -> FUNDEF DEFS {Node(Tfundef, $1) :: $2}
DEFS -> STRUCTDEF DEFS {$1 :: $2}
DEFS -> {[]}
STRUCTDEF -> SYM_STRUCT SYM_IDENTIFIER STRUCTORFUN {$3 $2}
STRUCTORFUN -> SYM_LBRACE STRUCTCONTENT SYM_RBRACE SYM_SEMICOLON {fun name -> Node(Tstructdef, [StringLeaf(name);Node(Tstructcontent,$2)])}
STRUCTORFUN -> SYM_IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS FUNBODY {fun name -> Node(Tfundef,[Node(Tstruct,[StringLeaf(name)]);StringLeaf($1);Node(Tfunargs,$3);$5])}
STRUCTCONTENT -> SYM_TYPE SYM_IDENTIFIER SYM_SEMICOLON STRUCTCONTENT {Node(Tstructelement,[$1; StringLeaf($2)])::$4}
STRUCTCONTENT -> {[]}
BLOC -> SYM_LBRACE INSTRS SYM_RBRACE {Node(Tblock, $2)}
FUNDEFS -> {[]}
FUNDEFS -> FUNDEF FUNDEFS { (Node (Tfundef, $1)) :: $2 }
FUNDEF -> SYM_TYPE SYM_IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS FUNBODY { [$1; StringLeaf($2); (Node(Tfunargs, $4)); $6] }
FUNDEF -> SYM_TYPE_NO_STRUCT SYM_IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS FUNBODY { [$1; StringLeaf($2); (Node(Tfunargs, $4)); $6] }
FUNBODY -> BLOC {$1}
FUNBODY -> SYM_SEMICOLON {NullLeaf}
LPARAMS -> {[]}
......@@ -54,7 +61,7 @@ ASSIGN_EXPR -> {[NullLeaf]}
INSTRS -> {[]}
INSTRS -> INSTR INSTRS {$1::$2}
INSTR -> BLOC {$1}
INSTR -> VAR IN_INSTR {$2 $1}
INSTR -> VAR IN_INSTR {$2 ($1 Tstructpoint )}
INSTR -> SYM_TYPE SYM_IDENTIFIER ASSIGN_EXPR SYM_SEMICOLON {Node(Tassign, [Node(Tassignvar , (StringLeaf $2)::$3@[$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])}
......@@ -87,13 +94,27 @@ FACTOR_IDENTIFIER -> {fun x -> x}
FACTOR_IDENTIFIER -> SYM_LPARENTHESIS L_CALL_PARAMS SYM_RPARENTHESIS {fun x -> Node(Tcall, x::$2)}
FACTOR -> SYM_INTEGER {IntLeaf($1)}
FACTOR -> SYM_CHARACTER {CharLeaf($1)}
FACTOR -> VAR FACTOR_IDENTIFIER {$2 $1}
FACTOR -> VAR FACTOR_IDENTIFIER {$2 ($1 Tstructunfoll)}
FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS {$2}
SYM_TYPE -> SYM_INT TYPE_PT {$2 (Node(Tint,[]))}
SYM_TYPE -> SYM_CHAR TYPE_PT { $2 (Node(Tchar,[]))}
SYM_TYPE -> SYM_VOID TYPE_PT {$2 (Node(Tvoid,[]))}
SYM_TYPE -> SYM_STRUCT TYPE_PT SYM_IDENTIFIER {$2 (Node(Tstruct,[StringLeaf($3)]))}
SYM_TYPE -> SYM_TYPE_NO_STRUCT {$1}
SYM_TYPE_NO_STRUCT -> SYM_INT TYPE_PT {$2 (Node(Tint,[]))}
SYM_TYPE_NO_STRUCT -> SYM_CHAR TYPE_PT { $2 (Node(Tchar,[]))}
SYM_TYPE_NO_STRUCT -> SYM_VOID TYPE_PT {$2 (Node(Tvoid,[]))}
TYPE_PT -> SYM_ASTERISK TYPE_PT {fun x -> $2 (Node(Tptr,[x]))}
TYPE_PT -> {fun x -> x}
VAR -> SYM_IDENTIFIER {StringLeaf($1)}
VAR -> SYM_ASTERISK VAR {Node(Tp,[$2])}
VAR -> SYM_AMPERSAND VAR {Node(Taddrof,[$2])}
VAR -> SYM_IDENTIFIER DOTVAR { fun x ->
let a = $2 x in
match a with
| [] -> StringLeaf($1)
| _ -> resolve_associativity (StringLeaf($1)) a
}
VAR -> SYM_ASTERISK VAR {fun x -> Node(Tp,[$2 x])}
VAR -> SYM_AMPERSAND VAR {fun x -> Node(Taddrof,[$2 x])}
DOTVAR -> SYM_POINT SYM_IDENTIFIER DOTVAR {fun x ->
let res = $3 x in
match res with
| [] -> (x,[StringLeaf $2])::[]
| _ -> (Tstructpoint,[StringLeaf $2])::res
}
DOTVAR -> {fun x -> []}
src/ast.ml
View file @ 9b110917
......@@ -31,10 +31,11 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tprint
| Tneg
| Tlistglobdef
| Tfundef | Tfunname | Tfunargs | Tfunbody
| Tstructdef | Tstructcontent | Tstructelement | Tstructunfoll | Tstructpoint
| Tassignvar
| Targ | Tcall | Targs
| Taddrof | Tp
| Tvoid | Tint | Tchar | Tptr
| Tvoid | Tint | Tchar | Tptr | Tstruct
type tree = | Node of tag * tree list
| StringLeaf of string
......@@ -82,8 +83,15 @@ let string_of_tag = function
| Tchar -> "Tchar"
| Tvoid -> "Tvoid"
| Tptr -> "Tptr"
| Tstruct -> "Tstruct"
| Taddrof -> "Taddrof"
| Tp -> "Tp"
| Tstructdef -> "Tstructdef"
| Tstructcontent -> "Tstructcontent"
| Tstructelement -> "Tstructelement"
| Tstructunfoll -> "Tstructunfoll"
| Tstructpoint -> "Tstructpoint"
(* Écrit un fichier .dot qui correspond à un AST *)
......@@ -129,13 +137,14 @@ let rec string_of_ast a =
let rec is_type (tr:tree) : typ res =
match tr with
| Node(t,st) when List.length st <=1-> (match t with
| Tvoid -> OK(Tvoid)
| Tint -> OK(Tint)
| Tchar -> OK(Tchar)
| Tptr ->
let* subtype = is_type (List.hd st) in
| Node(t,st) when List.length st <=1-> (match t,st with
| Tvoid,_ -> OK(Tvoid)
| Tint,_ -> OK(Tint)
| Tchar,_ -> OK(Tchar)
| Tptr, [st] ->
let* subtype = is_type st in
OK(Prog.Tptr (subtype))
| Tstruct, [StringLeaf name] -> OK(Prog.Tstruct name)
| _ -> Error "Not a type")
| _ ->Error (Format.sprintf "Not a type: %s" (string_of_ast tr))
\ No newline at end of file
src/cfg_gen.ml
View file @ 9b110917
......@@ -8,34 +8,34 @@ open Cfg_print
open Options
open Elang_gen
(* [cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e] converts an [Elang.expr] into a [expr res]. This should
(* [cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e] converts an [Elang.expr] into a [expr res]. This should
always succeed and be straightforward.
In later versions of this compiler, you will add more things to [Elang.expr]
but not to [Cfg.expr], hence the distinction.
*)
let rec cfg_expr_of_eexpr fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarinmem: (string, int) Hashtbl.t) (e: Elang.expr) : expr res =
let rec cfg_expr_of_eexpr struct_table fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarinmem: (string, int) Hashtbl.t) (e: Elang.expr) : expr res =
match e with
| Elang.Ebinop (b, e1, e2) ->
let* t1 = type_expr funvartyp fun_typ e1 in
let* t2 = type_expr funvartyp fun_typ e2 in
let* value1 = cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e1 in
let* value2 = cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e2 in
let* t1 = type_expr struct_table funvartyp fun_typ e1 in
let* t2 = type_expr struct_table funvartyp fun_typ e2 in
let* value1 = cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e1 in
let* value2 = cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e2 in
(match t1 with
| Tptr t ->
let* size = size_type t in
let* size = size_type t struct_table in
OK(Ebinop(b, value1, Ebinop(Emul, value2, Eint size)))
| _ ->
(match t2 with
| Tptr t ->
let* size = size_type t in
let* size = size_type t struct_table in
OK(Ebinop(b, (Ebinop(Emul, value1, Eint size)), value2))
| _ ->
OK (Ebinop (b, value1, value2))
))
| Elang.Eunop (u, e) ->
cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e >>= fun ee ->
cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e >>= fun ee ->
OK (Eunop (u, ee))
| Elang.Eint i -> OK (Eint i)
| Elang.Echar c -> OK (Eint (Char.code c))
......@@ -43,12 +43,12 @@ let rec cfg_expr_of_eexpr fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarin
(
match Hashtbl.find_option funvarinmem v with
| Some offset ->
let* mem_to_read = size_type (Hashtbl.find funvartyp v) in
let* mem_to_read = size_type (Hashtbl.find funvartyp v) struct_table in
OK(Eload(Estk offset,mem_to_read))
| None ->OK (Evar v)
)
| Elang.Ecall(name, elist) ->
let* args_expr = list_map_res (cfg_expr_of_eexpr fun_typ funvartyp funvarinmem) elist in
let* args_expr = list_map_res (cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem) elist in
OK(Cfg.Ecall(name, args_expr))
| Elang.Eaddrof (e) ->
(match e with
......@@ -60,15 +60,16 @@ let rec cfg_expr_of_eexpr fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarin
| _ -> Error "unauthorised operation: & on non var"
)
| Elang.Eload e ->
let* cfg_e = cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e in
let* type_to_load = type_expr funvartyp fun_typ e in
let* cfg_e = cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e in
let* type_to_load = type_expr struct_table funvartyp fun_typ e in
(match type_to_load with
| Tptr t ->
let* size = size_type t in
let* size = size_type t struct_table in
OK(Eload(cfg_e,size))
| _ -> Error "Can't load non pointer")
| _ -> Error "souffle dans mon trou"
(* [cfg_node_of_einstr fun_typ funvartyp funvarinmem next cfg succ i] builds the CFG node(s) that correspond
(* [cfg_node_of_einstr struct_table fun_typ funvartyp funvarinmem next cfg succ i] builds the CFG node(s) that correspond
to the E instruction [i].
[cfg] is the current state of the control-flow graph.
......@@ -83,55 +84,56 @@ let rec cfg_expr_of_eexpr fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarin
Hint: several nodes may be generated for a single E instruction.
*)
let rec cfg_node_of_einstr fun_typ funvartyp (funvarinmem: (string, int) Hashtbl.t) (next: int) (cfg : (int, cfg_node) Hashtbl.t)
let rec cfg_node_of_einstr struct_table fun_typ funvartyp (funvarinmem: (string, int) Hashtbl.t) (next: int) (cfg : (int, cfg_node) Hashtbl.t)
(succ: int) (i: instr) : (int * int) res =
match i with
| Elang.Iassign (v, e) ->
let* value = cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e in
let* value = cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e in
(match Hashtbl.find_option funvarinmem v with
| Some addr ->
let type_var = Hashtbl.find funvartyp v in
let* size_write = size_type type_var in
let* size_write = size_type type_var struct_table in
Hashtbl.replace cfg next (Cstore(Estk addr,value,size_write, succ));
OK(next, next+1)
| None ->
let* e = cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e in
let* e = cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e in
Hashtbl.replace cfg next (Cassign(v,e,succ));
OK (next, next + 1))
| Elang.Iif (c, ithen, ielse) ->
cfg_expr_of_eexpr fun_typ funvartyp funvarinmem c >>= fun c ->
cfg_node_of_einstr fun_typ funvartyp funvarinmem next cfg succ ithen >>= fun (nthen, next) ->
cfg_node_of_einstr fun_typ funvartyp funvarinmem next cfg succ ielse >>= fun (nelse, next) ->
cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem c >>= fun c ->
cfg_node_of_einstr struct_table fun_typ funvartyp funvarinmem next cfg succ ithen >>= fun (nthen, next) ->
cfg_node_of_einstr struct_table fun_typ funvartyp funvarinmem next cfg succ ielse >>= fun (nelse, next) ->
Hashtbl.replace cfg next (Ccmp(c, nthen, nelse)); OK (next, next + 1)
| Elang.Iwhile (c, i) ->
cfg_expr_of_eexpr fun_typ funvartyp funvarinmem c >>= fun c ->
cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem c >>= fun c ->
let (cmp, next) = (next, next + 1) in
cfg_node_of_einstr fun_typ funvartyp funvarinmem next cfg cmp i >>= fun (nthen, next) ->
cfg_node_of_einstr struct_table fun_typ funvartyp funvarinmem next cfg cmp i >>= fun (nthen, next) ->
Hashtbl.replace cfg cmp (Ccmp(c, nthen, succ)); OK (cmp, next + 1)
| Elang.Iblock il ->
List.fold_right (fun i acc ->
acc >>= fun (succ, next) ->
cfg_node_of_einstr fun_typ funvartyp funvarinmem next cfg succ i
cfg_node_of_einstr struct_table fun_typ funvartyp funvarinmem next cfg succ i
) il (OK (succ, next))
| Elang.Ireturn e ->
cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e >>= fun e ->
cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e >>= fun e ->
Hashtbl.replace cfg next (Creturn e); OK (next, next + 1)
| Elang.Iprint e ->
cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e >>= fun e ->
cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem 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 fun_typ funvartyp funvarinmem) elist in
let* args_expr = list_map_res (cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem) elist in
Hashtbl.replace cfg next (Ccall(name, args_expr, succ));
OK (next,next+1)
| Elang.Istore (e1, e2) ->
let* addr = cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e1 in
let* value = cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e2 in
let* t = type_expr funvartyp fun_typ e1 in
let* size_write = size_type t in
let* addr = cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e1 in
let* value = cfg_expr_of_eexpr struct_table fun_typ funvartyp funvarinmem e2 in
let* t = type_expr struct_table funvartyp fun_typ e1 in
let* size_write = size_type t struct_table in
Hashtbl.replace cfg next (Cstore(addr,value,size_write, succ));
OK(next, next+1)
| _ -> Error "soufle dans mon trou"
......@@ -156,10 +158,10 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) =
in reachable_aux n Set.empty
(* [cfg_fun_of_efun f] builds the CFG for E function [f]. *)
let cfg_fun_of_efun fun_typ { funargs; funbody; funvartyp; funvarinmem; funstksz } =
let cfg_fun_of_efun struct_table fun_typ { funargs; funbody; funvartyp; funvarinmem; funstksz } =
let cfg = Hashtbl.create 17 in
Hashtbl.replace cfg 0 (Creturn (Eint 0));
cfg_node_of_einstr fun_typ funvartyp funvarinmem 1 cfg 0 funbody >>= fun (node, _) ->
cfg_node_of_einstr struct_table fun_typ funvartyp funvarinmem 1 cfg 0 funbody >>= fun (node, _) ->
(* remove unreachable nodes *)
let r = reachable_nodes node cfg in
Hashtbl.filteri_inplace (fun k _ -> Set.mem k r) cfg;
......@@ -169,20 +171,21 @@ let cfg_fun_of_efun fun_typ { funargs; funbody; funvartyp; funvarinmem; funstksz
cfgfunstksz = funstksz;
}
let cfg_gdef_of_edef fun_typ gd =
let cfg_gdef_of_edef struct_table fun_typ gd =
match gd with
Gfun f -> cfg_fun_of_efun fun_typ f >>= fun f -> OK (Gfun f)
Gfun f -> cfg_fun_of_efun struct_table fun_typ f >>= fun f -> OK (Gfun f)
let cfg_prog_of_eprog (ep: eprog) : cfg_fun prog res =
let fun_typ = Hashtbl.create (3+(List.length ep)) in
let (fun_list, struct_table) = ep in
let fun_typ = Hashtbl.create (3+(List.length fun_list)) in
List.iter (fun (name,pro) ->
match pro with
| Gfun f -> Hashtbl.replace fun_typ name ((snd (List.split f.funargs)),f.funrettype);
)ep;
)fun_list;
Hashtbl.replace fun_typ "print" ([Tint], Tvoid);
Hashtbl.replace fun_typ "print_int" ([Tint], Tvoid);
Hashtbl.replace fun_typ "print_char" ([Tchar], Tvoid);
assoc_map_res (fun fname -> cfg_gdef_of_edef fun_typ) ep
assoc_map_res (fun fname -> cfg_gdef_of_edef struct_table fun_typ) fun_list
let pass_cfg_gen ep =
match cfg_prog_of_eprog ep with
......
src/elang.ml
View file @ 9b110917
......@@ -16,6 +16,7 @@ type expr =
| Ecall of string * expr list
| Eaddrof of expr
| Eload of expr
| Egetfield of expr * string
type instr =
| Iassign of string * expr
......@@ -26,6 +27,7 @@ type instr =
| Iprint of expr
| Icall of string * expr list
| Istore of expr * expr
| Isetfield of expr * string * expr
type efun = {
funargs: ( string * typ ) list;
......@@ -36,4 +38,4 @@ type efun = {
funstksz : int
}
type eprog = efun prog
type eprog = efun prog * (string, (string * typ) list) Hashtbl.t
src/elang_gen.ml
View file @ 9b110917
......@@ -50,19 +50,23 @@ let binop_of_tag =
| _ -> assert false
let rec type_expr
let rec type_expr struct_table
(typ_var : (string,typ) Hashtbl.t)
(typ_fun : (string, typ list * typ) Hashtbl.t)
(e: expr)
: typ res =
match e with
| Ebinop(op,e1,e2) -> type_expr typ_var typ_fun e1
| Eunop(op,e) -> type_expr typ_var typ_fun e
| Ebinop(op,e1,e2) -> type_expr struct_table typ_var typ_fun e1
| Eunop(op,e) -> type_expr struct_table typ_var typ_fun e
| Eint n -> OK Tint
| Echar c -> OK Tchar
| Evar v ->
(match Hashtbl.find_option typ_var v with
| Some t -> OK t
| Some t ->(
match t with
| Tstruct name -> OK (Tptr t)
| _ -> OK t
)
| None -> Error (Format.sprintf "variable %s not found (unknown type)" v)
)
| Ecall (func, el) ->
......@@ -71,13 +75,19 @@ let rec type_expr
| None -> Error (Format.sprintf "function %s not found (unknown type)" func)
)
| Eaddrof (e) ->
let* type_e = type_expr typ_var typ_fun e in
let* type_e = type_expr struct_table typ_var typ_fun e in
OK(Tptr type_e)
| Eload e ->
let* type_e = type_expr typ_var typ_fun e in
match type_e with
let* type_e = type_expr struct_table typ_var typ_fun e in
(match type_e with
| Tptr t -> OK t
| _ -> Error "Can't deference a non pointer type"
| _ -> Error "Can't deference a non pointer type")
| Egetfield (e,s) ->
let* et = type_expr struct_table typ_var typ_fun e in
match et with
| Tptr Tstruct name -> field_type struct_table name s
| _ -> Error "Can only get field of struct"
let are_types_compatible (t1: typ) (t2:typ): typ res =
match t1 with
......@@ -87,11 +97,13 @@ let are_types_compatible (t1: typ) (t2:typ): typ res =
| Tint | Tchar -> OK(t1)
| _ -> Error (Format.sprintf "Incompatible type %s %s" (string_of_typ t1) (string_of_typ t2))
)
| Tptr Tstruct name -> if t2 = Tstruct name || t2 = Tptr (Tstruct name) then OK(t1) else Error (Printf.sprintf "Incompatible type %s %s" (string_of_typ t1) (string_of_typ t2))
| Tstruct name -> if t2 = Tstruct name || t2 = Tptr (Tstruct name) then OK(t1) else Error (Printf.sprintf "Incompatible type %s %s" (string_of_typ t1) (string_of_typ t2))
| Tptr t -> (
match t2 with
| Tptr t' -> if t = t' then OK(t) else Error "Pointer of two different types"
| Tint -> OK(Tint)
| _ -> Error "Incompatible type: pointers are integers"
match t2 with
| Tptr t' -> if t = t' then OK(t) else Error "Pointer of two different types"
| Tint -> OK(Tint)
| _ -> Error "Incompatible type: pointers are integers"
)
| _ -> Error (Format.sprintf "Incompatible type %s %s" (string_of_typ t1) (string_of_typ t2))
......@@ -109,7 +121,6 @@ let type_expr_binop (op:binop) (t1: typ) (t2:typ): typ res =
)
| _ -> error
)
| Tptr t' -> (
match t2 with
| Tint | Tchar when op = Eadd || op = Esub -> OK t1
......@@ -118,7 +129,7 @@ let type_expr_binop (op:binop) (t1: typ) (t2:typ): typ res =
| Eclt | Ecle | Ecgt | Ecge | Eceq | Ecne -> OK Tint
| _ -> error
)
| _ -> error
| _-> error
)
| _ -> error
......@@ -134,6 +145,7 @@ let rec addr_taken_expr (e: expr) : string Set.t =
match e with
| Ebinop (_,e1,e2) -> Set.union (addr_taken_expr e1) (addr_taken_expr e2)
| Eload (e)
| Egetfield (e,_)
| Eunop (_,e) -> addr_taken_expr e
| Ecall (_,el) -> List.fold_left (fun acc e -> Set.union acc (addr_taken_expr e)) Set.empty el
| Eaddrof (Evar(v)) -> Set.singleton v
......@@ -151,15 +163,21 @@ let rec addr_taken_instr (i: instr) : string Set.t =
| Ireturn e -> addr_taken_expr e
| Iprint e -> addr_taken_expr e
| Icall (_,el) -> List.fold_left (fun acc e -> Set.union acc (addr_taken_expr e)) Set.empty el
| Isetfield(e1,_,e2)
| Istore (e1,e2) -> Set.union (addr_taken_expr e1)(addr_taken_expr e2)
let gen_funvarinmem i funvartyp: ((string, int )Hashtbl.t * int) res=
let gen_funvarinmem i funvartyp struct_table: ((string, int )Hashtbl.t * int) res=
let var_in_mem = addr_taken_instr i in
let var_in_mem = Hashtbl.fold (fun name typv acc ->
match typv with
| Tstruct _ -> Set.union (Set.singleton name) acc
| _ -> acc
) funvartyp var_in_mem in
Set.fold (
fun var acc ->
let* (table, size) = acc in
let var_typ = Hashtbl.find funvartyp var in
let* offset = size_type var_typ in
let* offset = size_type var_typ struct_table in
Hashtbl.replace table var size;
OK (table, size + offset)
) var_in_mem (OK (Hashtbl.create (Set.cardinal var_in_mem), 0))
......@@ -168,7 +186,9 @@ let gen_funvarinmem i funvartyp: ((string, int )Hashtbl.t * int) res=
the tree is not well-formed, fails with an [Error] message. *)
let rec make_eexpr_of_ast (a: tree)
(typ_var : (string,typ) Hashtbl.t)
(typ_fun : (string, typ list * typ) Hashtbl.t) : (expr * typ) res =
(typ_fun : (string, typ list * typ) Hashtbl.t)
(struct_table: (string, (string * Prog.typ) list) Hashtbl.t)
: (expr * typ) res =
let res =
match a with
| Node(Tcall, StringLeaf(name)::r) ->
......@@ -176,51 +196,76 @@ let rec make_eexpr_of_ast (a: tree)
| Node(Targs, l )::[] -> l
| _ -> []
) in
list_map_res (fun e -> make_eexpr_of_ast e typ_var typ_fun) args_list >>= fun args_expr ->
list_map_res (fun e -> make_eexpr_of_ast e typ_var typ_fun struct_table) args_list >>= fun args_expr ->
let (args_expr, args_t) = List.split args_expr in
let returned_expression = Ecall(name, args_expr) in
let (args_typ,_) = Hashtbl.find typ_fun name in
if (List.length args_typ) != (List.length args_t) then Error (Format.sprintf "%s called with %d instead of %d" name (List.length args_t) (List.length args_typ) ) else
let does_args_typ_match = List.for_all2 (=) args_typ args_t in
let does_args_typ_match = List.for_all2 (
fun t1 t2 ->
match are_types_compatible t1 t2 with
| OK _ -> true
| Error _ -> false
) args_typ args_t in
if does_args_typ_match then
let* t = type_expr typ_var typ_fun returned_expression in
let* t = type_expr struct_table typ_var typ_fun returned_expression in
OK (returned_expression, t)
else Error (Format.sprintf "arguments types does not match in expression calling %s" name)
| Node(t, [e1; e2]) when tag_is_binop t ->
make_eexpr_of_ast e1 typ_var typ_fun >>= fun (expr1,t1) ->
make_eexpr_of_ast e2 typ_var typ_fun >>= fun (expr2,t2) ->
make_eexpr_of_ast e1 typ_var typ_fun struct_table >>= fun (expr1,t1) ->
make_eexpr_of_ast e2 typ_var typ_fun struct_table >>= fun (expr2,t2) ->
let op = binop_of_tag t in
let* t1 = type_expr_binop op t1 t2 in
OK (Ebinop(op, expr1 , expr2),t1)
| Node(t, [e1]) when tag_is_unop t -> make_eexpr_of_ast e1 typ_var typ_fun >>= fun (expr1,t1) ->
| Node(t, [e1]) when tag_is_unop t -> make_eexpr_of_ast e1 typ_var typ_fun struct_table >>= fun (expr1,t1) ->
let op = unop_of_tag t in
let* t1 = type_expr_unop op t1 in
OK(Eunop(op,expr1), t1)
| Node(t,[e1]) when t = Tint -> make_eexpr_of_ast e1 typ_var typ_fun
| Node(t,[e1]) when t = Tint -> make_eexpr_of_ast e1 typ_var typ_fun struct_table
| IntLeaf(num) -> OK(Eint(num), Tint)
| StringLeaf(str) ->
let returned_expression = Evar(str) in
let* t = type_expr typ_var typ_fun returned_expression in
let* t = type_expr struct_table typ_var typ_fun returned_expression in
OK(returned_expression, t)
| CharLeaf(c) -> OK(Echar(c),Tchar)
| Node(Tp, [e1]) ->
let* (expr, t) = make_eexpr_of_ast e1 typ_var typ_fun in
let* (expr, t) = make_eexpr_of_ast e1 typ_var typ_fun struct_table in
(match t with
| Tptr t -> OK(Eload expr, t)
| _ -> Error (Printf.sprintf "Can't Load non pointer here %s" (string_of_ast a)))
| Node(Taddrof, [e1]) ->
let* (expr, t) = make_eexpr_of_ast e1 typ_var typ_fun in
let* (expr, t) = make_eexpr_of_ast e1 typ_var typ_fun struct_table in
OK(Eaddrof(expr), Tptr t)
| Node(Tstructunfoll,[e1; StringLeaf field]) ->
let* (struct_expr, t) = make_eexpr_of_ast e1 typ_var typ_fun struct_table in
(match t with
| Tptr Tstruct s->
let* t = field_type struct_table s field in
OK(Egetfield(struct_expr, field), t)
| _ -> Error "Bad expression"
)
| Node(Tstructpoint,[e1; StringLeaf field]) -> (
let* (struct_expr, t) = make_eexpr_of_ast e1 typ_var typ_fun struct_table in
match t with
| Tptr Tstruct name ->
let* t' = field_type struct_table name field in
OK (Eaddrof (Egetfield (struct_expr,field)), Tptr t')
| Tstruct name ->
let* t' = field_type struct_table name field in
OK (Eaddrof (Egetfield ((Eaddrof struct_expr),field)), Tptr t')
| _ -> Error "It should point to struct"
)
| _ -> Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
(string_of_ast a))
in
match res with
(match res with
OK o -> res
| Error msg -> Error (Format.sprintf "In make_eexpr_of_ast %s:\n%s"
(string_of_ast a) msg)
(string_of_ast a) msg))
let rec make_einstr_of_ast (a: tree) typ_var typ_fun ret_typ: instr res =
let rec make_einstr_of_ast (a: tree) typ_var typ_fun struct_table (ret_typ:typ): instr res =
let res =
match a with
| NullLeaf -> OK(Iblock [])
......@@ -229,67 +274,86 @@ let rec make_einstr_of_ast (a: tree) typ_var typ_fun ret_typ: instr res =
| Node(Targs, l )::[] -> l
| _ -> []
) in
list_map_res (fun e -> make_eexpr_of_ast e typ_var typ_fun) args_list >>= fun args_expr ->
list_map_res (fun e -> make_eexpr_of_ast e typ_var typ_fun struct_table) args_list >>= fun args_expr ->
let (args_expr, args_t) = List.split args_expr in
let returned_expression = Icall(name, args_expr) in
let (args_typ,_) = Hashtbl.find typ_fun name in
if (List.length args_typ) != (List.length args_t) then Error (Format.sprintf "%s called with %d instead of %d" name (List.length args_t) (List.length args_typ) ) else
let does_args_typ_match = List.for_all2 (=) args_typ args_t in
let does_args_typ_match = List.for_all2 (
fun t1 t2 ->
match are_types_compatible t1 t2 with
| OK _ -> true
| Error _ -> false
) args_typ args_t in
if does_args_typ_match then
let* t = type_expr typ_var typ_fun (Ecall(name, args_expr)) in
let* t = type_expr struct_table typ_var typ_fun (Ecall(name, args_expr)) in
OK (returned_expression)
else Error (Format.sprintf "arguments types does not match in expression calling %s" name)