jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Tabs, trailing ws and long lines shall receive no mercy!

Browse source
This commit is contained in:
Adrien Guatto 2010-06-26 16:53:25 +02:00
parent 7323c83f79
commit b4ddefa65c
52 changed files with 2792 additions and 2732 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
compiler/global/location.ml
View file

@ -10,7 +10,6 @@ type location =
* int (* Position of the next character following the last one *) * int (* Position of the next character following the last one *)
let input_name = ref "" (* Input file name. *) let input_name = ref "" (* Input file name. *)
let input_chan = ref stdin (* The channel opened on the input. *) let input_chan = ref stdin (* The channel opened on the input. *)

7
compiler/global/names.ml
View file

@ -57,7 +57,8 @@ let is_infix s =
let print_name ff n = let print_name ff n =
let n = if is_infix n let n = if is_infix n
then "( " ^ (n ^ " )") (* do not remove the space around n, since for example "(*" would create bugs *) then "( " ^ (n ^ " )") (* do not remove the space around n, since for example
"(*" would create bugs *)
else n else n
in Format.fprintf ff "%s" n in Format.fprintf ff "%s" n
@ -65,6 +66,8 @@ let print_longname ff n =
match n with match n with
| Name m -> print_name ff m | Name m -> print_name ff m
| Modname { qual = "Pervasives"; id = m } -> print_name ff m | Modname { qual = "Pervasives"; id = m } -> print_name ff m
| Modname { qual = m1; id = m2 } -> (Format.fprintf ff "%s." m1; print_name ff m2) | Modname { qual = m1; id = m2 } ->
Format.fprintf ff "%s." m1;
print_name ff m2

2
compiler/global/types.ml
View file

@ -16,8 +16,6 @@ let invalid_type = Tprod []
let const_array_of ty n = Tarray (ty, SConst n) let const_array_of ty n = Tarray (ty, SConst n)
open Pp_tools open Pp_tools
open Format open Format

3
compiler/heptagon/analysis/causality.ml
View file

@ -90,7 +90,8 @@ let clear env c =
clearec c clearec c
let build dec = let build dec =
List.fold_left (fun acc { v_name = n } -> IdentSet.add n acc) IdentSet.empty dec let add acc { v_name = n; } = IdentSet.add n acc in
List.fold_left add IdentSet.empty dec
(** Main typing function *) (** Main typing function *)
let rec typing e = let rec typing e =

40
compiler/heptagon/analysis/typing.ml
View file

