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

Fixed warnings.

Browse source
This commit is contained in:
Nicolas Berthier 2014-03-18 11:01:56 +01:00
parent c3c7a331b6
commit 99ab12aa13
44 changed files with 254 additions and 254 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
compiler/global/clocks.ml
View file

@ -98,7 +98,7 @@ and unify_ck ck1 ck2 =
match (ck1, ck2) with
| Cbase, Cbase -> ()
| Cvar { contents = Cindex n1 }, Cvar { contents = Cindex n2 } when n1 = n2 -> ()
| Con (ck1, c1, n1), Con (ck2, c2, n2) when (c1 = c2) & (n1 = n2) ->
| Con (ck1, c1, n1), Con (ck2, c2, n2) when (c1 = c2) && (n1 = n2) ->
unify_ck ck1 ck2
| Cvar ({ contents = Cindex n } as v), ck
| ck, Cvar ({ contents = Cindex n } as v) ->

12
compiler/global/global_mapfold.ml
View file

@ -38,7 +38,7 @@ type 'a global_it_funs = {
static_exp_desc : 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
ty : 'a global_it_funs -> 'a -> ty -> ty * 'a;
ct : 'a global_it_funs -> 'a -> ct -> ct * 'a;
ck : 'a global_it_funs -> 'a -> ck -> ck * 'a;
ck : 'a global_it_funs -> 'a -> Clocks.ck -> Clocks.ck * 'a;
link : 'a global_it_funs -> 'a -> link -> link * 'a;
var_ident : 'a global_it_funs -> 'a -> var_ident -> var_ident * 'a;
param : 'a global_it_funs -> 'a -> param -> param * 'a;
@ -97,14 +97,14 @@ and ct funs acc c = match c with
and ck_it funs acc c = try funs.ck funs acc c with Fallback -> ck funs acc c
and ck funs acc c = match c with
| Cbase -> c, acc
| Cvar(link_ref) ->
| Clocks.Cbase -> c, acc
| Clocks.Cvar(link_ref) ->
let l, acc = link_it funs acc link_ref.contents in
Cvar {contents = l}, acc
| Con(ck, constructor_name, v) ->
Clocks.Cvar {contents = l}, acc
| Clocks.Con(ck, constructor_name, v) ->
let ck, acc = ck_it funs acc ck in
let v, acc = var_ident_it funs acc v in
Con (ck, constructor_name, v), acc
Clocks.Con (ck, constructor_name, v), acc
and link_it funs acc c =
try funs.link funs acc c with Fallback -> link funs acc c

4
compiler/global/global_printer.ml
View file

@ -70,8 +70,8 @@ let print_shortname ff {name = n} = print_name ff n
let print_ident = Idents.print_ident
let rec print_ck ff = function
| Cbase -> fprintf ff "."
| Con (ck, c, n) -> fprintf ff "%a on %a(%a)" print_ck ck print_qualname c print_ident n
| Clocks.Cbase -> fprintf ff "."
| Clocks.Con (ck, c, n) -> fprintf ff "%a on %a(%a)" print_ck ck print_qualname c print_ident n
| Cvar { contents = Cindex i } -> fprintf ff "'a%i" i
| Cvar { contents = Clink ck } ->
if !Compiler_options.full_type_info then

2
compiler/global/idents.mli
View file

