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

Active Boolean pass and Sigali backend

Browse source
This commit is contained in:
Gwenal Delaval 2011-07-27 11:21:34 +02:00
parent 9e41fcf71f
commit c77386d517
2 changed files with 162 additions and 120 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

161
compiler/heptagon/transformations/boolean.ml
View file

@ -172,7 +172,7 @@ let rec var_list clist =
let t = Tree(t1,t2) in let t = Tree(t1,t2) in
nv2 + 1, vl, t nv2 + 1, vl, t
let var_list prefix n = let nvar_list prefix n =
let rec varl acc = function let rec varl acc = function
| 0 -> acc | 0 -> acc
| n -> | n ->
@ -209,13 +209,14 @@ let translate_ty ty =
| Type(_) -> ty | Type(_) -> ty
| Enum { ty_nb_var = 1 } -> ty_bool | Enum { ty_nb_var = 1 } -> ty_bool
| Enum { ty_nb_var = n } -> | Enum { ty_nb_var = n } ->
let strlist = var_list "" n in let strlist = nvar_list "" n in
Tprod(List.map (fun _ -> ty_bool) strlist) Tprod(List.map (fun _ -> ty_bool) strlist)
end end
with Not_found -> ty with Not_found -> ty
end end
| Tprod(ty_list) -> Tprod(List.map trans ty_list) | Tprod(ty_list) -> Tprod(List.map trans ty_list)
| Tarray(ty,se) -> Tarray(trans ty,se) | Tarray(ty,se) -> Tarray(trans ty,se)
| Tinvalid -> assert false
in in
trans ty trans ty
@ -278,8 +279,7 @@ let translate_const c ty e =
end end
| _ -> Econst(c) | _ -> Econst(c)
(* TODO HERE : ct/ck *) let new_var_list d_list ty ck n =
let new_var_list d_list ty ct n =
let rec varl acc d_list = function let rec varl acc d_list = function
| 0 -> acc,d_list | 0 -> acc,d_list
| n -> | n ->
@ -289,6 +289,10 @@ let new_var_list d_list ty ct n =
varl acc d_list (n-1) in varl acc d_list (n-1) in
varl [] d_list n varl [] d_list n
let assert_ck = function
Ck(ck) -> ck
| Cprod(_) -> assert false
let intro_tuple context e = let intro_tuple context e =
let n = let n =
match e.e_ty with match e.e_ty with
@ -298,9 +302,11 @@ let intro_tuple context e =
Eapp({a_op=Etuple},e_l,None) -> context,e_l Eapp({a_op=Etuple},e_l,None) -> context,e_l
| _ -> | _ ->
let (d_list,eq_list) = context in let (d_list,eq_list) = context in
let v_list,d_list = new_var_list d_list ty_bool e.e_ct_annot n in (* e is not a tuple, therefore e.e_ct_annot = Ck(ck) *)
let ck = assert_ck e.e_ct_annot in
let v_list,d_list = new_var_list d_list ty_bool ck n in
let pat = Etuplepat(List.map (fun v -> Evarpat(v)) v_list) in let pat = Etuplepat(List.map (fun v -> Evarpat(v)) v_list) in
let eq_list = (mk_equation pat e) :: eq_list in let eq_list = (mk_equation (Eeq(pat,e))) :: eq_list in
let e_list = List.map (fun v -> { e with e_ty = ty_bool; e_desc = Evar(v) }) v_list in let e_list = List.map (fun v -> { e with e_ty = ty_bool; e_desc = Evar(v) }) v_list in
(d_list,eq_list),e_list (d_list,eq_list),e_list
@ -309,9 +315,11 @@ let rec when_list e bl vtree =
| [], _ -> e | [], _ -> e
| b::bl', VNode(v,t0,t1) -> | b::bl', VNode(v,t0,t1) ->
let (c,t) = if b then (ctrue,t1) else (cfalse,t0) in let (c,t) = if b then (ctrue,t1) else (cfalse,t0) in
let ck = assert_ck e.e_ct_annot in
let e_v = mk_exp (Evar v) ~ct_annot:(Ck(ck)) ty_bool in
let e_when = { e with let e_when = { e with
e_ct_annot = Con(e.e_ct_annot,c,v); e_ct_annot = Ck(Con(ck,c,v));
e_desc = Ewhen(e,c,v) } in e_desc = Ewhen(e,c,e_v) } in
when_list e_when bl' t when_list e_when bl' t
| _::_, Vempty -> failwith("when_list: non-coherent boolean list and tree") | _::_, Vempty -> failwith("when_list: non-coherent boolean list and tree")
@ -320,14 +328,15 @@ let rec when_ck desc ty ck =
| Cbase | Cvar _ -> | Cbase | Cvar _ ->
{ e_desc = desc; { e_desc = desc;
e_base_ck = Cbase; e_base_ck = Cbase;
e_ct_annot = ck; e_ct_annot = Ck(ck);
e_ty = ty; e_ty = ty;
e_loc = no_location } e_loc = no_location }
| Con(ck',c,v) -> | Con(ck',c,v) ->
let e = when_ck desc ty ck' in let e = when_ck desc ty ck' in
{ e_desc = Ewhen(e,c,v); let e_v = mk_exp (Evar v) ~ct_annot:(Ck(ck')) ty_bool in
{ e_desc = Ewhen(e,c,e_v);
e_base_ck = Cbase; e_base_ck = Cbase;
e_ct_annot = ck; e_ct_annot = Ck(ck);
e_ty = ty; e_ty = ty;
e_loc = no_location } e_loc = no_location }
@ -370,7 +379,7 @@ let rec base_value ck ty =
{ e_desc = mk_tuple e_list; { e_desc = mk_tuple e_list;
e_ty = Tprod(List.map (fun _ -> ty_bool) e_list); e_ty = Tprod(List.map (fun _ -> ty_bool) e_list);
e_base_ck = Cbase; e_base_ck = Cbase;
e_ct_annot = ck; e_ct_annot = Ck(ck);
e_loc = no_location } e_loc = no_location }
end end
with Not_found -> with Not_found ->
@ -381,7 +390,7 @@ let rec base_value ck ty =
{ e_desc = mk_tuple e_list; { e_desc = mk_tuple e_list;
e_ty = Tprod(List.map (fun e -> e.e_ty) e_list); e_ty = Tprod(List.map (fun e -> e.e_ty) e_list);
e_base_ck = Cbase; e_base_ck = Cbase;
e_ct_annot = ck; e_ct_annot = Ck(ck);
e_loc = no_location; e_loc = no_location;
} }
| Tarray(ty,se) -> | Tarray(ty,se) ->
@ -389,30 +398,32 @@ let rec base_value ck ty =
{ e_desc = Eapp((mk_app ~params:[se] Earray_fill), [e], None); { e_desc = Eapp((mk_app ~params:[se] Earray_fill), [e], None);
e_ty = Tarray(e.e_ty,se); e_ty = Tarray(e.e_ty,se);
e_base_ck = Cbase; e_base_ck = Cbase;
e_ct_annot = ck; e_ct_annot = Ck(ck);
e_loc = no_location; e_loc = no_location;
} }
| Tinvalid -> failwith("Boolean: invalid type")
let rec merge_tree ck ty e_map btree vtree = let rec merge_tree ck ty e_map btree vtree =
match btree, vtree with match btree, vtree with
| Node(None), _ -> base_value ck ty | Node(None), _ -> base_value ck ty
| Node(Some name), _ -> | Node(Some name), _ ->
let e = QualEnv.find name e_map in let e = QualEnv.find name e_map in
{ e with e_ct_annot = ck } { e with e_ct_annot = Ck(ck) }
| Tree(t1,t2), VNode(v,vt1,vt2) -> | Tree(t1,t2), VNode(v,vt1,vt2) ->
let e1 = merge_tree (Con(ck,ctrue,v)) ty e_map t1 vt1 let e1 = merge_tree (Con(ck,ctrue,v)) ty e_map t1 vt1
and e2 = merge_tree (Con(ck,cfalse,v)) ty e_map t2 vt2 and e2 = merge_tree (Con(ck,cfalse,v)) ty e_map t2 vt2
in in
{ e_desc = Emerge(v,[(ctrue,e1);(cfalse,e2)]); let e_v = mk_exp (Evar v) ~ct_annot:(Ck(ck)) ty_bool in
{ e_desc = Emerge(e_v,[(ctrue,e1);(cfalse,e2)]);
e_ty = ty; e_ty = ty;
e_base_ck = Cbase; e_base_ck = Cbase;
e_ct_annot = ck; e_ct_annot = Ck(ck);
e_loc = no_location } e_loc = no_location }
| Tree (_,_), Vempty -> failwith("merge_tree: non-coherent trees") | Tree (_,_), Vempty -> failwith("merge_tree: non-coherent trees")
let rec translate env context ({e_desc = desc; e_ty = ty; e_ct_annot = ck} as e) = let rec translate env context ({e_desc = desc; e_ty = ty; e_ct_annot = ct} as e) =
let ck = translate_ct env ck in let ct = translate_ct env ct in
let context,desc = let context,desc =
match desc with match desc with
| Econst(c) -> | Econst(c) ->
@ -428,21 +439,25 @@ let rec translate env context ({e_desc = desc; e_ty = ty; e_ct_annot = ck} as e)
mk_tuple (List.map mk_tuple (List.map
(fun v -> { e with (fun v -> { e with
e_ty = ty_bool; e_ty = ty_bool;
e_ct_annot = ck; e_ct_annot = ct;
e_desc = Evar(v); }) e_desc = Evar(v); })
ident_list) ident_list)
with Not_found -> Evar(name) with Not_found -> Evar(name)
end in end in
context,desc context,desc
| Efby(None, e) -> | Efby(e1,e2) ->
let context,e1 = translate env context e1 in
let context,e2 = translate env context e2 in
context,Efby(e1,e2)
| Epre(None, e) ->
let context,e = translate env context e in let context,e = translate env context e in
context,Efby(None,e) context,Epre(None,e)
| Efby(Some c,e) -> | Epre(Some c,e) ->
let e_c = translate_const c ty e in let e_c = translate_const c ty e in
let context,e = translate env context e in let context,e = translate env context e in
begin begin
match e_c with match e_c with
| Econst(c) -> context,Efby(Some c,e) | Econst(c) -> context,Epre(Some c,e)
| Eapp({ a_op = Etuple },e_c_l,None) -> | Eapp({ a_op = Etuple },e_c_l,None) ->
let context,e_l = intro_tuple context e in let context,e_l = intro_tuple context e in
let c_l = List.map (function let c_l = List.map (function
@ -453,14 +468,14 @@ let rec translate env context ({e_desc = desc; e_ty = ty; e_ct_annot = ck} as e)
(List.map2 (List.map2
(fun c e -> { e with (fun c e -> { e with
e_ty = ty_bool; e_ty = ty_bool;
e_desc = Efby(Some c,e)}) e_desc = Epre(Some c,e)})
c_l e_l) c_l e_l)
| _ -> assert false | _ -> assert false
end end
| Eapp(app, e_list, r) -> | Eapp(app, e_list, r) ->
let context,e_list = translate_list env context e_list in let context,e_list = translate_list env context e_list in
context, Eapp(app, e_list, r) context, Eapp(app, e_list, r)
| Ewhen(e,c,ck) -> | Ewhen(e,c,({ e_desc = Evar(ck) } as e_ck)) ->
let context,e = translate env context e in let context,e = translate env context e in
begin begin
try try
@ -470,20 +485,20 @@ let rec translate env context ({e_desc = desc; e_ty = ty; e_ct_annot = ck} as e)
context,e_when.e_desc context,e_when.e_desc
with Not_found -> with Not_found ->
(* Boolean clock *) (* Boolean clock *)
context,Ewhen(e,c,ck) context,Ewhen(e,c,e_ck)
end end
| Emerge(ck_m,l) (* of name * (longname * exp) list *) | Emerge(({ e_desc = Evar(ck) } as e_ck),l) (* of name * (longname * exp) list *)
-> ->
begin begin
try try
let info = Env.find ck_m env in let info = Env.find ck env in
let context,e_map = List.fold_left let context,e_map = List.fold_left
(fun (context,e_map) (n,e) -> (fun (context,e_map) (n,e) ->
let context,e = translate env context e in let context,e = translate env context e in
context,QualEnv.add n e e_map) context,QualEnv.add n e e_map)
(context,QualEnv.empty) l in (context,QualEnv.empty) l in
let e_merge = let e_merge =
merge_tree ck ty e_map merge_tree (assert_ck ct) ty e_map
info.var_enum.ty_tree info.var_enum.ty_tree
info.clocked_var in info.clocked_var in
context,e_merge.e_desc context,e_merge.e_desc
@ -495,7 +510,7 @@ let rec translate env context ({e_desc = desc; e_ty = ty; e_ct_annot = ck} as e)
let context,e = translate env context e in let context,e = translate env context e in
context, (n,e)::acc_l) context, (n,e)::acc_l)
(context,[]) l in (context,[]) l in
context,Emerge(ck_m,l) context,Emerge(e_ck,l)
end end
| Estruct(l) -> | Estruct(l) ->
let context,acc = let context,acc =
@ -509,11 +524,15 @@ let rec translate env context ({e_desc = desc; e_ty = ty; e_ct_annot = ck} as e)
let context,pe_list = translate_list env context pe_list in let context,pe_list = translate_list env context pe_list in
let context,e_list = translate_list env context e_list in let context,e_list = translate_list env context e_list in
context,Eiterator(it,app,se,pe_list,e_list,r) context,Eiterator(it,app,se,pe_list,e_list,r)
| Ewhen(_,_,_)
| Emerge(_,_)
| Elast _ ->
failwith("Boolean: not supported expression (abstract tree should be normalized)")
in in
context,{ e with context,{ e with
e_desc = desc; e_desc = desc;
e_ty = translate_ty ty; e_ty = translate_ty ty;
e_ct_annot = ck} e_ct_annot = ct}
and translate_list env context e_list = and translate_list env context e_list =
let context,acc_e = let context,acc_e =
@ -524,27 +543,6 @@ and translate_list env context e_list =
(context,[]) e_list in (context,[]) e_list in
context,List.rev acc_e context,List.rev acc_e
let translate_eq env context ({eq_desc = desc} as eq) =
let desc,(d_list,eq_list) =
match desc with
| Eblock block ->
let block, _ = translate_block env [] [] block in
Eblock block,
context
| Eeq(pat,e) ->
let pat = translate_pat env pat in
let context,e = translate env context e in
Eeq(pat,e),
context
| _ -> failwith("Boolean pass: control structures should be removed")
in
d_list,{ eq with desc = desc }::eq_list
let translate_eqs env eq_list =
List.fold_left
(fun context eq ->
translate_eq env context eq) ([],[]) eq_list
(* Tranlate variable declaration list : outputs (* Tranlate variable declaration list : outputs
- new declaration list - new declaration list
- added local variables suffixed with "(_(1|0))*" for clock coherence - added local variables suffixed with "(_(1|0))*" for clock coherence
@ -567,7 +565,8 @@ let var_dec_list (acc_vd,acc_loc,acc_eq) var_from n =
| _ckvar::l, Con(ck',c,v) -> | _ckvar::l, Con(ck',c,v) ->
(* assert v = _ckvar *) (* assert v = _ckvar *)
let e = when_ck l ck' var in let e = when_ck l ck' var in
{ e_desc = Ewhen(e,c,v); let e_v = mk_exp (Evar v) ~ct_annot:(Ck(ck')) ty_bool in
{ e_desc = Ewhen(e,c,e_v);
e_base_ck = Cbase; e_base_ck = Cbase;
e_ct_annot = Ck(ck); e_ct_annot = Ck(ck);
e_ty = ty_bool; e_ty = ty_bool;
@ -636,9 +635,8 @@ let var_dec_list (acc_vd,acc_loc,acc_eq) var_from n =
v_loc = no_location } :: acc_loc in v_loc = no_location } :: acc_loc in
(* vi_... = vi when ... when (True|False)(v1) *) (* vi_... = vi when ... when (True|False)(v1) *)
let acc_eq = let acc_eq =
{ eq_lhs = Evarpat(id); (mk_equation (Eeq(Evarpat(id),(when_ck acc_var ck vi))))
eq_rhs = when_ck acc_var ck vi; ::acc_eq in
eq_loc = no_location }::acc_eq in
(* Build left son (ck on False(vi_...)) *) (* Build left son (ck on False(vi_...)) *)
let ck_0 = Con(ck,cfalse,id) in let ck_0 = Con(ck,cfalse,id) in
let acc_loc,acc_eq,t0 = let acc_loc,acc_eq,t0 =
@ -696,6 +694,7 @@ let buildenv_var_dec (acc_vd,acc_loc,acc_eq,env) ({v_type = ty} as v) =
with Not_found -> v::acc_vd, acc_loc, acc_eq, env with Not_found -> v::acc_vd, acc_loc, acc_eq, env
end end
end end
| Tinvalid -> failwith("Boolean: invalid type")
let buildenv_var_dec_list env vlist = let buildenv_var_dec_list env vlist =
List.fold_left buildenv_var_dec ([],[],[],env) vlist List.fold_left buildenv_var_dec ([],[],[],env) vlist
@ -706,7 +705,7 @@ let translate_var_dec env ({ v_clock = ck } as v) =
let translate_var_dec_list env vlist = let translate_var_dec_list env vlist =
List.map (translate_var_dec env) vlist List.map (translate_var_dec env) vlist
let translate_block env add_locals add_eqs ({ b_local = v; let rec translate_block env add_locals add_eqs ({ b_local = v;
b_equs = eq_list; } as b) = b_equs = eq_list; } as b) =
let v, v',v_eq,env = buildenv_var_dec_list env v in let v, v',v_eq,env = buildenv_var_dec_list env v in
let v = v@v'@add_locals in let v = v@v'@add_locals in
@ -718,12 +717,31 @@ let translate_block env add_locals add_eqs ({ b_local = v;
b_local = v@d_list; b_local = v@d_list;
b_equs = eq_list }, env b_equs = eq_list }, env
and translate_eq env context ({eq_desc = desc} as eq) =
let desc,(d_list,eq_list) =
match desc with
| Eblock block ->
let block, _ = translate_block env [] [] block in
Eblock block,
context
| Eeq(pat,e) ->
let pat = translate_pat env pat in
let context,e = translate env context e in
Eeq(pat,e),
context
| _ -> failwith("Boolean pass: control structures should be removed")
in
d_list,{ eq with eq_desc = desc }::eq_list
and translate_eqs env eq_list =
List.fold_left
(fun context eq ->
translate_eq env context eq) ([],[]) eq_list
let translate_contract env contract = let translate_contract env contract =
match contract with match contract with
| None -> None, env | None -> None, env
| Some { c_local = v; | Some { c_assume = e_a;
c_eq = eq_list;
c_assume = e_a;
c_enforce = e_g; c_enforce = e_g;
c_controllables = cl; c_controllables = cl;
c_block = b } -> c_block = b } ->
@ -738,7 +756,6 @@ let translate_contract env contract =
Some { c_block = { b with Some { c_block = { b with
b_local = d_list; b_local = d_list;
b_equs = eq_list }; b_equs = eq_list };
c_eq = eq_list;
c_assume = e_a; c_assume = e_a;
c_enforce = e_g; c_enforce = e_g;
c_controllables = cl }, c_controllables = cl },
@ -753,14 +770,22 @@ let node ({ n_input = inputs;
let contract, env = translate_contract env contract in let contract, env = translate_contract env contract in
let add_locals = in_loc@out_loc in let add_locals = in_loc@out_loc in
let add_eqs = in_eq@out_eq in let add_eqs = in_eq@out_eq in
let b = translate_block env add_locals add_eqs b in let b,_ = translate_block env add_locals add_eqs b in
{ n with { n with
n_input = List.rev inputs; n_input = List.rev inputs;
n_output = List.rev outputs; n_output = List.rev outputs;
n_contract = contract; n_contract = contract;
n_block = b } n_block = b }
let build type_dec = let program_desc p_desc =
match p_desc with
| Pnode(n) -> Pnode(node n)
| _ -> p_desc
let build p_desc =
match p_desc with
| Ptype(type_dec) ->
begin
let tenv = let tenv =
match type_dec.t_desc with match type_dec.t_desc with
| Type_enum clist -> | Type_enum clist ->
@ -770,7 +795,9 @@ let build type_dec =
ty_tree = t}) ty_tree = t})
| tdesc -> Type(tdesc) in | tdesc -> Type(tdesc) in
enum_types := QualEnv.add type_dec.t_name tenv !enum_types enum_types := QualEnv.add type_dec.t_name tenv !enum_types
end
| _ -> ()
let program ({ p_types = t_list; p_nodes = n_list } as p) = let program ({ p_desc = d_list } as p) =
List.iter build t_list; List.iter build d_list;
{ p with p_nodes = List.map node n_list } { p with p_desc = List.map program_desc d_list }

95
compiler/minils/sigali/sigalimain.ml
View file

@ -2,8 +2,8 @@
(* *) (* *)
(* Heptagon/BZR *) (* Heptagon/BZR *)
(* *) (* *)
(* Author : Gwenaël Delaval *) (* Author : Gwenaël Delaval *)
(* Organization : INRIA Rennes, VerTeCs *) (* Organization : UJF, LIG *)
(* *) (* *)
(****************************************************) (****************************************************)
@ -62,26 +62,42 @@ let rec translate_ck pref e = function
| "false" -> Snot(Svar(pref ^ (name var))) | "false" -> Snot(Svar(pref ^ (name var)))
| _ -> assert false) | _ -> assert false)
(* [translate e = c] *)
let rec translate prefix ({ Minils.e_desc = desc; Minils.e_ty = ty } as e) = let rec translate_ext prefix ({ Minils.w_desc = desc; Minils.w_ty = ty } as e) =
match desc with match desc with
| Minils.Econst(v) -> | Minils.Wconst(v) ->
begin match (actual_ty ty) with begin match (actual_ty ty) with
| Tbool -> Sconst(translate_static_exp v) | Tbool -> Sconst(translate_static_exp v)
| Tint -> a_const (Sconst(translate_static_exp v)) | Tint -> a_const (Sconst(translate_static_exp v))
| Tother -> failwith("Sigali: untranslatable type") | Tother -> failwith("Sigali: untranslatable type")
end end
| Minils.Evar(n) -> Svar(prefix ^ (name n)) | Minils.Wvar(n) -> Svar(prefix ^ (name n))
| Minils.Wwhen(e, c, var) when ((actual_ty e.Minils.w_ty) = Tbool) ->
let e = translate_ext prefix e in
Swhen(e,
match (shortname c) with
"true" -> Svar(prefix ^ (name var))
| "false" -> Snot(Svar(prefix ^ (name var)))
| _ -> assert false)
| Minils.Wwhen(e, _c, _var) ->
translate_ext prefix e
| Minils.Wfield(_) ->
failwith("Sigali: structures not implemented")
(* [translate e = c] *)
let rec translate prefix ({ Minils.e_desc = desc; Minils.e_ty = ty } as e) =
match desc with
| Minils.Eextvalue(ext) -> translate_ext prefix ext
| Minils.Eapp (* pervasives binary or unary stateless operations *) | Minils.Eapp (* pervasives binary or unary stateless operations *)
({ Minils.a_op = Minils.Efun({qual=Pervasives;name=n})}, ({ Minils.a_op = Minils.Efun({qual=Pervasives;name=n})},
e_list, _) -> e_list, _) ->
begin begin
match n, e_list with match n, e_list with
| "not", [e] -> Snot(translate prefix e) | "not", [e] -> Snot(translate_ext prefix e)
| "or", [e1;e2] -> Sor((translate prefix e1),(translate prefix e2)) | "or", [e1;e2] -> Sor((translate_ext prefix e1),
| "&", [e1;e2] -> Sand((translate prefix e1),(translate prefix e2)) (translate_ext prefix e2))
(* a_inf and a_sup : +1 to translate ideals to boolean | "&", [e1;e2] -> Sand((translate_ext prefix e1),
polynomials *) (translate_ext prefix e2))
| ("<="|"<"|">="|">"), [e1;e2] -> | ("<="|"<"|">="|">"), [e1;e2] ->
let op,modv = let op,modv =
begin match n with begin match n with
@ -90,35 +106,31 @@ let rec translate prefix ({ Minils.e_desc = desc; Minils.e_ty = ty } as e) =
| ">=" -> a_sup,0 | ">=" -> a_sup,0
| _ -> a_sup,1 | _ -> a_sup,1
end in end in
let e1 = translate prefix e1 in let e1 = translate_ext prefix e1 in
begin match e2.Minils.e_desc with let sig_e =
| Minils.Econst({se_desc = Sint(v)}) -> begin match e2.Minils.w_desc with
let e = op e1 (Sconst(Cint(v+modv))) in | Minils.Wconst({se_desc = Sint(v)}) ->
Splus(e,Sconst(Ctrue)) op e1 (Sconst(Cint(v+modv)))
| _ -> | _ ->
let e2 = translate prefix e2 in let e2 = translate_ext prefix e2 in
let e = op (Sminus(e1,e2)) (Sconst(Cint(modv))) in op (Sminus(e1,e2)) (Sconst(Cint(modv)))
Splus(e,Sconst(Ctrue)) end in
end (* a_inf and a_sup : +1 to translate ideals to boolean
| "+", [e1;e2] -> Splus((translate prefix e1),(translate prefix e2)) polynomials *)
| "-", [e1;e2] -> Sminus((translate prefix e1),(translate prefix e2)) Splus(sig_e,Sconst(Ctrue))
| "*", [e1;e2] -> Sprod((translate prefix e1),(translate prefix e2)) | "+", [e1;e2] -> Splus((translate_ext prefix e1),
(translate_ext prefix e2))
| "-", [e1;e2] -> Sminus((translate_ext prefix e1),
(translate_ext prefix e2))
| "*", [e1;e2] -> Sprod((translate_ext prefix e1),
(translate_ext prefix e2))
| ("=" | ("="
| "<>"),_ -> failwith("Sigali: '=' or '<>' not yet implemented") | "<>"),_ -> failwith("Sigali: '=' or '<>' not yet implemented")
| _ -> assert false | _ -> assert false
end end
| Minils.Ewhen(e, c, var) when ((actual_ty e.Minils.e_ty) = Tbool) ->
let e = translate prefix e in
Swhen(e,
match (shortname c) with
"true" -> Svar(prefix ^ (name var))
| "false" -> Snot(Svar(prefix ^ (name var)))
| _ -> assert false)
| Minils.Ewhen(e, _c, _var) ->
translate prefix e
| Minils.Emerge(ck,[(c1,e1);(_c2,e2)]) -> | Minils.Emerge(ck,[(c1,e1);(_c2,e2)]) ->
let e1 = translate prefix e1 in let e1 = translate_ext prefix e1 in
let e2 = translate prefix e2 in let e2 = translate_ext prefix e2 in
let e1,e2 = let e1,e2 =
begin begin
match (shortname c1) with match (shortname c1) with
@ -170,7 +182,7 @@ let rec translate_eq env f
(Slist[Sequal(Svar(sn),Sconst(c))]))::acc_eqs, (Slist[Sequal(Svar(sn),Sconst(c))]))::acc_eqs,
c::acc_init c::acc_init
in in
let e_next = translate prefix e in let e_next = translate_ext prefix e in
let e_next = translate_ck prefix e_next ck in let e_next = translate_ck prefix e_next ck in
acc_dep, acc_dep,
sn::acc_states, sn::acc_states,
@ -254,7 +266,7 @@ let rec translate_eq env f
prefixed (s_prefix ^ s)) prefixed (s_prefix ^ s))
g_p.proc_states in g_p.proc_states in
let e_states = List.map (fun hq -> Svar(hq)) new_states_list in let e_states = List.map (fun hq -> Svar(hq)) new_states_list in
let e_list = List.map (translate prefix) e_list in let e_list = List.map (translate_ext prefix) e_list in
let e_outputs,acc_inputs = let e_outputs,acc_inputs =
match inlined with match inlined with
| true -> [],acc_inputs | true -> [],acc_inputs
@ -414,7 +426,7 @@ let rec translate_eq env f
prefixed (s_prefix ^ s)) prefixed (s_prefix ^ s))
g_p.proc_states in g_p.proc_states in
let e_states = List.map (fun hq -> Svar(hq)) new_states_list in let e_states = List.map (fun hq -> Svar(hq)) new_states_list in
let e_list = List.map (translate prefix) e_list in let e_list = List.map (translate_ext prefix) e_list in
let e_outputs,acc_inputs = let e_outputs,acc_inputs =
match inlined with match inlined with
| true -> [],acc_inputs | true -> [],acc_inputs
@ -651,11 +663,14 @@ let translate_node env
let program p = let program p =
let _env,acc_proc = let _env,acc_proc =
List.fold_left List.fold_left
(fun (env,acc) node -> (fun (env,acc) p_desc ->
match p_desc with
| Minils.Pnode(node) ->
let env,(proc,contract) = translate_node env node in let env,(proc,contract) = translate_node env node in
env,contract::proc::acc) env,contract::proc::acc
| _ -> env,acc)
(NamesEnv.empty,[]) (NamesEnv.empty,[])
p.Minils.p_nodes in p.Minils.p_desc in
let procs = List.rev acc_proc in let procs = List.rev acc_proc in
let filename = filename_of_name (modul_to_string p.Minils.p_modname) in let filename = filename_of_name (modul_to_string p.Minils.p_modname) in
let dirname = build_path (filename ^ "_z3z") in let dirname = build_path (filename ^ "_z3z") in