@ -371,7 +371,8 @@ let rec merge local_names_list =
let all_last h env = let all_last h env =
Env.iter Env.iter
(fun elt _ -> (fun elt _ ->
if not (Env.find elt h).last then error (Elast_undefined(sourcename elt))) if not (Env.find elt h).last
then error (Elast_undefined(sourcename elt)))
env env
let last = function | Var -> false | Last _ -> true let last = function | Var -> false | Last _ -> true
@ -466,7 +467,8 @@ let rec typing statefull h e =
if List.length l <> List.length fields then if List.length l <> List.length fields then
message e.e_loc Esome_fields_are_missing; message e.e_loc Esome_fields_are_missing;
check_field_unicity l; check_field_unicity l;
let l = List.map (typing_field statefull h fields (Tid (Modname q))) l in let l =
List.map (typing_field statefull h fields (Tid (Modname q))) l in
Estruct l, Tid (Modname q) Estruct l, Tid (Modname q)
| Earray (exp::e_list) -> | Earray (exp::e_list) ->
@ -525,7 +527,8 @@ and typing_app statefull h op e_list =
params in params in
let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
let typed_e_list = typing_args statefull h expected_ty_list e_list in let typed_e_list = typing_args statefull h expected_ty_list e_list in
let size_constrs = instanciate_constr m ty_desc.node_params_constraints in let size_constrs =
instanciate_constr m ty_desc.node_params_constraints in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in let result_ty_list = List.map (subst_type_vars m) result_ty_list in
List.iter add_size_constr size_constrs; List.iter add_size_constr size_constrs;
(prod result_ty_list, (prod result_ty_list,
@ -566,7 +569,8 @@ and typing_array_op statefull h op e_list =
| Eselect_dyn, e1::defe::idx_list -> | Eselect_dyn, e1::defe::idx_list ->
let typed_e1, t1 = typing statefull h e1 in let typed_e1, t1 = typing statefull h e1 in
let typed_defe = expect statefull h (element_type t1) defe in let typed_defe = expect statefull h (element_type t1) defe in
let ty, typed_idx_list = typing_array_subscript_dyn statefull h idx_list t1 in let ty, typed_idx_list =
typing_array_subscript_dyn statefull h idx_list t1 in
ty, op, typed_e1::typed_defe::typed_idx_list ty, op, typed_e1::typed_defe::typed_idx_list
| Eupdate idx_list, [e1;e2] -> | Eupdate idx_list, [e1;e2] ->
let typed_e1, t1 = typing statefull h e1 in let typed_e1, t1 = typing statefull h e1 in
@ -600,7 +604,8 @@ and typing_array_op statefull h op e_list =
let m = List.combine (List.map (fun p -> p.p_name) ty_desc.node_params) let m = List.combine (List.map (fun p -> p.p_name) ty_desc.node_params)
params in params in
let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
let size_constrs = instanciate_constr m ty_desc.node_params_constraints in let size_constrs =
instanciate_constr m ty_desc.node_params_constraints in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in let result_ty_list = List.map (subst_type_vars m) result_ty_list in
let typed_e = expect statefull h (Tid Initial.pint) e in let typed_e = expect statefull h (Tid Initial.pint) e in
let e = size_exp_of_exp e in let e = size_exp_of_exp e in
@ -631,11 +636,13 @@ and typing_iterator statefull h it n args_ty_list result_ty_list e_list =
match it with match it with
| Imap -> | Imap ->
let args_ty_list = List.map (fun ty -> Tarray(ty, n)) args_ty_list in let args_ty_list = List.map (fun ty -> Tarray(ty, n)) args_ty_list in
let result_ty_list = List.map (fun ty -> Tarray(ty, n)) result_ty_list in let result_ty_list =
List.map (fun ty -> Tarray(ty, n)) result_ty_list in
let typed_e_list = typing_args statefull h args_ty_list e_list in let typed_e_list = typing_args statefull h args_ty_list e_list in
prod result_ty_list, typed_e_list prod result_ty_list, typed_e_list
| Ifold -> | Ifold ->
let args_ty_list = incomplete_map (fun ty -> Tarray (ty, n)) args_ty_list in let args_ty_list =
incomplete_map (fun ty -> Tarray (ty, n)) args_ty_list in
let typed_e_list = typing_args statefull h args_ty_list e_list in let typed_e_list = typing_args statefull h args_ty_list e_list in
(*check accumulator type matches in input and output*) (*check accumulator type matches in input and output*)
if List.length result_ty_list > 1 then if List.length result_ty_list > 1 then
@ -647,8 +654,10 @@ and typing_iterator statefull h it n args_ty_list result_ty_list e_list =
end; end;
(List.hd result_ty_list), typed_e_list (List.hd result_ty_list), typed_e_list
| Imapfold -> | Imapfold ->
let args_ty_list = incomplete_map (fun ty -> Tarray (ty, n)) args_ty_list in let args_ty_list =
let result_ty_list = incomplete_map (fun ty -> Tarray (ty, n)) result_ty_list in incomplete_map (fun ty -> Tarray (ty, n)) args_ty_list in
let result_ty_list =
incomplete_map (fun ty -> Tarray (ty, n)) result_ty_list in
let typed_e_list = typing_args statefull h args_ty_list e_list in let typed_e_list = typing_args statefull h args_ty_list e_list in
(*check accumulator type matches in input and output*) (*check accumulator type matches in input and output*)
begin try begin try
@ -758,8 +767,8 @@ and typing_automaton_handlers statefull h acc state_handlers =
let typed_e = expect statefull h (Tid Initial.pbool) e in let typed_e = expect statefull h (Tid Initial.pbool) e in
{ esc with e_cond = typed_e } in { esc with e_cond = typed_e } in
let handler let handler ({ s_state = n; s_block = b; s_until = e_list1;
({ s_state = n; s_block = b; s_until = e_list1; s_unless = e_list2 } as s) = s_unless = e_list2 } as s) =
let typed_b, defined_names, h0 = typing_block statefull h b in let typed_b, defined_names, h0 = typing_block statefull h b in
let typed_e_list1 = List.map (escape statefull h0) e_list1 in let typed_e_list1 = List.map (escape statefull h0) e_list1 in
let typed_e_list2 = List.map (escape false h) e_list2 in let typed_e_list2 = List.map (escape false h) e_list2 in
@ -868,7 +877,8 @@ let typing_contract statefull h contract =
let typed_c_list, controllable_names, h = build h h c_list in let typed_c_list, controllable_names, h = build h h c_list in
let typed_l_list, local_names, h' = build h h l_list in let typed_l_list, local_names, h' = build h h l_list in
let typed_eq, defined_names = typing_eq_list statefull h' Env.empty eq in let typed_eq, defined_names =
typing_eq_list statefull h' Env.empty eq in
(* assumption *) (* assumption *)
let typed_e_a = expect statefull h' (Tid Initial.pbool) e_a in let typed_e_a = expect statefull h' (Tid Initial.pbool) e_a in
@ -910,10 +920,12 @@ let node const_env ({ n_name = f;
let typed_o_list, output_names, h = build h h o_list in let typed_o_list, output_names, h = build h h o_list in
(* typing contract *) (* typing contract *)
let typed_contract, controllable_names, h = typing_contract false h contract in let typed_contract, controllable_names, h =
typing_contract false h contract in
let typed_l_list, local_names, h = build h h l_list in let typed_l_list, local_names, h = build h h l_list in
let typed_eq_list, defined_names = typing_eq_list false h Env.empty eq_list in let typed_eq_list, defined_names =
typing_eq_list false h Env.empty eq_list in
(* if not (statefull) & (List.length o_list <> 1) (* if not (statefull) & (List.length o_list <> 1)
then error (Etoo_many_outputs);*) then error (Etoo_many_outputs);*)
let expected_names = add local_names output_names in let expected_names = add local_names output_names in

58
compiler/heptagon/heptagon.ml
View file

@ -44,8 +44,8 @@ type exp =
| Eifthenelse | Eifthenelse
| Earray_op of array_op | Earray_op of array_op
| Efield_update of longname | Efield_update of longname
| Ecall of op_desc * exp option (** [op_desc] is the function called | Ecall of op_desc * exp option (** [op_desc] is the function called [exp
[exp option] is the optional reset condition *) option] is the optional reset condition *)
and array_op = and array_op =
| Erepeat | Erepeat
@ -79,72 +79,74 @@ type eq =
| Ereset of eq list * exp | Ereset of eq list * exp
| Eeq of pat * exp | Eeq of pat * exp
and block = and block = {
{ b_local : var_dec list; b_equs : eq list; mutable b_defnames : ty Env.t; b_local : var_dec list; b_equs : eq list; mutable b_defnames : ty Env.t;
mutable b_statefull : bool; b_loc : location mutable b_statefull : bool; b_loc : location
} }
and state_handler = and state_handler = {
{ s_state : name; s_block : block; s_until : escape list; s_state : name; s_block : block; s_until : escape list;
s_unless : escape list s_unless : escape list
} }
and escape = and escape = {
{ e_cond : exp; e_reset : bool; e_next_state : name e_cond : exp; e_reset : bool; e_next_state : name
} }
and switch_handler = and switch_handler = {
{ w_name : longname; w_block : block w_name : longname; w_block : block
} }
and present_handler = and present_handler = {
{ p_cond : exp; p_block : block p_cond : exp; p_block : block
} }
and var_dec = and var_dec = {
{ v_name : ident; mutable v_type : ty; v_last : last; v_loc : location } v_name : ident; mutable v_type : ty; v_last : last; v_loc : location
}
and last = and last =
| Var | Last of const option | Var | Last of const option
type type_dec = type type_dec = {
{ t_name : name; t_desc : type_desc; t_loc : location } t_name : name; t_desc : type_desc; t_loc : location
}
and type_desc = and type_desc =
| Type_abs | Type_enum of name list | Type_struct of structure | Type_abs | Type_enum of name list | Type_struct of structure
type contract = type contract = {
{ c_assume : exp; c_enforce : exp; c_controllables : var_dec list; c_assume : exp; c_enforce : exp; c_controllables : var_dec list;
c_local : var_dec list; c_eq : eq list c_local : var_dec list; c_eq : eq list
} }
type node_dec = type node_dec = {
{ n_name : name; n_statefull : bool; n_input : var_dec list; n_name : name; n_statefull : bool; n_input : var_dec list;
n_output : var_dec list; n_local : var_dec list; n_output : var_dec list; n_local : var_dec list;
n_contract : contract option; n_equs : eq list; n_loc : location; n_contract : contract option; n_equs : eq list; n_loc : location;
n_params : param list; n_params : param list;
n_params_constraints : size_constr list n_params_constraints : size_constr list
} }
type const_dec = type const_dec = {
{ c_name : name; c_type : ty; c_value : size_exp; c_loc : location } c_name : name; c_type : ty; c_value : size_exp; c_loc : location }
type program = type program = {
{ p_pragmas : (name * string) list; p_opened : name list; p_pragmas : (name * string) list; p_opened : name list;
p_types : type_dec list; p_nodes : node_dec list; p_types : type_dec list; p_nodes : node_dec list;
p_consts : const_dec list p_consts : const_dec list
} }
type signature = type signature = {
{ sig_name : name; sig_inputs : arg list; sig_name : name; sig_inputs : arg list;
sig_outputs : arg list; sig_params : param list sig_outputs : arg list; sig_params : param list
} }
type interface = type interface =
interface_decl list interface_decl list
and interface_decl = and interface_decl = {
{ interf_desc : interface_desc; interf_loc : location interf_desc : interface_desc; interf_loc : location
} }
and interface_desc = and interface_desc =

28
compiler/heptagon/parsing/scoping.ml
View file

@ -124,7 +124,9 @@ let rec translate_size_exp const_env e =
| Econst (Cint i) -> SConst i | Econst (Cint i) -> SConst i
| Eapp(app, [e1;e2]) -> | Eapp(app, [e1;e2]) ->
let op = op_from_app e.e_loc app in let op = op_from_app e.e_loc app in
SOp(op, translate_size_exp const_env e1, translate_size_exp const_env e2) SOp(op,
translate_size_exp const_env e1,
translate_size_exp const_env e2)
| _ -> Error.message e.e_loc Error.Estatic_exp_expected | _ -> Error.message e.e_loc Error.Estatic_exp_expected
let rec translate_type const_env = function let rec translate_type const_env = function
@ -158,8 +160,10 @@ and translate_op_desc const_env desc =
Heptagon.op_kind = translate_op_kind desc.op_kind } Heptagon.op_kind = translate_op_kind desc.op_kind }
and translate_array_op const_env env = function and translate_array_op const_env env = function
| Eselect e_list -> Heptagon.Eselect (List.map (translate_size_exp const_env) e_list) | Eselect e_list ->
| Eupdate e_list -> Heptagon.Eupdate (List.map (translate_size_exp const_env) e_list) Heptagon.Eselect (List.map (translate_size_exp const_env) e_list)
| Eupdate e_list ->
Heptagon.Eupdate (List.map (translate_size_exp const_env) e_list)
| Erepeat -> Heptagon.Erepeat | Erepeat -> Heptagon.Erepeat
| Eselect_slice -> Heptagon.Eselect_slice | Eselect_slice -> Heptagon.Eselect_slice
| Econcat -> Heptagon.Econcat | Econcat -> Heptagon.Econcat
@ -173,12 +177,14 @@ and translate_desc loc const_env env = function
| Evar x -> | Evar x ->
if Rename.mem x env then if Rename.mem x env then
Heptagon.Evar (Rename.name loc env x) Heptagon.Evar (Rename.name loc env x)
else if NamesEnv.mem x const_env then (* var not defined, maybe a const var*) else
if NamesEnv.mem x const_env then (* var not defined, maybe a const var*)
Heptagon.Econstvar x Heptagon.Econstvar x
else else
Error.message loc (Error.Evar x) Error.message loc (Error.Evar x)
| Elast x -> Heptagon.Elast (Rename.name loc env x) | Elast x -> Heptagon.Elast (Rename.name loc env x)
| Etuple e_list -> Heptagon.Etuple (List.map (translate_exp const_env env) e_list) | Etuple e_list ->
Heptagon.Etuple (List.map (translate_exp const_env env) e_list)
| Eapp ({ a_op = (Earray_op Erepeat)} as app, e_list) -> | Eapp ({ a_op = (Earray_op Erepeat)} as app, e_list) ->
let e_list = List.map (translate_exp const_env env) e_list in let e_list = List.map (translate_exp const_env env) e_list in
(match e_list with (match e_list with
@ -191,9 +197,11 @@ and translate_desc loc const_env env = function
Heptagon.Eapp (translate_app const_env env app, e_list) Heptagon.Eapp (translate_app const_env env app, e_list)
| Efield (e, field) -> Heptagon.Efield (translate_exp const_env env e, field) | Efield (e, field) -> Heptagon.Efield (translate_exp const_env env e, field)
| Estruct f_e_list -> | Estruct f_e_list ->
let f_e_list = List.map (fun (f,e) -> f, translate_exp const_env env e) f_e_list in let f_e_list =
List.map (fun (f,e) -> f, translate_exp const_env env e) f_e_list in
Heptagon.Estruct f_e_list Heptagon.Estruct f_e_list
| Earray e_list -> Heptagon.Earray (List.map (translate_exp const_env env) e_list) | Earray e_list ->
Heptagon.Earray (List.map (translate_exp const_env env) e_list)
and translate_pat loc env = function and translate_pat loc env = function
| Evarpat x -> Heptagon.Evarpat (Rename.name loc env x) | Evarpat x -> Heptagon.Evarpat (Rename.name loc env x)
@ -268,7 +276,8 @@ and translate_last env = function
let translate_contract const_env env ct = let translate_contract const_env env ct =
{ Heptagon.c_assume = translate_exp const_env env ct.c_assume; { Heptagon.c_assume = translate_exp const_env env ct.c_assume;
Heptagon.c_enforce = translate_exp const_env env ct.c_enforce; Heptagon.c_enforce = translate_exp const_env env ct.c_enforce;
Heptagon.c_controllables = translate_vd_list const_env env ct.c_controllables; Heptagon.c_controllables =
translate_vd_list const_env env ct.c_controllables;
Heptagon.c_local = translate_vd_list const_env env ct.c_local; Heptagon.c_local = translate_vd_list const_env env ct.c_local;
Heptagon.c_eq = List.map (translate_eq const_env env) ct.c_eq } Heptagon.c_eq = List.map (translate_eq const_env env) ct.c_eq }
@ -312,7 +321,8 @@ let translate_program p =
{ Heptagon.p_pragmas = p.p_pragmas; { Heptagon.p_pragmas = p.p_pragmas;
Heptagon.p_opened = p.p_opened; Heptagon.p_opened = p.p_opened;
Heptagon.p_types = List.map (translate_typedec const_env) p.p_types; Heptagon.p_types = List.map (translate_typedec const_env) p.p_types;
Heptagon.p_nodes = List.map (translate_node const_env Rename.empty) p.p_nodes; Heptagon.p_nodes =
List.map (translate_node const_env Rename.empty) p.p_nodes;
Heptagon.p_consts = List.map (translate_const_dec const_env) p.p_consts; } Heptagon.p_consts = List.map (translate_const_dec const_env) p.p_consts; }
let translate_arg const_env a = let translate_arg const_env a =

3
compiler/heptagon/transformations/every.ml
View file

@ -90,7 +90,8 @@ and translate v acc_eq_list e =
let re = { re with e_desc = Evar n } in let re = { re with e_desc = Evar n } in
v,acc_eq_list, v,acc_eq_list,
{ e with e_desc = { e with e_desc =
Eapp({ op with a_op = Earray_op(Eiterator(it, op_desc, Some re)) }, Eapp({ op with a_op =
Earray_op(Eiterator(it, op_desc, Some re)) },
e_list) } e_list) }
| Eapp(f, e_list) -> | Eapp(f, e_list) ->
let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in

4
compiler/heptagon/transformations/present.ml
View file

@ -48,7 +48,9 @@ and translate_present_handlers handlers cont =
let translate_present_handler { p_cond = e; p_block = b } cont = let translate_present_handler { p_cond = e; p_block = b } cont =
let statefull = b.b_statefull or cont.b_statefull in let statefull = b.b_statefull or cont.b_statefull in
mk_block ~statefull:statefull b.b_defnames mk_block ~statefull:statefull b.b_defnames
[mk_switch_equation ~statefull:statefull e [{ w_name = ptrue; w_block = b }; [mk_switch_equation
~statefull:statefull e
[{ w_name = ptrue; w_block = b };
{ w_name = pfalse; w_block = cont }]] in { w_name = pfalse; w_block = cont }]] in
let b = List.fold_right translate_present_handler handlers cont in let b = List.fold_right translate_present_handler handlers cont in
List.hd (b.b_equs) List.hd (b.b_equs)

14
compiler/heptagon/transformations/reset.ml
View file

@ -48,8 +48,9 @@ let mk_bool_param n =
let or_op_call = mk_op ( Ecall(mk_op_desc Initial.por [] Eop, None) ) let or_op_call = mk_op ( Ecall(mk_op_desc Initial.por [] Eop, None) )
let pre_true e = let pre_true e = {
{ e with e_desc = Eapp(mk_op (Epre (Some (Cconstr Initial.ptrue))), [e]) } e with e_desc = Eapp(mk_op (Epre (Some (Cconstr Initial.ptrue))), [e])
}
let init e = pre_true { dfalse with e_loc = e.e_loc } let init e = pre_true { dfalse with e_loc = e.e_loc }
(* the boolean condition for a structural reset *) (* the boolean condition for a structural reset *)
@ -111,10 +112,12 @@ let add_local_equations i n m lm acc =
(* [mi = false;...; m1 = l_m1;...; mn = l_mn] *) (* [mi = false;...; m1 = l_m1;...; mn = l_mn] *)
let rec loop acc k = let rec loop acc k =
if k < n then if k < n then
if k = i then loop ((mk_simple_equation (Evarpat (m.(k))) dfalse) :: acc) (k+1) if k = i
then loop ((mk_simple_equation (Evarpat (m.(k))) dfalse) :: acc) (k+1)
else else
loop loop
((mk_simple_equation (Evarpat (m.(k))) (mk_bool_var lm.(k))) :: acc) (k+1) ((mk_simple_equation (Evarpat (m.(k))) (mk_bool_var lm.(k))) :: acc)
(k+1)
else acc else acc
in loop acc 0 in loop acc 0
@ -233,7 +236,8 @@ and translate res e =
else else
{ e with e_desc = Eapp(op, e_list ) } { e with e_desc = Eapp(op, e_list ) }
(* add reset to the current reset exp. *) (* add reset to the current reset exp. *)
| Eapp( { a_op = Earray_op (Eiterator(it, op_desc, Some re)) } as op, e_list) -> | Eapp( { a_op = Earray_op (Eiterator(it, op_desc, Some re)) } as op,
e_list) ->
let re = translate res re in let re = translate res re in
let e_list = List.map (translate res) e_list in let e_list = List.map (translate res) e_list in
let r = Some (or_op res re) in let r = Some (or_op res re) in

21
compiler/main/hept2mls.ml
View file

@ -56,7 +56,8 @@ struct
let add l env = let add l env =
Ecomp(env, Ecomp(env,
List.fold_left List.fold_left
(fun acc { Heptagon.v_name = n } -> IdentSet.add n acc) IdentSet.empty l) (fun acc { Heptagon.v_name = n } ->
IdentSet.add n acc) IdentSet.empty l)
(* sample e according to the clock [base on C1(x1) on ... on Cn(xn)] *) (* sample e according to the clock [base on C1(x1) on ... on Cn(xn)] *)
let con env x e = let con env x e =
@ -150,7 +151,9 @@ let switch x ci_eqs_list =
then () then ()
else else
begin begin
List.iter (fun (x,e) -> Printf.eprintf "|%s|, " (name x)) firsts; List.iter
(fun (x,e) -> Printf.eprintf "|%s|, " (name x))
firsts;
assert false assert false
end; end;
check_eqs nexts in check_eqs nexts in
@ -221,9 +224,9 @@ and translate_array_op env op e_list =
Erepeat (size_exp_of_exp idx, e) Erepeat (size_exp_of_exp idx, e)
| Heptagon.Eselect idx_list, [e] -> | Heptagon.Eselect idx_list, [e] ->
Eselect (idx_list, e) Eselect (idx_list, e)
(*Little hack: we need the to access the type of the array being accessed to (*Little hack: we need the to access the type of the array being
store the bounds (which will be used at code generation time, where the types accessed to store the bounds (which will be used at code generation
are harder to find). *) time, where the types are harder to find). *)
| Heptagon.Eselect_dyn, e::defe::idx_list -> | Heptagon.Eselect_dyn, e::defe::idx_list ->
let bounds = bounds_list e.e_ty in let bounds = bounds_list e.e_ty in
Eselect_dyn (idx_list, bounds, e, defe) Eselect_dyn (idx_list, bounds, e, defe)
@ -262,7 +265,8 @@ let rec translate env
mk_exp ~loc:loc ~exp_ty:ty (Estruct f_e_list) mk_exp ~loc:loc ~exp_ty:ty (Estruct f_e_list)
| Heptagon.Earray(e_list) -> | Heptagon.Earray(e_list) ->
mk_exp ~loc:loc ~exp_ty:ty (Earray (List.map (translate env) e_list)) mk_exp ~loc:loc ~exp_ty:ty (Earray (List.map (translate env) e_list))
| Heptagon.Elast _ -> Error.message loc Error.Eunsupported_language_construct | Heptagon.Elast _ ->
Error.message loc Error.Eunsupported_language_construct
let rec translate_pat = function let rec translate_pat = function
| Heptagon.Evarpat(n) -> Evarpat n | Heptagon.Evarpat(n) -> Evarpat n
@ -342,7 +346,10 @@ and translate_switch_handlers env ni (locals, l_eqs, s_eqs) e handlers =
[] -> IdentSet.empty [] -> IdentSet.empty
| { Heptagon.w_block = { Heptagon.b_defnames = env } } :: _ -> | { Heptagon.w_block = { Heptagon.b_defnames = env } } :: _ ->
(* Create set from env *) (* Create set from env *)
(Ident.Env.fold (fun name _ set -> IdentSet.add name set) env IdentSet.empty) in (Ident.Env.fold
(fun name _ set -> IdentSet.add name set)
env
IdentSet.empty) in
let ni_handlers = def handlers in let ni_handlers = def handlers in
let x, locals, l_eqs = equation locals l_eqs (translate env e) in let x, locals, l_eqs = equation locals l_eqs (translate env e) in

3
compiler/minils/analysis/init.ml
View file

@ -226,7 +226,8 @@ let rec typing h e =
| Ewhen (e, c, n) -> | Ewhen (e, c, n) ->
let { t_init = i1 } = Env.find n h in let { t_init = i1 } = Env.find n h in
let i2 = itype (typing h e) in skeleton (max i1 i2) e.e_ty let i2 = itype (typing h e) in skeleton (max i1 i2) e.e_ty
(* result of the encoding of e1 -> e2 == if true fby false then e1 else e2 *) (* result of the encoding of e1 -> e2 ==
if true fby false then e1 else e2 *)
| Eifthenelse( | Eifthenelse(
{ e_desc = Efby(Some (Cconstr tn), { e_desc = Econst (Cconstr fn) }) }, { e_desc = Efby(Some (Cconstr tn), { e_desc = Econst (Cconstr fn) }) },
e2, e3) when tn = Initial.ptrue & fn = Initial.pfalse -> e2, e3) when tn = Initial.ptrue & fn = Initial.pfalse ->

23
compiler/minils/minils.ml
View file

@ -45,9 +45,11 @@ and edesc =
| Econstvar of name | Econstvar of name
| Efby of const option * exp | Efby of const option * exp
| Etuple of exp list | Etuple of exp list
| Ecall of op_desc * exp list * ident option (** [op_desc] is the function called | Ecall of op_desc * exp list * ident option (** [op_desc] is the function
[exp list] is the passed arguments called [exp list] is the
[ident option] is the optional reset condition *) passed arguments [ident
option] is the optional reset
condition *)
| Ewhen of exp * longname * ident | Ewhen of exp * longname * ident
| Emerge of ident * (longname * exp) list | Emerge of ident * (longname * exp) list
@ -61,15 +63,16 @@ and edesc =
and array_op = and array_op =
| Erepeat of size_exp * exp | Erepeat of size_exp * exp
| Eselect of size_exp list * exp (*indices, array*) | Eselect of size_exp list * exp (*indices, array*)
| Eselect_dyn of exp list * size_exp list * exp * exp (*indices, bounds, array, default*) | Eselect_dyn of exp list * size_exp list * exp * exp (* indices, bounds,
array, default*)
| Eupdate of size_exp list * exp * exp (*indices, array, value*) | Eupdate of size_exp list * exp * exp (*indices, array, value*)
| Eselect_slice of size_exp * size_exp * exp (*lower bound, upper bound, array*) | Eselect_slice of size_exp * size_exp * exp (*lower bound, upper bound,
array*)
| Econcat of exp * exp | Econcat of exp * exp
| Eiterator of iterator_type * op_desc * size_exp * exp list * ident option (** | Eiterator of iterator_type * op_desc * size_exp * exp list * ident option
[op_desc] is the function iterated, (** [op_desc] is the function iterated, [size_exp] is the size of the
[size_exp] is the size of the iteration, iteration, [exp list] is the passed arguments, [ident option] is the
[exp list] is the passed arguments, optional reset condition *)
[ident option] is the optional reset condition *)
and op_desc = { op_name: longname; op_params: size_exp list; op_kind: op_kind } and op_desc = { op_name: longname; op_params: size_exp list; op_kind: op_kind }
and op_kind = | Eop | Enode and op_kind = | Eop | Enode

6
compiler/minils/sequential/c.ml
View file

@ -129,9 +129,9 @@ and cfile_desc =
(** {3 Pretty-printing of the C ast.} *) (** {3 Pretty-printing of the C ast.} *)
(** [pp_list1 f sep fmt l] pretty-prints into the Format.formatter [fmt] elements (** [pp_list1 f sep fmt l] pretty-prints into the Format.formatter [fmt]
of the list [l] via the function [f], separated by [sep] strings and elements of the list [l] via the function [f], separated by [sep] strings
breakable spaces. *) and breakable spaces. *)
let rec pp_list1 f sep fmt l = match l with let rec pp_list1 f sep fmt l = match l with
| [] -> fprintf fmt "" | [] -> fprintf fmt ""
| [x] -> fprintf fmt "%a" f x | [x] -> fprintf fmt "%a" f x

3
compiler/minils/sequential/c.mli
View file

@ -45,7 +45,8 @@ and cexpr =
| Cconst of cconst (** Constants. *) | Cconst of cconst (** Constants. *)
| Clhs of clhs (** Left-hand-side expressions are obviously expressions! *) | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *)
| Caddrof of clhs (** Take the address of a left-hand-side expression. *) | Caddrof of clhs (** Take the address of a left-hand-side expression. *)
| Cstructlit of string * cexpr list (** Structure literal " \{f1, f2, ... \}". *) | Cstructlit of string * cexpr list (** Structure literal
" \{f1, f2, ... \}". *)
| Carraylit of cexpr list (** Array literal [e1, e2, ...]. *) | Carraylit of cexpr list (** Array literal [e1, e2, ...]. *)
and cconst = and cconst =
| Ccint of int (** Integer constant. *) | Ccint of int (** Integer constant. *)

11
compiler/minils/sequential/cgen.ml
View file

@ -41,7 +41,8 @@ struct
eprintf "%aCode generation : Unnamed outputs are not supported.\n" eprintf "%aCode generation : Unnamed outputs are not supported.\n"
output_location loc output_location loc
| Ederef_not_pointer -> | Ederef_not_pointer ->
eprintf "%aCode generation : Trying to deference a non pointer type. \n" eprintf
"%aCode generation : Trying to deference a non pointer type.\n"
output_location loc output_location loc
end; end;
raise Misc.Error raise Misc.Error
@ -855,7 +856,8 @@ let cfile_list_of_oprog name oprog =
List.iter add_opened_module deps; List.iter add_opened_module deps;
let cfile_name = String.uncapitalize cd.cl_id in let cfile_name = String.uncapitalize cd.cl_id in
let mem_cdecl,use_ctrlr,(cdecls, cdefs) = cdefs_and_cdecls_of_class_def cd in let mem_cdecl,use_ctrlr,(cdecls, cdefs) =
cdefs_and_cdecls_of_class_def cd in
let cfile_mem = cfile_name ^ "_mem" in let cfile_mem = cfile_name ^ "_mem" in
add_opened_module cfile_mem; add_opened_module cfile_mem;
@ -898,8 +900,9 @@ let global_file_header name prog =
let ty_decls = List.concat ty_decls in let ty_decls = List.concat ty_decls in
let mem_step_fun_decls = List.map mem_decl_of_class_def prog.o_defs in let mem_step_fun_decls = List.map mem_decl_of_class_def prog.o_defs in
let reset_fun_decls = let reset_fun_decls =
List.map let cdecl_of_reset_fun cd =
(fun cd -> cdecl_of_cfundef (reset_fun_def_of_class_def cd)) prog.o_defs in cdecl_of_cfundef (reset_fun_def_of_class_def cd) in
List.map cdecl_of_reset_fun prog.o_defs in
let step_fun_decls = List.map step_fun_decl prog.o_defs in let step_fun_decls = List.map step_fun_decl prog.o_defs in
(name ^ ".h", Cheader (get_opened_modules (), (name ^ ".h", Cheader (get_opened_modules (),

3
compiler/minils/sequential/csubst.ml
View file

@ -15,7 +15,8 @@ let rec subst_stm map stm =
Cif (subst_exp map e, subst_stm_list map truel, Cif (subst_exp map e, subst_stm_list map truel,
subst_stm_list map falsel) subst_stm_list map falsel)
| Cswitch (e, l) -> | Cswitch (e, l) ->
Cswitch (subst_exp map e, List.map (fun (s, sl) -> s, subst_stm_list map sl) l) Cswitch (subst_exp map e,
List.map (fun (s, sl) -> s, subst_stm_list map sl) l)
| Cwhile (e, l) -> | Cwhile (e, l) ->
Cwhile (subst_exp map e, subst_stm_list map l) Cwhile (subst_exp map e, subst_stm_list map l)
| Cfor (x, i1, i2, l) -> | Cfor (x, i1, i2, l) ->

6
compiler/minils/sequential/java.ml
View file

@ -241,7 +241,8 @@ let rec print_exp ff e p avs ts single =
| Struct_lit(type_name,fields) -> | Struct_lit(type_name,fields) ->
let fields = let fields =
List.sort List.sort
(fun (ln1,_) (ln2,_) -> String.compare (shortname ln1) (shortname ln2)) (fun (ln1,_) (ln2,_) ->
String.compare (shortname ln1) (shortname ln2))
fields in fields in
let exps = List.map (fun (_,e) -> e) fields in let exps = List.map (fun (_,e) -> e) fields in
fprintf ff "new %a(@[<hov>" fprintf ff "new %a(@[<hov>"
@ -501,7 +502,8 @@ let print_step ff n s objs ts single =
print_act ff s.bd objs print_act ff s.bd objs
(List.map (fun vd -> vd.v_name) s.out) ts single; (List.map (fun vd -> vd.v_name) s.out) ts single;
fprintf ff "@ @ return "; fprintf ff "@ @ return ";
if single then fprintf ff "%s" (jname_of_name (Ident.name (List.hd s.out).v_name)) if single
then fprintf ff "%s" (jname_of_name (Ident.name (List.hd s.out).v_name))
else fprintf ff "step_ans"; else fprintf ff "step_ans";
fprintf ff ";@]@ }@ @]" fprintf ff ";@]@ }@ @]"

6
compiler/minils/sequential/mls2obc.ml
View file

@ -87,7 +87,8 @@ let rec
| Minils.Econst v -> Const (translate_const const_env v) | Minils.Econst v -> Const (translate_const const_env v)
| Minils.Evar n -> Lhs (var_from_name map n) | Minils.Evar n -> Lhs (var_from_name map n)
| Minils.Econstvar n -> Const (Cint (int_of_size_exp const_env (SVar n))) | Minils.Econstvar n -> Const (Cint (int_of_size_exp const_env (SVar n)))
| Minils.Ecall ( { Minils.op_name = n; Minils.op_kind = Minils.Eop }, e_list, _) -> | Minils.Ecall ( { Minils.op_name = n;
Minils.op_kind = Minils.Eop }, e_list, _) ->
Op (n, List.map (translate const_env map (m, si, j, s)) e_list) Op (n, List.map (translate const_env map (m, si, j, s)) e_list)
| Minils.Ewhen (e, _, _) -> translate const_env map (m, si, j, s) e | Minils.Ewhen (e, _, _) -> translate const_env map (m, si, j, s) e
| Minils.Efield (e, field) -> | Minils.Efield (e, field) ->
@ -150,7 +151,8 @@ let rec
let si = let si =
(match opt_c with (match opt_c with
| None -> si | None -> si
| Some c -> (Assgn (x, Const (translate_const const_env c))) :: si) in | Some c ->
(Assgn (x, Const (translate_const const_env c))) :: si) in
let ty = translate_type const_env ty in let ty = translate_type const_env ty in
let m = (n, ty) :: m in let m = (n, ty) :: m in
let action = let action =

3
compiler/minils/transformations/callgraph.ml
View file

@ -56,7 +56,8 @@ let rec collect_exp nodes env e =
(* Do the real work: call node *) (* Do the real work: call node *)
| Ecall( { op_name = ln; op_params = params; op_kind = Eop }, e_list, _) -> | Ecall( { op_name = ln; op_params = params; op_kind = Eop }, e_list, _) ->
List.iter (collect_exp nodes env) e_list List.iter (collect_exp nodes env) e_list
| Ecall( { op_name = ln; op_params = params; op_kind = Enode }, e_list, _) -> | Ecall( { op_name = ln; op_params = params; op_kind = Enode },
e_list, _) ->
List.iter (collect_exp nodes env) e_list; List.iter (collect_exp nodes env) e_list;
let params = List.map (int_of_size_exp env) params in let params = List.map (int_of_size_exp env) params in
call_node_instance nodes ln params call_node_instance nodes ln params

6
compiler/minils/transformations/normalize.ml
View file

@ -145,7 +145,8 @@ let rec translate kind context e =
let context, e1 = translate kind context e1 in let context, e1 = translate kind context e1 in
whenc context e1 c n whenc context e1 c n
| Ecall(op_desc, e_list, r) -> | Ecall(op_desc, e_list, r) ->
let context, e_list = translate_list function_args_kind context e_list in let context, e_list =
translate_list function_args_kind context e_list in
context, { e with e_desc = Ecall(op_desc, e_list, r) } context, { e with e_desc = Ecall(op_desc, e_list, r) }
| Efby(v, e1) -> | Efby(v, e1) ->
let context, e1 = translate Exp context e1 in let context, e1 = translate Exp context e1 in
@ -205,7 +206,8 @@ and translate_array_exp kind context op =
let context, e2 = translate VRef context e2 in let context, e2 = translate VRef context e2 in
context, Econcat(e1, e2) context, Econcat(e1, e2)
| Eiterator (it, op_desc, n, e_list, reset) -> | Eiterator (it, op_desc, n, e_list, reset) ->
let context, e_list = translate_list function_args_kind context e_list in let context, e_list =
translate_list function_args_kind context e_list in
context, Eiterator(it, op_desc, n, e_list, reset) context, Eiterator(it, op_desc, n, e_list, reset)
and translate_list kind context e_list = and translate_list kind context e_list =

1
compiler/minils/transformations/schedule.ml
View file

@ -40,7 +40,6 @@ let n1_list = head e1 in
let n2_list = head e2 in let n2_list = head e2 in
*) *)
(* clever scheduling *) (* clever scheduling *)
let schedule eq_list = let schedule eq_list =
let rec recook = function let rec recook = function

4
compiler/preproc.ml
View file

@ -12,8 +12,8 @@ open Unix
(** [date] is a string denoting the current date. *) (** [date] is a string denoting the current date. *)
let date = let date =
let days = [| "sunday"; "monday"; "tuesday"; "wednesday"; "thursday"; "friday"; let days = [| "sunday"; "monday"; "tuesday"; "wednesday"; "thursday";
"saturday" |] "friday"; "saturday" |]
and months = [| "january"; "february"; "march"; "april"; "may"; "june"; and months = [| "january"; "february"; "march"; "april"; "may"; "june";
"july"; "august"; "september"; "october"; "november"; "july"; "august"; "september"; "october"; "november";
"december" |] in "december" |] in

3
compiler/utilities/global/compiler_utils.ml
View file

@ -75,7 +75,8 @@ and doc_target =
^ " java or z3z)" ^ " java or z3z)"
and doc_full_type_info = "\t\t\tPrint full type information" and doc_full_type_info = "\t\t\tPrint full type information"
and doc_target_path = and doc_target_path =
"<path>\tGenerated files will be placed in <path>\n\t\t\t(the directory is cleaned)" "<path>\tGenerated files will be placed in <path>\n\t\t\t(the directory is"
^ " cleaned)"
and doc_noinit = "\t\tDisable initialization analysis" and doc_noinit = "\t\tDisable initialization analysis"
let errmsg = "Options are:" let errmsg = "Options are:"

3
compiler/utilities/global/dep.ml
View file

@ -69,7 +69,8 @@ struct
List.iter (attach node) names; List.iter (attach node) names;
make_graph g_list names_to_graph in make_graph g_list names_to_graph in
let g_list, names_to_graph, node_env = init_graph eqs [] Env.empty Env.empty in let g_list, names_to_graph, node_env =
init_graph eqs [] Env.empty Env.empty in
make_graph g_list names_to_graph; make_graph g_list names_to_graph;
g_list, node_env g_list, node_env
end end

9
compiler/utilities/graph.ml
View file

@ -38,9 +38,12 @@ let add_depends node1 node2 =
) )
let remove_depends node1 node2 = let remove_depends node1 node2 =
if not (node1.g_tag = node2.g_tag) then ( if not (node1.g_tag = node2.g_tag)
node1.g_depends_on <- List.filter (fun n -> n.g_tag <> node2.g_tag) node1.g_depends_on; then (
node2.g_depends_by <- List.filter (fun n -> n.g_tag <> node1.g_tag) node2.g_depends_by node1.g_depends_on <-
List.filter (fun n -> n.g_tag <> node2.g_tag) node1.g_depends_on;
node2.g_depends_by <-
List.filter (fun n -> n.g_tag <> node1.g_tag) node2.g_depends_by
) )
let graph top_list bot_list = { g_top = top_list; g_bot = bot_list } let graph top_list bot_list = { g_top = top_list; g_bot = bot_list }

3
compiler/utilities/pp_tools.ml
View file

@ -83,7 +83,8 @@ module MapMake (Key : ELT) (Elt : P) = struct
include M include M
let fprint prp eem = let fprint prp eem =
Format.fprintf prp "[@[<hv 2>"; Format.fprintf prp "[@[<hv 2>";
iter (fun k m -> Format.fprintf prp "@ | %a -> %a" Key.fprint k Elt.fprint m) eem; iter (fun k m ->
Format.fprintf prp "@ | %a -> %a" Key.fprint k Elt.fprint m) eem;
Format.fprintf prp "@]@ ]"; Format.fprintf prp "@]@ ]";
end end
*) *)