@ -27,8 +27,6 @@
(* *)
(***********************************************************************)
open Names
(** This modules manages unique identifiers,
/!\ To be effective, [enter_node] has to be called when entering a node
[gen_var] generates a variable identifier

19
compiler/heptagon/analysis/hept_clocking.ml
View file

@ -48,7 +48,10 @@ open Location
open Format
(** Error Kind *)
type error_kind = | Etypeclash of ct * ct | Eclockclash of ck * ck | Edefclock
type error_kind =
| Etypeclash of ct * ct
| Eclockclash of Clocks.ck * Clocks.ck
| Edefclock
let error_message loc = function
| Etypeclash (actual_ct, expected_ct) ->
@ -111,10 +114,10 @@ let rec typing h pat e =
| Ewhen (e,c,n) ->
let ck_n = ck_of_name h n in
let _base = expect h pat (skeleton ck_n e.e_ty) e in
skeleton (Con (ck_n, c, n)) e.e_ty, Con (ck_n, c, n)
skeleton (Clocks.Con (ck_n, c, n)) e.e_ty, Clocks.Con (ck_n, c, n)
| Emerge (x, c_e_list) ->
let ck = ck_of_name h x in
List.iter (fun (c,e) -> expect h pat (Ck(Con (ck,c,x))) e) c_e_list;
List.iter (fun (c,e) -> expect h pat (Ck(Clocks.Con (ck,c,x))) e) c_e_list;
Ck ck, ck
| Estruct l ->
let ck = fresh_clock () in
@ -264,9 +267,9 @@ let typing_contract h contract =
c_controllables = c_list } ->
let h' = typing_block h b in
(* assumption *)
expect h' (Etuplepat []) (Ck Cbase) e_a;
expect h' (Etuplepat []) (Ck Clocks.Cbase) e_a;
(* property *)
expect h' (Etuplepat []) (Ck Cbase) e_g;
expect h' (Etuplepat []) (Ck Clocks.Cbase) e_g;
append_env h c_list
@ -276,9 +279,9 @@ let typing_local_contract h contract =
| Some { c_assume_loc = e_a_loc;
c_enforce_loc = e_g_loc } ->
(* assumption *)
expect h (Etuplepat []) (Ck Cbase) e_a_loc;
expect h (Etuplepat []) (Ck Clocks.Cbase) e_a_loc;
(* property *)
expect h (Etuplepat []) (Ck Cbase) e_g_loc
expect h (Etuplepat []) (Ck Clocks.Cbase) e_g_loc
(* check signature causality and update it in the global env *)
let update_signature h node =
@ -299,7 +302,7 @@ let typing_node node =
let h = typing_block h node.n_block in
typing_local_contract h node.n_contract;
(* synchronize input and output on base : find the free vars and set them to base *)
Env.iter (fun _ ck -> unify_ck Cbase (root_ck_of ck)) h0;
Env.iter (fun _ ck -> unify_ck Clocks.Cbase (root_ck_of ck)) h0;
(*update clock info in variables descriptions *)
let set_clock vd = { vd with v_clock = ck_repr (Env.find vd.v_ident h) } in
let node = { node with n_input = List.map set_clock node.n_input;

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

@ -188,7 +188,6 @@ let rec less left_ty right_ty =
module Printer = struct
open Format
open Pp_tools
open Global_printer
let rec print_init ff i = match !i with
| Izero -> fprintf ff "initialized"
@ -212,8 +211,6 @@ module Printer = struct
end
module Error = struct
open Location
type error = | Eclash of root * typ * typ
exception Error of location * error

16
compiler/heptagon/analysis/stateful.ml
View file

@ -63,36 +63,36 @@ let edesc funs stateful ed =
| Eapp({ a_op = (Enode f | Efun f) } as app, e_list, r) ->
let ty_desc = find_value f in
let op = if ty_desc.node_stateful then Enode f else Efun f in
Eapp({ app with a_op = op }, e_list, r), ty_desc.node_stateful or stateful
Eapp({ app with a_op = op }, e_list, r), ty_desc.node_stateful || stateful
| Eiterator(it, ({ a_op = (Enode f | Efun f) } as app), n, pe_list, e_list, r) ->
let ty_desc = find_value f in
let op = if ty_desc.node_stateful then Enode f else Efun f in
Eiterator(it, { app with a_op = op }, n, pe_list, e_list, r),
ty_desc.node_stateful or stateful
ty_desc.node_stateful || stateful
| _ -> ed, stateful
(* Automatons have an hidden state whatever *)
let eqdesc funs stateful eqd =
let eqd, stateful = Hept_mapfold.eqdesc funs stateful eqd in
let is_automaton = match eqd with | Eautomaton _ -> true | _ -> false in
eqd, stateful or is_automaton
eqd, stateful || is_automaton
(* update eq_stateful field *)
let eq funs acc eq =
let eq, stateful = Hept_mapfold.eq funs false eq in
{ eq with eq_stateful = stateful }, stateful or acc
{ eq with eq_stateful = stateful }, stateful || acc
(* update b_stateful field *)
let block funs acc b =
let b, stateful = Hept_mapfold.block funs false b in
{ b with b_stateful = stateful }, acc or stateful
{ b with b_stateful = stateful }, acc || stateful
(* Strong preemption should be decided with stateles expressions *)
let escape_unless funs acc esc =
let esc, stateful = Hept_mapfold.escape funs false esc in
if stateful then
message esc.e_cond.e_loc Eexp_should_be_stateless;
esc, acc or stateful
esc, acc || stateful
(* Present conditions should be stateless *)
let present_handler funs acc ph =
@ -107,8 +107,8 @@ let present_handler funs acc ph =
let node_dec funs _ n =
Idents.enter_node n.n_name;
let n, stateful = Hept_mapfold.node_dec funs false n in
if stateful & (not n.n_stateful) then message n.n_loc Eshould_be_a_node;
if not stateful & n.n_stateful (* update the global env if stateful is not necessary *)
if stateful && (not n.n_stateful) then message n.n_loc Eshould_be_a_node;
if not stateful && n.n_stateful (* update the global env if stateful is not necessary *)
then Modules.replace_value n.n_name
{ (Modules.find_value n.n_name) with Signature.node_stateful = false };
{ n with n_stateful = stateful }, false (* set stateful only if needed *)

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

@ -1252,11 +1252,11 @@ let node ({ n_name = f; n_input = i_list; n_output = o_list;
| TypingError(error) -> message loc error
let typing_const_dec cd =
let ty = check_type QualEnv.empty cd.c_type in
let se = expect_static_exp QualEnv.empty ty cd.c_value in
let ty = check_type QualEnv.empty cd.Heptagon.c_type in
let se = expect_static_exp QualEnv.empty ty cd.Heptagon.c_value in
let const_def = { Signature.c_type = ty; Signature.c_value = se } in
Modules.replace_const cd.c_name const_def;
{ cd with c_value = se; c_type = ty }
{ cd with Heptagon.c_value = se; Heptagon.c_type = ty }
let typing_typedec td =
let tydesc = match td.t_desc with

12
compiler/heptagon/analysis/unsafe.ml
View file

@ -57,17 +57,17 @@ let exp funs unsafe e =
let e, unsafe = Hept_mapfold.exp funs unsafe e in
match e.e_desc with
| Eapp({ a_op = op } as app, e_l, r) ->
let u = (unsafe_op op) or app.a_unsafe in
if u & (not unsafe)
let u = (unsafe_op op) || app.a_unsafe in
if u && (not unsafe)
then message e.e_loc Eshould_be_unsafe
else {e with e_desc = Eapp({ app with a_unsafe = u }, e_l, r)}, (unsafe or u)
else {e with e_desc = Eapp({ app with a_unsafe = u }, e_l, r)}, (unsafe || u)
| Eiterator(it, ({ a_op = op } as app), n, pe_list, e_list, r) ->
let u = (unsafe_op op) or app.a_unsafe in
if u & (not unsafe)
let u = (unsafe_op op) || app.a_unsafe in
if u && (not unsafe)
then message e.e_loc Eshould_be_unsafe
else
{e with e_desc = Eiterator(it, { app with a_unsafe = u }, n, pe_list, e_list, r)}
, (unsafe or u)
, (unsafe || u)
| _ -> e, unsafe
(* unsafe nodes are rejected if they are not declared unsafe *)

2
compiler/heptagon/hept_printer.ml
View file

@ -185,7 +185,7 @@ and print_app ff (app, args) =
match app.a_op with
| Etuple -> print_exp_tuple ff args
(* we need a special case for '*' and '*.' as printing (_*_) is incorrect *)
| Efun { name = n } when (n = "*" or n = "*.") ->
| Efun { name = n } when (n = "*" || n = "*.") ->
let a1, a2 = assert_2 args in
fprintf ff "@[%a@, %s@, %a@]" print_exp a1 n print_exp a2
| Efun ({ qual = Pervasives; name = n } as f) when (is_infix n) ->

6
compiler/heptagon/hept_utils.ml
View file

@ -38,7 +38,7 @@ open Heptagon
(* Helper functions to create AST. *)
(* TODO : After switch, all mk_exp should take care of level_ck *)
let mk_exp desc ?(level_ck = Cbase) ?(ct_annot = None) ?(loc = no_location) ty ~linearity =
let mk_exp desc ?(level_ck = Clocks.Cbase) ?(ct_annot = None) ?(loc = no_location) ty ~linearity =
{ e_desc = desc; e_ty = ty; e_ct_annot = ct_annot; e_linearity = linearity;
e_level_ck = level_ck; e_loc = loc; }
@ -109,7 +109,7 @@ let mk_node
let vars_pat pat =
let rec _vars_pat locals acc = function
| Evarpat x ->
if (IdentSet.mem x locals) or (IdentSet.mem x acc)
if (IdentSet.mem x locals) || (IdentSet.mem x acc)
then acc
else IdentSet.add x acc
| Etuplepat pat_list -> List.fold_left (_vars_pat locals) acc pat_list
@ -119,7 +119,7 @@ let vars_pat pat =
a list of [var_dec]. *)
let rec vd_mem n = function
| [] -> false
| vd::l -> vd.v_ident = n or (vd_mem n l)
| vd::l -> vd.v_ident = n || (vd_mem n l)
let args_of_var_decs =
(* before the clocking the clock is wrong in the signature *)

4
compiler/heptagon/heptagon.ml
View file

@ -48,7 +48,7 @@ type exp = {
e_desc : desc;
e_ty : ty;
mutable e_ct_annot : ct option; (* exists when a source annotation exists *)
e_level_ck : ck; (* set by the switch pass, represents the activation base of the expression *)
e_level_ck : Clocks.ck; (* set by the switch pass, represents the activation base of the expression *)
mutable e_linearity : linearity;
e_loc : location }
@ -141,7 +141,7 @@ and var_dec = {
v_ident : var_ident;
v_type : ty;
v_linearity : linearity;
v_clock : ck;
v_clock : Clocks.ck;
v_last : last;
v_loc : location }

27
compiler/heptagon/parsing/hept_scoping.ml
View file

@ -66,13 +66,13 @@ module Error =
struct
type error =
| Evar_unbound of name
| Equal_notfound of name*qualname
| Equal_notfound of name*Names.qualname
| Equal_unbound of name*name
| Enot_last of name
| Evariable_already_defined of name
| Econst_variable_already_defined of name
| Estatic_exp_expected
| Eredefinition of qualname
| Eredefinition of Names.qualname
| Elinear_type_no_memalloc
let message loc kind =
@ -123,7 +123,7 @@ open Error
let safe_add loc add n x =
try ((add n x) : unit)
with Modules.Already_defined -> message loc (Eredefinition n)
with Modules.Already_defined -> Error.message loc (Eredefinition n)
(** {3 Qualify when ToQ and check when Q according to the global env } *)
@ -155,30 +155,29 @@ let qualify_const local_const c = match c with
module Rename =
struct
open Error
include
(Map.Make (struct type t = string let compare = String.compare end))
(** Rename a var *)
let var loc env n =
try fst (find n env)
with Not_found -> message loc (Evar_unbound n)
with Not_found -> Error.message loc (Evar_unbound n)
(** Rename a last *)
let last loc env n =
try
let id, last = find n env in
if not last then message loc (Enot_last n) else id
with Not_found -> message loc (Evar_unbound n)
if not last then Error.message loc (Enot_last n) else id
with Not_found -> Error.message loc (Evar_unbound n)
(** Adds a name to the list of used names and idents. *)
let add_used_name env n =
add n (ident_of_name n, false) env
(** Add a var *)
let add_var loc env n =
if mem n env then message loc (Evariable_already_defined n)
if mem n env then Error.message loc (Evariable_already_defined n)
else
add n (ident_of_name n, false) env
(** Add a last *)
let add_last loc env n =
if mem n env then message loc (Evariable_already_defined n)
if mem n env then Error.message loc (Evariable_already_defined n)
else
add n (ident_of_name n, true) env
(** Add a var dec *)
@ -233,7 +232,7 @@ let rec translate_static_exp se =
let se_d = translate_static_exp_desc se.se_loc se.se_desc in
Types.mk_static_exp Types.Tinvalid ~loc:se.se_loc se_d
with
| ScopingError err -> message se.se_loc err
| ScopingError err -> Error.message se.se_loc err
and translate_static_exp_desc _loc ed =
let t = translate_static_exp in
@ -256,7 +255,7 @@ and translate_static_exp_desc _loc ed =
let expect_static_exp e = match e.e_desc with
| Econst se -> translate_static_exp se
| _ -> message e.e_loc Estatic_exp_expected
| _ -> Error.message e.e_loc Estatic_exp_expected
let rec translate_type loc ty =
try
@ -270,7 +269,7 @@ let rec translate_type loc ty =
| Tinvalid -> Types.Tinvalid
)
with
| ScopingError err -> message loc err
| ScopingError err -> Error.message loc err
let rec translate_some_clock loc env ck = match ck with
| None -> Clocks.fresh_clock()
@ -293,7 +292,7 @@ let rec translate_exp env e =
Heptagon.e_level_ck = Clocks.Cbase;
Heptagon.e_ct_annot = Misc.optional (translate_ct e.e_loc env) e.e_ct_annot;
Heptagon.e_loc = e.e_loc }
with ScopingError(error) -> message e.e_loc error
with ScopingError(error) -> Error.message e.e_loc error
and translate_desc loc env = function
| Econst c -> Heptagon.Econst (translate_static_exp c)
@ -424,7 +423,7 @@ and translate_switch_handler loc env sh =
{ Heptagon.w_name = qualify_constrs sh.w_name;
Heptagon.w_block = fst (translate_block env sh.w_block) }
with
| ScopingError err -> message loc err
| ScopingError err -> Error.message loc err
and translate_var_dec env vd =
(* env is initialized with the declared vars before their translation *)

5
compiler/heptagon/parsing/hept_static_scoping.ml
View file

@ -56,7 +56,7 @@ let qualify_pervasive q =
begin
try
match (Modules.qualify_value name) with
| { Names.qual = Names.Pervasives } as qn ->
| { Names.qual = Names.Pervasives } as qn ->
Q qn
| _ -> raise Not_static
with Not_found -> raise Not_static
@ -80,7 +80,7 @@ let exp funs local_const e =
let sed =
match e.e_desc with
| Evar n ->
(try Svar (Q (qualify_const local_const (ToQ n)))
(try Svar (Q (Hept_scoping.qualify_const local_const (ToQ n)))
with Error.ScopingError _ -> raise Not_static)
| Eapp({ a_op = Earray_fill; a_params = n_list }, [e]) ->
Sarray_power (assert_se e, List.map assert_se n_list)
@ -124,4 +124,3 @@ let interface i =
List.iter open_module i.i_opened;
let i, _ = Hept_parsetree_mapfold.interface_it funs Names.NamesSet.empty i in
i

2
compiler/heptagon/transformations/automata.ml
View file

@ -90,7 +90,7 @@ let intro_type type_name state_env =
Moore automatons doesn't have strong transitions,
Mealy automatons may have some. *)
let no_strong_transition state_handlers =
let handler no_strong { s_unless = l } = no_strong & (l = []) in
let handler no_strong { s_unless = l } = no_strong && (l = []) in
List.fold_left handler true state_handlers

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

@ -324,15 +324,15 @@ let rec on_list ck bl vtree =
| [], _ -> ck
| b::bl', VNode(v,t0,t1) ->
let (c,t) = if b then (ctrue,t1) else (cfalse,t0) in
on_list (Con(ck,c,v)) bl' t
on_list (Clocks.Con(ck,c,v)) bl' t
| _::_, Vempty -> failwith("on_list: non-coherent boolean list and tree")
let rec translate_ck env ck =
match ck with
| Cbase -> Cbase
| Cvar {contents = Clink(ck)} -> translate_ck env ck
| Cvar {contents = Cindex(_)} -> ck
| Con(ck,c,n) ->
| Clocks.Cbase -> Clocks.Cbase
| Clocks.Cvar {contents = Clink(ck)} -> translate_ck env ck
| Clocks.Cvar {contents = Cindex(_)} -> ck
| Clocks.Con(ck,c,n) ->
let ck = translate_ck env ck in
begin
try
@ -341,7 +341,7 @@ let rec translate_ck env ck =
on_list ck bl info.clocked_var
with Not_found ->
(* Boolean clock *)
Con(ck,c,n)
Clocks.Con(ck,c,n)
end
let rec translate_ct env ct =
@ -418,21 +418,21 @@ let rec when_list e bl vtree =
let ck = assert_ck e.e_ct_annot in
(* let e_v = mk_exp (Evar v) ~ct_annot:(Some(Ck(ck))) ty_bool in *)
let e_when = { e with
e_ct_annot = Some (Ck(Con(ck,c,v)));
e_ct_annot = Some (Ck(Clocks.Con(ck,c,v)));
e_desc = Ewhen(e,c,v) } in
when_list e_when bl' t
| _::_, Vempty -> failwith("when_list: non-coherent boolean list and tree")
let rec when_ck desc li ty ck =
match ck with
| Cbase | Cvar _ ->
| Clocks.Cbase | Clocks.Cvar _ ->
{ e_desc = desc;
e_level_ck = ck;
e_ct_annot = Some(Ck(ck));
e_linearity = li;
e_ty = ty;
e_loc = no_location }
| Con(ck',c,v) ->
| Clocks.Con(ck',c,v) ->
let e = when_ck desc li ty ck' in
(* let e_v = mk_exp (Evar v) ~ct_annot:(Some(Ck(ck'))) ty_bool in *)
{ e_desc = Ewhen(e,c,v);
@ -480,7 +480,7 @@ let rec base_value ck li ty =
let e_list = aux [] n in
{ e_desc = mk_tuple e_list;
e_ty = Tprod(List.map (fun _ -> ty_bool) e_list);
e_level_ck = Cbase;
e_level_ck = Clocks.Cbase;
e_ct_annot = Some(Ck(ck));
e_linearity = li;
e_loc = no_location }
@ -492,7 +492,7 @@ let rec base_value ck li ty =
let e_list = List.map (base_value ck li) ty_list in
{ e_desc = mk_tuple e_list;
e_ty = Tprod(List.map (fun e -> e.e_ty) e_list);
e_level_ck = Cbase;
e_level_ck = Clocks.Cbase;
e_ct_annot = Some(Ck(ck));
e_linearity = li;
e_loc = no_location;
@ -501,7 +501,7 @@ let rec base_value ck li ty =
let e = base_value ck li ty in
{ e_desc = Eapp((mk_app ~params:[se] Earray_fill), [e], None);
e_ty = Tarray(e.e_ty,se);
e_level_ck = Cbase;
e_level_ck = Clocks.Cbase;
e_ct_annot = Some(Ck(ck));
e_linearity = li;
e_loc = no_location;
@ -515,13 +515,13 @@ let rec merge_tree ck ty li e_map btree vtree =
let e = QualEnv.find name e_map in
{ e with e_ct_annot = Some(Ck(ck)) }
| Tree(t1,t2), VNode(v,vt1,vt2) ->
let e1 = merge_tree (Con(ck,cfalse,v)) ty li e_map t1 vt1
and e2 = merge_tree (Con(ck,ctrue,v)) ty li e_map t2 vt2
let e1 = merge_tree (Clocks.Con(ck,cfalse,v)) ty li e_map t1 vt1
and e2 = merge_tree (Clocks.Con(ck,ctrue,v)) ty li e_map t2 vt2
in
(* let e_v = mk_exp (Evar v) ~ct_annot:(Some(Ck(ck))) ty_bool in *)
{ e_desc = Emerge(v,[(cfalse,e1);(ctrue,e2)]);
e_ty = ty;
e_level_ck = Cbase;
e_level_ck = Clocks.Cbase;
e_ct_annot = Some(Ck(ck));
e_linearity = li;
e_loc = no_location }
@ -672,7 +672,7 @@ let var_dec_list (acc_vd,acc_loc,acc_eq) var_from n =
e_ty = ty_bool;
e_linearity = var_from.v_linearity;
e_loc = no_location }
| _ckvar::l, Con(ck',c,v) ->
| _ckvar::l, Clocks.Con(ck',c,v) ->
(* assert v = _ckvar *)
let e = when_ck l ck' var in
(* let e_v = mk_exp (Evar v) ~ct_annot:(Some(Ck(ck'))) ty_bool in *)
@ -718,7 +718,7 @@ let var_dec_list (acc_vd,acc_loc,acc_eq) var_from n =
| v1::v_list, [] ->
(* Root : no new id, only rec calls for sons *)
(* Build left son (ck on False(vi_...)) *)
let ck_0 = Con(ck,cfalse,v1) in
let ck_0 = Clocks.Con(ck,cfalse,v1) in
let acc_loc,acc_eq,t0 =
clocked_tree
(acc_loc,acc_eq)
@ -726,7 +726,7 @@ let var_dec_list (acc_vd,acc_loc,acc_eq) var_from n =
("_0")
v_list ck_0 in
(* Build right son (ck on True(vi_...))*)
let ck_1 = Con(ck,ctrue,v1) in
let ck_1 = Clocks.Con(ck,ctrue,v1) in
let acc_loc,acc_eq,t1 =
clocked_tree
(acc_loc,acc_eq)
@ -750,7 +750,7 @@ let var_dec_list (acc_vd,acc_loc,acc_eq) var_from n =
(mk_equation (Eeq(Evarpat(id),(when_ck acc_var ck vi))))
::acc_eq in
(* Build left son (ck on False(vi_...)) *)
let ck_0 = Con(ck,cfalse,id) in
let ck_0 = Clocks.Con(ck,cfalse,id) in
let acc_loc,acc_eq,t0 =
clocked_tree
(acc_loc,acc_eq)
@ -758,7 +758,7 @@ let var_dec_list (acc_vd,acc_loc,acc_eq) var_from n =
(suffix ^ "_0")
v_list ck_0 in
(* Build right son (ck on True(vi_...))*)
let ck_1 = Con(ck,ctrue,id) in
let ck_1 = Clocks.Con(ck,ctrue,id) in
let acc_loc,acc_eq,t1 =
clocked_tree
(acc_loc,acc_eq)
@ -796,7 +796,7 @@ let buildenv_var_dec (acc_vd,acc_loc,acc_eq,env) ({v_type = ty} as v) =
v info.ty_nb_var in
let env =
Env.add
v.v_ident
v.v_ident
{ var_enum = info;
var_list = vl;
clocked_var = t }

6
compiler/heptagon/transformations/contracts.ml
View file

@ -261,7 +261,7 @@ let block funs (env, newvars, newequs, cont_vars, contracts) blk =
let defnames = List.fold_left
(fun env v -> Env.add v.v_ident v env)
blk.b_defnames cont_vars' in
({ blk with
({ blk with
b_local = newvars' @ blk.b_local;
b_equs = newequs' @ blk.b_equs;
b_defnames = defnames;
@ -280,7 +280,7 @@ let var_exp v = mk_exp (Evar v) tbool ~linearity:Ltop
let true_exp = mk_exp (Econst (mk_static_bool true)) tbool ~linearity:Ltop
let node_dec funs (env, newvars, newequs, cont_vars, contracts) nd =
let nd, (env, newvars, newequs, cont_vars, contracts) =
let nd, (env, newvars, newequs, _cont_vars, contracts) =
Hept_mapfold.node_dec funs (env, newvars, newequs, cont_vars, contracts) nd in
(* Build assume and guarantee parts from contract list (list of
@ -330,7 +330,7 @@ let node_dec funs (env, newvars, newequs, cont_vars, contracts) nd =
let program p =
let funs =
{ defaults with exp = exp; block = block; node_dec = node_dec; eq = eq; } in
let (p, (_, newvars, newequs, cont_vars, contracts)) =
let (p, (_, newvars, newequs, _cont_vars, contracts)) =
Hept_mapfold.program funs (QualEnv.empty, [], [], [], []) p in
assert (newvars = []);
assert (newequs = []);

2
compiler/heptagon/transformations/itfusion.ml
View file

@ -56,7 +56,7 @@ let anon_nodes = ref QualEnv.empty
let add_anon_node inputs outputs locals eqs =
let n = mk_fresh_node_name () in
let b = mk_block ~locals:locals eqs in
let nd = mk_node ~input:inputs ~output:outputs n b in
let nd = Hept_utils.mk_node ~input:inputs ~output:outputs n b in
anon_nodes := QualEnv.add n nd !anon_nodes;
n

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

@ -34,7 +34,7 @@ open Hept_mapfold
let translate_present_handlers handlers cont =
let translate_present_handler { p_cond = e; p_block = b } cont =
let stateful = b.b_stateful or cont.b_stateful in
let stateful = b.b_stateful || cont.b_stateful in
mk_block ~stateful:stateful ~defnames:b.b_defnames
[mk_switch_equation e
[{ w_name = Initial.ptrue; w_block = b };
@ -52,4 +52,3 @@ let program p =
let funs = { Hept_mapfold.defaults with eqdesc = eqdesc } in
let p, _ = Hept_mapfold.program_it funs false p in
p

2
compiler/main/hept2mls.ml
View file

@ -108,7 +108,7 @@ let translate_app app =
let mk_extvalue e w =
let clock = match e.Heptagon.e_ct_annot with
| None -> fresh_clock ()
| Some ct -> assert_1 (unprod ct)
| Some ct -> assert_1 (Clocks.unprod ct)
in
mk_extvalue ~loc:e.Heptagon.e_loc ~linearity:e.Heptagon.e_linearity
~ty:e.Heptagon.e_ty ~clock:clock w

1
compiler/main/heptc.ml
View file

@ -28,7 +28,6 @@
(***********************************************************************)
open Misc
open Compiler_utils
open Compiler_options

12
compiler/main/hepts.ml
View file

@ -360,13 +360,11 @@ let main () =
(fun s -> raise (Arg.Bad ("Invalid argument: " ^ s)))
usage_msg;
if (!mod_name = "")
or (!node_name = "")
or (!exec_name = "") then
begin
Arg.usage arg_list usage_msg;
raise Error
end;
if (!mod_name = "") || (!node_name = "") || (!exec_name = "") then
begin
Arg.usage arg_list usage_msg;
raise Error
end;
open_module (Module !mod_name);

12
compiler/main/mls2obc.ml
View file

@ -216,9 +216,9 @@ let ssa_update_record dest src f v =
List.map assgn_act fields
let rec control map ck s = match ck with
| Cbase | Cvar { contents = Cindex _ } -> s
| Clocks.Cbase | Cvar { contents = Cindex _ } -> s
| Cvar { contents = Clink ck } -> control map ck s
| Con(ck, c, n) ->
| Clocks.Con(ck, c, n) ->
let x = ext_value_exp_from_name map n in
control map ck (Acase(x, [(c, mk_block [s])]))
@ -771,10 +771,10 @@ let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc;
let translate_const_def { Minils.c_name = name; Minils.c_value = se;
Minils.c_type = ty; Minils.c_loc = loc } =
{ c_name = name;
c_value = se;
c_type = ty;
c_loc = loc }
{ Obc.c_name = name;
Obc.c_value = se;
Obc.c_type = ty;
Obc.c_loc = loc }
let program { Minils.p_modname = p_modname; Minils.p_opened = p_o; Minils.p_desc = pd; } =
build_anon pd;

23
compiler/minils/analysis/clocking.ml
View file

@ -48,7 +48,10 @@ open Location
open Format
(** Error Kind *)
type error_kind = | Etypeclash of ct * ct | Eclockclash of ck * ck | Edefclock
type error_kind =
| Etypeclash of ct * ct
| Eclockclash of Clocks.ck * Clocks.ck
| Edefclock
let error_message loc = function
| Etypeclash (actual_ct, expected_ct) ->
@ -88,7 +91,7 @@ let rec typing_extvalue h w =
| Wwhen (w1, c, n) ->
let ck_n = ck_of_name h n in
expect_extvalue h ck_n w1;
Con (ck_n, c, n)
Clocks.Con (ck_n, c, n)
| Wfield (w1, _) ->
typing_extvalue h w1
| Wreinit (w1, w2) ->
@ -178,11 +181,11 @@ let typing_eq h ({ eq_lhs = pat; eq_rhs = e; eq_loc = loc } as eq) =
| Ewhen (e,c,n) ->
let ck_n = ck_of_name h n in
let _base = expect (skeleton ck_n e.e_ty) e in
let base_ck = if stateful e then ck_n else Con (ck_n, c, n) in
skeleton (Con (ck_n, c, n)) e.e_ty, base_ck
let base_ck = if stateful e then ck_n else Clocks.Con (ck_n, c, n) in
skeleton (Clocks.Con (ck_n, c, n)) e.e_ty, base_ck
| Emerge (x, c_e_list) ->
let ck = ck_of_name h x in
List.iter (fun (c,e) -> expect_extvalue h (Con (ck,c,x)) e) c_e_list;
List.iter (fun (c,e) -> expect_extvalue h (Clocks.Con (ck,c,x)) e) c_e_list;
Ck ck, ck
| Estruct l ->
let ck = fresh_clock () in
@ -265,10 +268,10 @@ let typing_contract h0 h contract =
(* assumption *)
(* property *)
let eq_list = typing_eqs h' eq_list in
expect_extvalue h' Cbase e_a;
expect_extvalue h' Cbase e_g;
expect_extvalue h Cbase e_a_loc;
expect_extvalue h Cbase e_g_loc;
expect_extvalue h' Clocks.Cbase e_a;
expect_extvalue h' Clocks.Cbase e_g;
expect_extvalue h Clocks.Cbase e_a_loc;
expect_extvalue h Clocks.Cbase e_g_loc;
let h = append_env h c_list in
Some { contract with c_eq = eq_list }, h
@ -281,7 +284,7 @@ let typing_node node =
(* let h = append_env h node.n_local in *)
let equs = typing_eqs h node.n_equs in
(* synchronize input and output on base : find the free vars and set them to base *)
Env.iter (fun _ ck -> unify_ck Cbase (root_ck_of ck)) h0;
Env.iter (fun _ ck -> unify_ck Clocks.Cbase (root_ck_of ck)) h0;
(*update clock info in variables descriptions *)
let set_clock vd = { vd with v_clock = ck_repr (Env.find vd.v_ident h) } in
let node = { node with n_input = List.map set_clock node.n_input;

16
compiler/minils/analysis/interference.ml
View file

@ -112,8 +112,8 @@ module InterfRead = struct
exception Const_extvalue
let rec vars_ck acc = function
| Con(ck2, _, n) -> (Ivar n)::(vars_ck acc ck2)
| Cbase | Cvar { contents = Cindex _ } -> acc
| Clocks.Con(ck2, _, n) -> (Ivar n)::(vars_ck acc ck2)
| Clocks.Cbase | Cvar { contents = Cindex _ } -> acc
| Cvar { contents = Clink ck } -> vars_ck acc ck
let rec vars_ct acc ct = match ct with
@ -343,7 +343,7 @@ let all_ivars_list ivs =
let is_fast_memory x =
match ck_repr (World.ivar_clock (Imem x)) with
| Cbase -> false
| Clocks.Cbase -> false
| _ -> true
(* TODO: variables with no use ?? *)
@ -405,7 +405,7 @@ let should_interfere (ivx, ivy) =
not ((x_is_mem && not x_is_when) ||
(y_is_mem && not y_is_when)) && Clocks.are_disjoint ckx cky
in
not (disjoint_clocks or are_copies)
not (disjoint_clocks || are_copies)
)
let should_interfere = Misc.memoize_couple should_interfere
@ -417,7 +417,7 @@ let should_interfere = Misc.memoize_couple should_interfere
let init_interference_graph () =
let add_tyenv env iv =
let ty = Static.simplify_type Names.QualEnv.empty (World.ivar_type iv) in
TyEnv.add_element ty (mk_node iv) env
TyEnv.add_element ty (Interference_graph.mk_node iv) env
in
(** Adds a node for the variable and all fields of a variable. *)
let add_ivar env iv ty =
@ -441,7 +441,7 @@ let init_interference_graph () =
is real. *)
let add_interferences_from_list force vars =
let add_interference ivx ivy =
if force or should_interfere (ivx, ivy) then
if force || should_interfere (ivx, ivy) then
add_interference_link_from_ivar ivx ivy
in
Misc.iter_couple add_interference vars
@ -628,10 +628,10 @@ let add_init_return_eq f =
(** a_1,..,a_p = __init__ *)
let eq_init = mk_equation false (pat_from_dec_list f.n_input)
(mk_extvalue_exp Cbase Initial.tint ~linearity:Ltop (Wconst (Initial.mk_static_int 0))) in
(mk_extvalue_exp Clocks.Cbase Initial.tint ~linearity:Ltop (Wconst (Initial.mk_static_int 0))) in
(** __return__ = o_1,..,o_q, mem_1, ..., mem_k *)
let eq_return = mk_equation false (Etuplepat [])
(mk_exp Cbase Tinvalid ~linearity:Ltop (tuple_from_dec_and_mem_list f.n_output)) in
(mk_exp Clocks.Cbase Tinvalid ~linearity:Ltop (tuple_from_dec_and_mem_list f.n_output)) in
(eq_init::f.n_equs)@[eq_return]
(** Coalesce Imem x and Ivar x *)

8
compiler/minils/minils.ml
View file

@ -61,7 +61,7 @@ and tdesc =
and extvalue = {
w_desc : extvalue_desc;
mutable w_ck: ck;
mutable w_ck: Clocks.ck;
w_ty : ty;
w_linearity : linearity;
w_loc : location }
@ -75,7 +75,7 @@ and extvalue_desc =
and exp = {
e_desc : edesc;
e_level_ck : ck; (*when no data dep, execute the exp on this clock (set by [switch] *)
e_level_ck : Clocks.ck; (*when no data dep, execute the exp on this clock (set by [switch] *)
mutable e_ct : ct;
e_ty : ty;
e_linearity : linearity;
@ -127,14 +127,14 @@ type eq = {
eq_lhs : pat;
eq_rhs : exp;
eq_unsafe : bool;
eq_base_ck : ck;
eq_base_ck : Clocks.ck;
eq_loc : location }
type var_dec = {
v_ident : var_ident;
v_type : ty;
v_linearity : linearity;
v_clock : ck;
v_clock : Clocks.ck;
v_loc : location }
type contract = {

2
compiler/minils/mls_printer.ml
View file

@ -53,7 +53,7 @@ let rec print_pat ff = function
fprintf ff "@[<2>(%a)@]" (print_list_r print_pat """,""") pat_list
let print_vd ?(show_ck=false) ff { v_ident = n; v_type = ty; v_linearity = lin; v_clock = ck } =
if show_ck or !Compiler_options.full_type_info then
if show_ck || !Compiler_options.full_type_info then
fprintf ff "%a : %a%a :: %a" print_ident n print_type ty print_linearity lin print_ck ck
else fprintf ff "%a : %a%a" print_ident n print_type ty print_linearity lin

12
compiler/minils/mls_utils.ml
View file

@ -77,7 +77,7 @@ let rec vd_find n = function
a list of [var_dec]. *)
let rec vd_mem n = function
| [] -> false
| vd::l -> vd.v_ident = n or (vd_mem n l)
| vd::l -> vd.v_ident = n || (vd_mem n l)
(** @return whether [ty] corresponds to a record type. *)
@ -102,8 +102,8 @@ struct
let def acc { eq_lhs = pat } = vars_pat acc pat
let rec vars_ck acc = function
| Con(ck, _, n) -> vars_ck (add n acc) ck
| Cbase | Cvar { contents = Cindex _ } -> acc
| Clocks.Con(ck, _, n) -> vars_ck (add n acc) ck
| Clocks.Cbase | Cvar { contents = Cindex _ } -> acc
| Cvar { contents = Clink ck } -> vars_ck acc ck
let rec vars_ct acc = function
@ -178,9 +178,9 @@ struct
let head ck =
let rec headrec ck l =
match ck with
| Cbase
| Clocks.Cbase
| Cvar { contents = Cindex _ } -> l
| Con(ck, _, n) -> headrec ck (n :: l)
| Clocks.Con(ck, _, n) -> headrec ck (n :: l)
| Cvar { contents = Clink ck } -> headrec ck l
in
headrec ck []
@ -262,7 +262,7 @@ let remove_eqs_from_node nd ids =
let walk_vd vd vd_list = if IdentSet.mem vd.v_ident ids then vd_list else vd :: vd_list in
let walk_eq eq eq_list =
let defs = ident_list_of_pat eq.eq_lhs in
if (not eq.eq_unsafe) & List.for_all (fun v -> IdentSet.mem v ids) defs
if (not eq.eq_unsafe) && List.for_all (fun v -> IdentSet.mem v ids) defs
then eq_list
else eq :: eq_list
in

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

@ -88,8 +88,8 @@ let rec translate_ck pref e = function
let e = translate_ck pref e ck in
Swhen(e,
match (shortname c) with
"true" -> Svar(pref ^ (name var))
| "false" -> Snot(Svar(pref ^ (name var)))
"true" -> Sigali.Svar(pref ^ (name var))
| "false" -> Snot(Sigali.Svar(pref ^ (name var)))
| _ -> assert false)
@ -105,9 +105,9 @@ let rec translate_ext prefix ({ Minils.w_desc = desc; Minils.w_ty = ty }) =
(* get variable iff it is Boolean or local *)
begin match (actual_ty ty) with
| Tbool ->
Svar(prefix ^ (name n))
Sigali.Svar(prefix ^ (name n))
| Tint when (IdentSet.mem n !current_locals) ->
Svar(prefix ^ (name n))
Sigali.Svar(prefix ^ (name n))
| _ ->
raise Untranslatable
end
@ -210,7 +210,7 @@ let rec translate prefix ({ Minils.e_desc = desc } as e) =
| "false" -> e2,e1
| _ -> assert false
end in
let var_ck = Svar(prefix ^ (name ck)) in
let var_ck = Sigali.Svar(prefix ^ (name ck)) in
begin match (actual_ty e.Minils.e_ty) with
| Tbool -> Sdefault(Swhen(e1,var_ck),e2)
| Tint -> a_part var_ck (a_const (Sconst(Cint(0)))) e1 e2
@ -258,7 +258,7 @@ let translate_eq f
let c = translate_static_exp c in
(extend
initialisations
(Slist[Sequal(Svar(sn),Sconst(c))]))::acc_eqs,
(Slist[Sequal(Sigali.Svar(sn),Sconst(c))]))::acc_eqs,
c::acc_init
in
let e_next = translate_ext prefix e' in
@ -268,7 +268,7 @@ let translate_eq f
acc_init,acc_inputs,
(extend
evolutions
(Slist[Sdefault(e_next,Svar(sn))]))
(Slist[Sdefault(e_next,Sigali.Svar(sn))]))
::acc_eqs
with Untranslatable ->
untranslatable_warn e;
@ -346,7 +346,7 @@ let translate_contract f contract =
let body =
[{ stmt_name = var_g; stmt_def = Sconst(Ctrue) };
{ stmt_name = var_a; stmt_def = Sconst(Ctrue) }] in
[],[],[],body,(Svar(var_a),Svar(var_g)),[],[],[]
[],[],[],body,(Sigali.Svar(var_a),Sigali.Svar(var_g)),[],[],[]
| Some {Minils.c_local = locals;
Minils.c_eq = l_eqs;
Minils.c_assume = e_a;
@ -366,7 +366,8 @@ let translate_contract f contract =
let controllables =
List.map
(fun ({ Minils.v_ident = id } as v) -> v,(prefix ^ (name id))) cl in
states,init,inputs,body,(Svar(var_a),Svar(var_g)),controllables,(locals@cl),l_eqs
states,init,inputs,body,(Sigali.Svar(var_a),Sigali.Svar(var_g)),
controllables,(locals@cl),l_eqs
@ -406,7 +407,7 @@ let translate_node
let mls_ctrl,sig_ctrl = List.split controllables in
let constraints =
List.map
(fun v -> Sequal(Ssquare(Svar(v)),Sconst(Ctrue)))
(fun v -> Sequal(Ssquare(Sigali.Svar(v)),Sconst(Ctrue)))
(sig_inputs@sig_ctrl) in
let constraints = constraints @ [Sequal (a_c,Sconst(Ctrue))] in
let body_sink, sig_states_full, obj_exp =
@ -422,11 +423,11 @@ let translate_node
let body_sink =
[(extend
initialisations
(Slist[Sequal(Svar(error_state_name),Sconst(Ctrue))]));
(Slist[Sequal(Sigali.Svar(error_state_name),Sconst(Ctrue))]));
(extend
evolutions
(Slist[g_c]))] in
(body_sink, sig_states_full, Svar(error_state_name))
(body_sink, sig_states_full, Sigali.Svar(error_state_name))
end in
let obj = Security(obj_exp) in
let p = { proc_dep = [];

2
compiler/minils/transformations/schedule_interf.ml
View file

@ -162,7 +162,7 @@ struct
let rec min_same_ck (min_eq, min_c, min_same_ctrl) l = match l with
| [] -> min_eq
| (eq, c, same_ctrl)::l ->
if (c < min_c) or (c = min_c && (same_ctrl && not min_same_ctrl)) then
if (c < min_c) || (c = min_c && (same_ctrl && not min_same_ctrl)) then
min_same_ck (eq, c, same_ctrl) l
else
min_same_ck (min_eq, min_c, min_same_ctrl) l

19
compiler/minils/transformations/tomato.ml
View file

@ -81,7 +81,7 @@ struct
{
mutable er_class : int;
er_clock_type : ct;
er_base_ck : ck;
er_base_ck : Clocks.ck;
er_pattern : pat;
er_head : exp;
er_children : class_ref list;
@ -96,7 +96,7 @@ struct
open Mls_printer
let print_class_ref fmt cr = match cr with
| Cr_plain id -> print_ident fmt id
| Cr_plain id -> Global_printer.print_ident fmt id
| Cr_input w -> Format.fprintf fmt "%a (input)" print_extvalue w
let debug_tenv fmt tenv =
@ -149,19 +149,19 @@ struct
let rec clock_compare ck1 ck2 = match ck1, ck2 with
| Cvar { contents = Clink ck1; }, _ -> clock_compare ck1 ck2
| _, Cvar { contents = Clink ck2; } -> clock_compare ck1 ck2
| Cbase, Cbase -> 0
| Clocks.Cbase, Clocks.Cbase -> 0
| Cvar lr1, Cvar lr2 -> link_compare_modulo !lr1 !lr2
| Con (ck1, cn1, vi1), Con (ck2, cn2, vi2) ->
| Clocks.Con (ck1, cn1, vi1), Clocks.Con (ck2, cn2, vi2) ->
let cr1 = compare cn1 cn2 in
if cr1 <> 0 then cr1 else
let cr2 = ident_compare_modulo vi1 vi2 in
if cr2 <> 0 then cr2 else clock_compare ck1 ck2
| Cbase , _ -> 1
| Clocks.Cbase , _ -> 1
| Cvar _, Cbase -> -1
| Cvar _, Clocks.Cbase -> -1
| Cvar _, _ -> 1
| Con _, _ -> -1
| Clocks.Con _, _ -> -1
and link_compare_modulo li1 li2 = match li1, li2 with
| Cindex _, Cindex _ -> 0
@ -490,7 +490,7 @@ and reconstruct_class_ref mapping cr = match cr with
x
and reconstruct_clock mapping ck = match ck_repr ck with
| Con (ck, c, x) -> Con (reconstruct_clock mapping ck, c, new_name mapping x)
| Clocks.Con (ck, c, x) -> Clocks.Con (reconstruct_clock mapping ck, c, new_name mapping x)
| _ -> ck
and reconstruct_clock_type mapping ct = match ct with
@ -562,7 +562,8 @@ let compute_new_class (tenv : tom_env) =
| Cr_input _ -> None
| Cr_plain x ->
try Some (Env.find x mapping)
with Not_found -> Format.eprintf "Unknown class %a@." print_ident x; assert false
with Not_found -> Format.eprintf "Unknown class %a@."
Global_printer.print_ident x; assert false
in
let children = List.map map_class_ref eqr.er_children in

15
compiler/obc/c/cgen.ml
View file

@ -233,7 +233,7 @@ and create_affect_stm dest src ty =
| Cty_id ln ->
(match src with
| Cstructlit (_, ce_list) ->
let create_affect { f_name = f_name;
let create_affect { Signature.f_name = f_name;
Signature.f_type = f_type; } e stm_list =
let cty = ctype_of_otype f_type in
create_affect_stm (CLfield (dest, f_name)) e cty @ stm_list in
@ -263,7 +263,8 @@ let rec cexpr_of_static_exp se =
(cexpr_of_static_exp c) n_list)
| Svar ln ->
if !Compiler_options.unroll_loops && se.se_ty = Initial.tint
then cexpr_of_static_exp (Static.simplify QualEnv.empty (find_const ln).c_value)
then cexpr_of_static_exp
(Static.simplify QualEnv.empty (find_const ln).Signature.c_value)
else Cvar (cname_of_qn ln)
| Sop _ ->
let se' = Static.simplify QualEnv.empty se in
@ -497,7 +498,7 @@ let generate_function_call out_env var_env obj_env outvl objn args =
let rec create_affect_const var_env (dest : clhs) c =
match c.se_desc with
| Svar ln ->
let se = Static.simplify QualEnv.empty (find_const ln).c_value in
let se = Static.simplify QualEnv.empty (find_const ln).Signature.c_value in
create_affect_const var_env dest se
| Sarray_power(c, n_list) ->
let rec make_loop power_list replace = match power_list with
@ -684,7 +685,7 @@ let fun_def_of_step_fun n obj_env mem objs md =
let body = cstm_of_act_list out_env var_env obj_env md.m_body in
Cfundef {
f_name = fun_name;
C.f_name = fun_name;
f_retty = Cty_void;
f_args = args;
f_body = {
@ -741,7 +742,7 @@ let reset_fun_def_of_class_def cd =
[]
in
Cfundef {
f_name = (cname_of_qn cd.cd_name) ^ "_reset";
C.f_name = (cname_of_qn cd.cd_name) ^ "_reset";
f_retty = Cty_void;
f_args = [("self", Cty_ptr (Cty_id (qn_append cd.cd_name "_mem")))];
f_body = {
@ -787,7 +788,7 @@ let cdefs_and_cdecls_of_type_decl otd =
[], [Cdecl_typedef (ctype_of_otype ty, name)]
| Type_enum nl ->
let of_string_fun = Cfundef
{ f_name = name ^ "_of_string";
{ C.f_name = name ^ "_of_string";
f_retty = Cty_id otd.t_name;
f_args = [("s", Cty_ptr Cty_char)];
f_body =
@ -802,7 +803,7 @@ let cdefs_and_cdecls_of_type_decl otd =
map gen_if nl; }
}
and to_string_fun = Cfundef
{ f_name = "string_of_" ^ name;
{ C.f_name = "string_of_" ^ name;
f_retty = Cty_ptr Cty_char;
f_args = [("x", Cty_id otd.t_name); ("buf", Cty_ptr Cty_char)];
f_body =

2
compiler/obc/c/cmain.ml
View file

@ -313,7 +313,7 @@ let main_def_of_class_def cd =
variable list [var_list], prologue [prologue] and loop body [body]. *)
let main_skel var_list prologue body =
Cfundef {
f_name = "main";
C.f_name = "main";
f_retty = Cty_int;
f_args = [("argc", Cty_int); ("argv", Cty_ptr (Cty_ptr Cty_char))];
f_body = {

8
compiler/obc/control.ml
View file

@ -38,8 +38,8 @@ open Obc_mapfold
let appears_in_exp, appears_in_lhs =
let lhsdesc _ (x, acc) ld = match ld with
| Lvar y -> ld, (x, acc or (x=y))
| Lmem y -> ld, (x, acc or (x=y))
| Lvar y -> ld, (x, acc || (x=y))
| Lmem y -> ld, (x, acc || (x=y))
| _ -> raise Errors.Fallback
in
let funs = { Obc_mapfold.defaults with lhsdesc = lhsdesc } in
@ -75,14 +75,14 @@ let rec is_modified_by_call x args e_list = match args, e_list with
let is_modified_handlers j x handlers =
let act _ acc a = match a with
| Aassgn(l, _) -> a, acc or (appears_in_lhs x l)
| Aassgn(l, _) -> a, acc || (appears_in_lhs x l)
| Acall (name_list, o, Mstep, e_list) ->
(* first, check if e is one of the output of the function*)
if List.exists (appears_in_lhs x) name_list then
a, true
else (
let sig_info = find_obj (obj_ref_name o) j in
a, acc or (is_modified_by_call x sig_info.node_inputs e_list)
a, acc || (is_modified_by_call x sig_info.node_inputs e_list)
)
| _ -> raise Errors.Fallback
in

3
compiler/obc/java/java14_main.ml
View file

@ -1,4 +1,3 @@
open Misc
open Names
open Modules
open Signature
@ -37,7 +36,7 @@ let program p =
Idents.enter_node class_name;
let field_step_dnb, id_step_dnb =
let id = Idents.gen_var "java_main" "default_step_nb" in
mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id
Java.mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id
in
let main_methode =

3
compiler/obc/java/java_main.ml
View file

@ -26,7 +26,6 @@
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
(* *)
(***********************************************************************)
open Misc
open Names
open Modules
open Signature
@ -67,7 +66,7 @@ let program p =
Idents.enter_node class_name;
let field_step_dnb, id_step_dnb =
let id = Idents.gen_var "java_main" "default_step_nb" in
mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id
Java.mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id
in
let main_methode =

2
compiler/obc/java/java_printer.ml
View file

@ -95,7 +95,7 @@ and new_init_ty ff t = _ty true true ff t
and ty ff t = _ty false false ff t
and var_dec init ff vd =
if init & not vd.vd_alias then
if init && not vd.vd_alias then
fprintf ff "%a %a = %a" ty vd.vd_type var_ident vd.vd_ident exp (Java.default_value vd.vd_type)
else
fprintf ff "%a %a" ty vd.vd_type var_ident vd.vd_ident

68
compiler/obc/java/obc2java.ml
View file

@ -39,7 +39,6 @@
[p = e] when [e] is an array is understand as a copy of the reference, not a copy of the array.*)
open Format
open Misc
open Names
open Signature
open Obc
@ -58,8 +57,8 @@ let add_classe, get_classes =
with [body] a function from [var_ident] (the iterator) to [act] list *)
let fresh_for size body =
let i = Idents.gen_var "obc2java" "i" in
let id = mk_var_dec i false Tint in
Afor (id, Sint 0, size, mk_block (body i))
let id = Java.mk_var_dec i false Tint in
Java.Afor (id, Sint 0, size, Java.mk_block (body i))
(** fresh nested Afor from 0 to [size]
with [body] a function from [var_ident] list (the iterator list) to [act] list :
@ -73,12 +72,12 @@ let fresh_nfor s_l body =
let rec aux s_l i_l = match s_l with
| [s] ->
let i = Idents.gen_var "obc2java" "i" in
let id = (mk_var_dec i false Tint) in
Afor (id, Sint 0, s, mk_block (body (List.rev (i::i_l))))
let id = (Java.mk_var_dec i false Tint) in
Java.Afor (id, Sint 0, s, Java.mk_block (body (List.rev (i::i_l))))
| s::s_l ->
let i = Idents.gen_var "obc2java" "i" in
let id = mk_var_dec i false Tint in
Afor (id, Sint 0, s, mk_block ([aux s_l (i::i_l)]))
let id = Java.mk_var_dec i false Tint in
Java.Afor (id, Sint 0, s, Java.mk_block ([aux s_l (i::i_l)]))
| [] -> Misc.internal_error "Fresh nfor called with empty size list"
in
aux s_l []
@ -327,19 +326,19 @@ let jop_of_op param_env op_name e_l =
let rec act_list param_env act_l acts =
let _act act acts = match act with
| Obc.Aassgn (p,e) -> (Aassgn (pattern param_env p, exp param_env e))::acts
| Obc.Aassgn (p,e) -> (Java.Aassgn (pattern param_env p, exp param_env e))::acts
| Obc.Aop (op,e_l) -> Aexp (jop_of_op param_env op e_l) :: acts
| Obc.Acall ([], obj, Mstep, e_l) ->
let acall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
Aexp acall::acts
| Obc.Acall ([p], obj, Mstep, e_l) ->
let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
let assgn = Aassgn (pattern param_env p, ecall) in
let assgn = Java.Aassgn (pattern param_env p, ecall) in
assgn::acts
| Obc.Acall (p_l, obj, Mstep, e_l) ->
let return_ty = p_l |> pattern_list_to_type |> (ty param_env) in
let return_id = Idents.gen_var "obc2java" "out" in
let return_vd = mk_var_dec return_id false return_ty in
let return_vd = Java.mk_var_dec return_id false return_ty in
let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
let assgn = Anewvar (return_vd, ecall) in
let copy_return_to_var i p =
@ -351,7 +350,7 @@ let rec act_list param_env act_l acts =
| _ -> Ecast(t, e)
in
let p = pattern param_env p in
Aassgn (p, cast t (Efield (Evar return_id, "c"^(string_of_int i))))
Java.Aassgn (p, cast t (Efield (Evar return_id, "c"^(string_of_int i))))
in
let copies = Misc.mapi copy_return_to_var p_l in
assgn::(copies@acts)
@ -364,7 +363,9 @@ let rec act_list param_env act_l acts =
| [(c,b)] when c = Initial.ptrue ->
(Aif (exp param_env e, block param_env b)):: acts
| [(c,b)] when c = Initial.pfalse ->
(Aifelse (exp param_env e, {b_locals = []; b_body = []}, block param_env b)) :: acts
(Aifelse (exp param_env e, {Java.b_locals = [];
Java.b_body = []},
block param_env b)) :: acts
| _ ->
let _, _then = List.find (fun (c,_) -> c = Initial.ptrue) c_b_l in
let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in
@ -376,11 +377,12 @@ let rec act_list param_env act_l acts =
let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
acase::acts
| Obc.Afor (v, se, se', b) ->
let afor = Afor (var_dec param_env v,
exp param_env se, exp param_env se', block param_env b) in
let afor = Java.Afor (var_dec param_env v,
exp param_env se, exp param_env se',
block param_env b) in
afor::acts
| Obc.Ablock b ->
let ablock = Ablock (block param_env b) in
let ablock = Java.Ablock (block param_env b) in
ablock::acts
in
List.fold_right _act act_l acts
@ -389,7 +391,7 @@ and block param_env ?(locals=[]) ?(end_acts=[]) ob =
let blocals = var_dec_list param_env ob.Obc.b_locals in
let locals = locals @ blocals in
let acts = act_list param_env ob.Obc.b_body end_acts in
{ b_locals = locals; b_body = acts }
{ Java.b_locals = locals; Java.b_body = acts }
@ -400,7 +402,7 @@ and block param_env ?(locals=[]) ?(end_acts=[]) ob =
let sig_params_to_vds p_l =
let param_to_arg param_env p =
let p_ident = Idents.gen_var "obc2java" (String.uppercase p.Signature.p_name) in
let p_vd = mk_var_dec p_ident false (ty param_env p.Signature.p_type) in
let p_vd = Java.mk_var_dec p_ident false (ty param_env p.Signature.p_type) in
let param_env = NamesEnv.add p.Signature.p_name p_ident param_env in
p_vd, param_env
in Misc.mapfold param_to_arg NamesEnv.empty p_l
@ -410,12 +412,12 @@ let sig_args_to_vds param_env a_l =
let arg_to_vd { a_name = n; a_type = t } =
let n = match n with None -> "v" | Some s -> s in
let id = Idents.gen_var "obc2java" n in
mk_var_dec id false (ty param_env t)
Java.mk_var_dec id false (ty param_env t)
in List.map arg_to_vd a_l
(** [copy_to_this vd_l] creates [this.x = x] for all [x] in [vd_l] *)
let copy_to_this vd_l =
let _vd vd = Aassgn (Pthis vd.vd_ident, Evar vd.vd_ident) in
let _vd vd = Java.Aassgn (Pthis vd.vd_ident, Evar vd.vd_ident) in
List.map _vd vd_l
@ -442,7 +444,7 @@ let class_def_list classes cd_l =
let reset_mems = block param_env (remove_resets oreset.Obc.m_body) in
mk_methode body "reset", reset_mems
with Not_found -> (* stub reset method *)
mk_methode (mk_block []) "reset", mk_block []
mk_methode (Java.mk_block []) "reset", Java.mk_block []
in
(* [obj_env] gives the type of an [obj_ident],
needed in async because we change the classe for async obj *)
@ -460,14 +462,14 @@ let class_def_list classes cd_l =
match od.o_size with
| None ->
let t = Idents.Env.find od.o_ident obj_env in
(Aassgn (Pthis od.o_ident, Enew (t, params)))::acts
(Java.Aassgn (Pthis od.o_ident, Enew (t, params)))::acts
| Some size_l ->
let size_l = List.rev (List.map (static_exp param_env) size_l) in
let t = Idents.Env.find od.o_ident obj_env in
let assgn_elem i_l =
[ Aassgn (Parray_elem (Pthis od.o_ident, List.map mk_var i_l), Enew (t, params)) ]
[ Java.Aassgn (Parray_elem (Pthis od.o_ident, List.map mk_var i_l), Enew (t, params)) ]
in
(Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size_l), [])))
(Java.Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size_l), [])))
:: (fresh_nfor size_l assgn_elem)
:: acts
in
@ -475,24 +477,24 @@ let class_def_list classes cd_l =
let allocate acts vd = match Modules.unalias_type vd.v_type with
| Types.Tarray _ ->
let t = ty param_env vd.v_type in
( Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts
( Java.Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts
| _ -> acts
in
(* init actions [acts] in reverse order : *)
(* init member variables *)
let acts = [Ablock reset_mems] in
let acts = [Java.Ablock reset_mems] in
(* allocate member arrays *)
let acts = List.fold_left allocate acts cd.cd_mems in
(* init member objects *)
let acts = List.fold_left obj_init_act acts cd.cd_objs in
(* init static params *)
let acts = (copy_to_this vds_params)@acts in
{ b_locals = []; b_body = acts }
{ Java.b_locals = []; Java.b_body = acts }
in mk_methode ~args:vds_params body (shortname class_name), obj_env
in
let fields =
let mem_to_field fields vd =
(mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields
(Java.mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields
in
let obj_to_field fields od =
let jty = match od.o_size with
@ -500,7 +502,7 @@ let class_def_list classes cd_l =
| Some size_l -> Tarray (Idents.Env.find od.o_ident obj_env,
List.map (static_exp param_env) size_l)
in
(mk_field ~protection:Pprotected jty od.o_ident) :: fields
(Java.mk_field ~protection:Pprotected jty od.o_ident) :: fields
in
let fields = fields_params in
let fields = List.fold_left mem_to_field fields cd.cd_mems in
@ -546,7 +548,7 @@ let type_dec_list classes td_l =
(* [translate_field_name] will give the right result anywhere it is used,
since the [ident_of_name] will keep it as it is unique in the class,
see [Idents.enter_node classe_name] *)
mk_field jty field
Java.mk_field jty field
in
let f_l =
List.sort
@ -554,15 +556,15 @@ let type_dec_list classes td_l =
compare (f1.Signature.f_name.name) (f2.Signature.f_name.name))
f_l in
let fields = List.map mk_field_jfield f_l in
let cons_params = List.map (fun f -> mk_var_dec f.f_ident false f.f_type) fields in
let cons_params = List.map (fun f -> Java.mk_var_dec f.f_ident false f.Java.f_type) fields in
let cons_body =
List.map
(fun f -> Aassgn ((Pthis f.f_ident),(Evar f.f_ident)))
(fun f -> Java.Aassgn ((Pthis f.f_ident),(Evar f.f_ident)))
fields in
let cons =
mk_methode
~args:cons_params
(mk_block cons_body)
(Java.mk_block cons_body)
classe_name.name in
(mk_classe ~fields:fields ~constrs:[cons] classe_name) :: classes
in
@ -582,7 +584,7 @@ let const_dec_list cd_l = match cd_l with
(* thus [translate_const_name] will gives the right result anywhere it is used. *)
let value = Some (static_exp param_env ovalue) in
let t = ty param_env otype in
mk_field ~static: true ~final: true ~value: value t name
Java.mk_field ~static: true ~final: true ~value: value t name
in
let fields = List.map mk_const_field cd_l in
[mk_classe ~fields: fields classe_name]

69
compiler/obc/java/obc2java14.ml
View file

@ -39,7 +39,6 @@
[p = e] when [e] is an array is understand as a copy of the reference, not a copy of the array.*)
open Format
open Misc
open Names
open Modules
open Signature
@ -59,8 +58,8 @@ let add_classe, get_classes =
with [body] a function from [var_ident] (the iterator) to [act] list *)
let fresh_for size body =
let i = Idents.gen_var "obc2java" "i" in
let id = mk_var_dec i false Tint in
Afor (id, Sint 0, size, mk_block (body i))
let id = Java.mk_var_dec i false Tint in
Java.Afor (id, Sint 0, size, Java.mk_block (body i))
(** fresh nested Afor from 0 to [size]
with [body] a function from [var_ident] list (the iterator list) to [act] list :
@ -74,12 +73,12 @@ let fresh_nfor s_l body =
let rec aux s_l i_l = match s_l with
| [s] ->
let i = Idents.gen_var "obc2java" "i" in
let id = (mk_var_dec i false Tint) in
Afor (id, Sint 0, s, mk_block (body (List.rev (i::i_l))))
let id = (Java.mk_var_dec i false Tint) in
Java.Afor (id, Sint 0, s, Java.mk_block (body (List.rev (i::i_l))))
| s::s_l ->
let i = Idents.gen_var "obc2java" "i" in
let id = mk_var_dec i false Tint in
Afor (id, Sint 0, s, mk_block ([aux s_l (i::i_l)]))
let id = Java.mk_var_dec i false Tint in
Java.Afor (id, Sint 0, s, Java.mk_block ([aux s_l (i::i_l)]))
| [] -> Misc.internal_error "Fresh nfor called with empty size list"
in
aux s_l []
@ -344,7 +343,7 @@ let jop_of_op param_env op_name e_l =
let rec act_list param_env act_l acts =
let _act act acts = match act with
| Obc.Aassgn (p,e) -> (Aassgn (pattern param_env p, exp param_env e))::acts
| Obc.Aassgn (p,e) -> (Java.Aassgn (pattern param_env p, exp param_env e))::acts
| Obc.Aop (op,e_l) -> Aexp (jop_of_op param_env op e_l) :: acts
| Obc.Acall (p_l, obj, Mstep, e_l) ->
let o_ref = obj_ref param_env obj in
@ -352,7 +351,7 @@ let rec act_list param_env act_l acts =
let assgn = Aexp ecall in
let copy_return_to_var i p =
let p = pattern param_env p in
Aassgn (p, Emethod_call (o_ref, "getOutput" ^ (string_of_int i), []))
Java.Aassgn (p, Emethod_call (o_ref, "getOutput" ^ (string_of_int i), []))
in
let copies = Misc.mapi copy_return_to_var p_l in
assgn::(copies@acts)
@ -365,7 +364,8 @@ let rec act_list param_env act_l acts =
| [(c,b)] when c = Initial.ptrue ->
(Aif (exp param_env e, block param_env b)):: acts
| [(c,b)] when c = Initial.pfalse ->
(Aifelse (exp param_env e, {b_locals = []; b_body = []}, block param_env b)) :: acts
(Aifelse (exp param_env e, {Java.b_locals = [];
Java.b_body = []}, block param_env b)) :: acts
| _ ->
let _, _then = List.find (fun (c,_) -> c = Initial.ptrue) c_b_l in
let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in
@ -382,11 +382,11 @@ let rec act_list param_env act_l acts =
let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
acase::acts
| Obc.Afor (v, se, se', b) ->
let afor = Afor (var_dec param_env v,
let afor = Java.Afor (var_dec param_env v,
exp param_env se, exp param_env se', block param_env b) in
afor::acts
| Obc.Ablock b ->
let ablock = Ablock (block param_env b) in
let ablock = Java.Ablock (block param_env b) in
ablock::acts
in
List.fold_right _act act_l acts
@ -395,7 +395,7 @@ and block param_env ?(locals=[]) ?(end_acts=[]) ob =
let blocals = var_dec_list param_env ob.Obc.b_locals in
let locals = locals @ blocals in
let acts = act_list param_env ob.Obc.b_body end_acts in
{ b_locals = locals; b_body = acts }
{ Java.b_locals = locals; Java.b_body = acts }
@ -406,7 +406,7 @@ and block param_env ?(locals=[]) ?(end_acts=[]) ob =
let sig_params_to_vds p_l =
let param_to_arg param_env p =
let p_ident = Idents.gen_var "obc2java" (String.uppercase p.Signature.p_name) in
let p_vd = mk_var_dec p_ident false (ty param_env p.Signature.p_type) in
let p_vd = Java.mk_var_dec p_ident false (ty param_env p.Signature.p_type) in
let param_env = NamesEnv.add p.Signature.p_name p_ident param_env in
p_vd, param_env
in Misc.mapfold param_to_arg NamesEnv.empty p_l
@ -416,12 +416,12 @@ let sig_args_to_vds param_env a_l =
let arg_to_vd { a_name = n; a_type = t } =
let n = match n with None -> "v" | Some s -> s in
let id = Idents.gen_var "obc2java" n in
mk_var_dec id false (ty param_env t)
Java.mk_var_dec id false (ty param_env t)
in List.map arg_to_vd a_l
(** [copy_to_this vd_l] creates [this.x = x] for all [x] in [vd_l] *)
let copy_to_this vd_l =
let _vd vd = Aassgn (Pthis vd.vd_ident, Evar vd.vd_ident) in
let _vd vd = Java.Aassgn (Pthis vd.vd_ident, Evar vd.vd_ident) in
List.map _vd vd_l
@ -448,7 +448,7 @@ let class_def_list classes cd_l =
let reset_mems = block param_env (remove_resets oreset.Obc.m_body) in
mk_methode body "reset", reset_mems
with Not_found -> (* stub reset method *)
mk_methode (mk_block []) "reset", mk_block []
mk_methode (Java.mk_block []) "reset", Java.mk_block []
in
(* [obj_env] gives the type of an [obj_ident],
needed in async because we change the classe for async obj *)
@ -466,14 +466,14 @@ let class_def_list classes cd_l =
match od.o_size with
| None ->
let t = Idents.Env.find od.o_ident obj_env in
(Aassgn (Pthis od.o_ident, Enew (t, params)))::acts
(Java.Aassgn (Pthis od.o_ident, Enew (t, params)))::acts
| Some size_l ->
let size_l = List.rev (List.map (static_exp param_env) size_l) in
let t = Idents.Env.find od.o_ident obj_env in
let assgn_elem i_l =
[ Aassgn (Parray_elem (Pthis od.o_ident, List.map mk_var i_l), Enew (t, params)) ]
[ Java.Aassgn (Parray_elem (Pthis od.o_ident, List.map mk_var i_l), Enew (t, params)) ]
in
(Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size_l), [])))
(Java.Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size_l), [])))
:: (fresh_nfor size_l assgn_elem)
:: acts
in
@ -481,24 +481,24 @@ let class_def_list classes cd_l =
let allocate acts vd = match Modules.unalias_type vd.v_type with
| Types.Tarray _ ->
let t = ty param_env vd.v_type in
( Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts
( Java.Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts
| _ -> acts
in
(* init actions [acts] in reverse order : *)
(* init member variables *)
let acts = [Ablock reset_mems] in
let acts = [Java.Ablock reset_mems] in
(* allocate member arrays *)
let acts = List.fold_left allocate acts cd.cd_mems in
(* init member objects *)
let acts = List.fold_left obj_init_act acts cd.cd_objs in
(* init static params *)
let acts = (copy_to_this vds_params)@acts in
{ b_locals = []; b_body = acts }
{ Java.b_locals = []; Java.b_body = acts }
in mk_methode ~args:vds_params body (shortname class_name), obj_env
in
let fields =
let mem_to_field fields vd =
(mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields
(Java.mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields
in
let obj_to_field fields od =
let jty = match od.o_size with
@ -506,7 +506,7 @@ let class_def_list classes cd_l =
| Some size_l -> Tarray (Idents.Env.find od.o_ident obj_env,
List.map (static_exp param_env) size_l)
in
(mk_field ~protection:Pprotected jty od.o_ident) :: fields
(Java.mk_field ~protection:Pprotected jty od.o_ident) :: fields
in
let fields = fields_params in
let fields = List.fold_left mem_to_field fields cd.cd_mems in
@ -515,11 +515,11 @@ let class_def_list classes cd_l =
let ostep = find_step_method cd in
let vd_output = var_dec_list param_env ostep.m_outputs in
let output_fields =
List.map (fun vd -> mk_field vd.vd_type vd.vd_ident) vd_output in
List.map (fun vd -> Java.mk_field vd.vd_type vd.vd_ident) vd_output in
let fields = fields @ output_fields in
let build_output_methods i f =
mk_methode ~returns:f.f_type
(mk_block [Areturn (Evar f.f_ident)])
mk_methode ~returns:f.Java.f_type
(Java.mk_block [Areturn (Evar f.f_ident)])
("getOutput" ^ (string_of_int i))
in
let output_methods = Misc.mapi build_output_methods output_fields in
@ -551,7 +551,7 @@ let type_dec_list classes td_l =
let init_value = Sint i in
let c = translate_constructor_name_2 c classe_name in
let field =
mk_field ~static:true ~final:true ~value:(Some init_value)
Java.mk_field ~static:true ~final:true ~value:(Some init_value)
Tint (Idents.ident_of_name c.name) in
(field::acc_fields),(i+1) in
let fields,_ = List.fold_left mk_constr_field ([],1) c_l in
@ -563,7 +563,7 @@ let type_dec_list classes td_l =
(* [translate_field_name] will give the right result anywhere it is used,
since the [ident_of_name] will keep it as it is unique in the class,
see [Idents.enter_node classe_name] *)
mk_field jty field
Java.mk_field jty field
in
let f_l =
List.sort
@ -571,15 +571,16 @@ let type_dec_list classes td_l =
compare (f1.Signature.f_name.name) (f2.Signature.f_name.name))
f_l in
let fields = List.map mk_field_jfield f_l in
let cons_params = List.map (fun f -> mk_var_dec f.f_ident false f.f_type) fields in
let cons_params = List.map
(fun f -> Java.mk_var_dec f.f_ident false f.Java.f_type) fields in
let cons_body =
List.map
(fun f -> Aassgn ((Pthis f.f_ident),(Evar f.f_ident)))
(fun f -> Java.Aassgn ((Pthis f.f_ident),(Evar f.f_ident)))
fields in
let cons =
mk_methode
~args:cons_params
(mk_block cons_body)
(Java.mk_block cons_body)
classe_name.name in
(mk_classe ~fields:fields ~constrs:[cons] classe_name) :: classes
in
@ -599,7 +600,7 @@ let const_dec_list cd_l = match cd_l with
(* thus [translate_const_name] will gives the right result anywhere it is used. *)
let value = Some (static_exp param_env ovalue) in
let t = ty param_env otype in
mk_field ~static: true ~final: true ~value: value t name
Java.mk_field ~static: true ~final: true ~value: value t name
in
let fields = List.map mk_const_field cd_l in
[mk_classe ~fields: fields classe_name]

4
compiler/obc/main/obc_compiler.ml
View file

@ -35,7 +35,7 @@ let compile_program p =
(* Memory allocation application *)
let p = pass "Application of Memory Allocation"
(!do_mem_alloc or !do_linear_typing) Memalloc_apply.program p pp in
(!do_mem_alloc || !do_linear_typing) Memalloc_apply.program p pp in
(*Scalarize for wanting backends*)
let p = pass "Scalarize" (!do_scalarize) Scalarize.program p pp in
@ -45,7 +45,7 @@ let compile_program p =
(*Dead code removal*)
let p = pass "Dead code removal"
(!do_mem_alloc or !do_linear_typing) Deadcode.program p pp in
(!do_mem_alloc || !do_linear_typing) Deadcode.program p pp in
(*Control optimization*)
let p = pass "Control optimization" true Control.program p pp in

6
compiler/obc/obc_utils.ml
View file

@ -100,7 +100,7 @@ let mk_if cond true_act =
let rec var_name x =
match x.pat_desc with
| Lvar x -> x
| Obc.Lvar x -> x
| Lmem x -> x
| Lfield(x,_) -> var_name x
| Larray(l, _) -> var_name l
@ -109,7 +109,7 @@ let rec var_name x =
a list of var_dec. *)
let rec vd_mem n = function
| [] -> false
| vd::l -> vd.v_ident = n or (vd_mem n l)
| vd::l -> vd.v_ident = n || (vd_mem n l)
(** Returns the var_dec object corresponding to the name n
in a list of var_dec. *)
@ -286,7 +286,7 @@ let interface_types i =
let rec ext_value_of_pattern patt =
let desc = match patt.pat_desc with
| Lvar id -> Wvar id
| Obc.Lvar id -> Wvar id
| Lmem id -> Wmem id
| Lfield (p, fn) -> Wfield (ext_value_of_pattern p, fn)
| Larray (p, e) -> Warray (ext_value_of_pattern p, e) in

15
compiler/obc/transformations/memalloc_apply.ml
View file

@ -42,7 +42,7 @@ module LinListEnv =
end)
let rec ivar_of_pat l = match l.pat_desc with
| Lvar x -> Ivar x
| Obc.Lvar x -> Ivar x
| Lfield(l, f) -> Ifield (ivar_of_pat l, f)
| _ -> assert false
@ -57,7 +57,7 @@ let rec repr_from_ivar env iv =
(try
let lhs = Env.find x env in lhs.pat_desc
with
Not_found -> Lvar x)
Not_found -> Obc.Lvar x)
| Ifield(iv, f) ->
let ty = Tid (Modules.find_field f) in
let lhs = mk_pattern ty (repr_from_ivar env iv) in
@ -82,9 +82,9 @@ let choose_representative m inputs outputs mems ty vars =
let desc = match inputs, outputs, mems with
| [], [], [] -> choose_record_field m vars
| [], [], (Ivar m)::_ -> Lmem m
| [Ivar vin], [], [] -> Lvar vin
| [], [Ivar vout], [] -> Lvar vout
| [Ivar vin], [Ivar _], [] -> Lvar vin
| [Ivar vin], [], [] -> Obc.Lvar vin
| [], [Ivar vout], [] -> Obc.Lvar vout
| [Ivar vin], [Ivar _], [] -> Obc.Lvar vin
| _, _, _ ->
Interference.print_debug "@.Something is wrong with the coloring : %a@." print_ivar_list vars;
Interference.print_debug "\tInputs : %a@." print_ivar_list inputs;
@ -115,7 +115,7 @@ let memalloc_subst_map inputs outputs mems subst_lists =
let rec lhs funs (env, mut, j) l = match l.pat_desc with
| Lmem _ -> l, (env, mut, j)
| Larray _ | Lfield _ -> Obc_mapfold.lhs funs (env, mut, j) l
| Lvar _ ->
| Obc.Lvar _ ->
(* replace with representative *)
let iv = ivar_of_pat l in
let lhs_desc = repr_from_ivar env iv in
@ -135,7 +135,8 @@ let extvalue funs (env, mut, j) w = match w.w_desc with
| Warray _ | Wfield _ -> Obc_mapfold.extvalue funs (env, mut, j) w
| Wvar x ->
(* replace with representative *)
let lhs, _ = lhs funs (env, mut, j) (mk_pattern Types.invalid_type (Lvar x)) in
let lhs, _ = lhs funs (env, mut, j)
(mk_pattern Types.invalid_type (Obc.Lvar x)) in
let neww = ext_value_of_pattern lhs in
{ w with w_desc = neww.w_desc }, (env, mut, j)

2
compiler/utilities/misc.ml
View file

@ -172,7 +172,7 @@ let repeat_list v n =
(** Same as List.mem_assoc but using the value instead of the key. *)
let rec memd_assoc value = function
| [] -> false
| (_,d)::l -> (d = value) or (memd_assoc value l)
| (_,d)::l -> (d = value) || (memd_assoc value l)
(** Same as List.assoc but searching for a data and returning the key. *)
let rec assocd value = function

2
compiler/utilities/sgraph.ml
View file

@ -47,7 +47,7 @@ let tag = ref 0
let new_tag () = incr tag; !tag
let containt g = g.g_containt
let linked g1 g2 =
(List.memq g2 g1.g_depends_on) or (List.memq g1 g2.g_depends_on)
(List.memq g2 g1.g_depends_on) || (List.memq g1 g2.g_depends_on)
let make c =
{ g_containt = c; g_tag = new_tag (); g_visited = false;
g_mark = -1; g_depends_on = []; g_depends_by = [] }