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

Fixed warnings & documentation comments.

Browse source 
- gitignore: ignore files generated by `configure' script.
This commit is contained in:
Nicolas Berthier 2013-11-08 18:51:06 +01:00
parent 10bdab4dc6
commit 216550c0d1
77 changed files with 212 additions and 384 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored
View file

@ -29,3 +29,6 @@ lib/java/.classpath
/test/async/build/*
/test/image_filters/java/*
compiler/doc.odocl
compiler/doc.docdir
config
config.status

5
compiler/Makefile
View file

@ -49,8 +49,9 @@ clean:
$(OCAMLBUILD) -clean
.PHONY: doc
doc:
find _build -regex '.*.cmi?' -printf '%f\n' \
doc: $(TARGET)
# Filter unused modules by scanning built ones:
find _build -regex '.*.cmi?' -printf '%f\n' \
| sed -e '/ocamlbuild/ d; s/\(.*\)\.cmi$$/\u\1/' \
| sort > doc.odocl;
$(OCAMLBUILD) doc.docdir/index.html

1
compiler/README_ocamlbuild_hepts.txt
View file

@ -5,4 +5,3 @@ To do so, go to the lablgtk library directory and type:
ocamlc -a gtkThread.cmo -o lablgtkthread.cma
ocamlopt -a gtkThread.cmx -o lablgtkthread.cmxa

4
compiler/global/global_mapfold.ml
View file

@ -100,7 +100,7 @@ and ck funs acc c = match c with
| Cbase -> c, acc
| Cvar(link_ref) ->
let l, acc = link_it funs acc link_ref.contents in
Cvar {link_ref with contents = l}, acc
Cvar {contents = l}, acc
| Con(ck, constructor_name, v) ->
let ck, acc = ck_it funs acc ck in
let v, acc = var_ident_it funs acc v in
@ -114,7 +114,7 @@ and link funs acc l = match l with
and var_ident_it funs acc i = funs.var_ident funs acc i
and var_ident funs acc i = i, acc
and var_ident _funs acc i = i, acc
and structure_it funs acc s = funs.structure funs acc s
and structure funs acc s =

3
compiler/global/global_printer.ml
View file

@ -27,7 +27,6 @@
(* *)
(***********************************************************************)
open Names
open Idents
open Signature
open Types
open Clocks
@ -195,5 +194,3 @@ let print_interface ff =
NamesEnv.iter
(fun key sigtype -> Format.fprintf ff "%a@," print_interface_value (key,sigtype)) m.m_values;
Format.fprintf ff "@]@."

9
compiler/global/location.ml
View file

@ -30,7 +30,6 @@
(* inspired from the source of the Caml Light 0.73 compiler *)
open Lexing
open Parsing
open Format
(* two important global variables: [input_name] and [input_chan] *)
@ -54,7 +53,7 @@ let error_prompt = ">"
(** Prints [n] times char [c] on [oc]. *)
let prints_n_chars ff n c = for i = 1 to n do pp_print_char ff c done
let prints_n_chars ff n c = for _i = 1 to n do pp_print_char ff c done
(** Prints out to [oc] a line designed to be printed under [line] from file [ic]
underlining from char [first] to char [last] with char [ch].
@ -82,7 +81,7 @@ let underline_line ic ff ch line first last =
let copy_lines nl ic ff prompt =
for i = 1 to nl do
for _i = 1 to nl do
pp_print_string ff prompt;
(try pp_print_string ff (input_line ic)
with End_of_file -> pp_print_string ff "<EOF>");
@ -90,13 +89,13 @@ let copy_lines nl ic ff prompt =
done
let copy_chunk p1 p2 ic ff =
try for i = p1 to p2 - 1 do pp_print_char ff (input_char ic) done
try for _i = p1 to p2 - 1 do pp_print_char ff (input_char ic) done
with End_of_file -> pp_print_string ff "<EOF>"
let skip_lines n ic =
try for i = 1 to n do
try for _i = 1 to n do
let _ = input_line ic in ()
done
with End_of_file -> ()

27
compiler/global/modules.ml
View file

@ -30,7 +30,6 @@
(* Module objects and global environnement management *)
open Misc
open Compiler_options
open Signature
open Types
@ -161,7 +160,7 @@ let initialize modul =
List.iter open_module !default_used_modules
(** { 3 Add functions prevent redefinitions } *)
(** {3 Add functions prevent redefinitions} *)
let _check_not_defined env f =
if QualEnv.mem f env then raise Already_defined
@ -190,7 +189,7 @@ let replace_type f v =
let replace_const f v =
g_env.consts <- QualEnv.add f v g_env.consts
(** { 3 Find functions look in the global environement, nothing more } *)
(** {3 Find functions look in the global environement, nothing more} *)
let find_value x = QualEnv.find x g_env.values
let find_type x = QualEnv.find x g_env.types
@ -204,7 +203,7 @@ let find_struct n =
| Tstruct fields -> fields
| _ -> raise Not_found
(** { 3 Check functions }
(** {3 Check functions}
Try to load the needed module and then to find it,
return true if in the table, return false if it can't find it. *)
@ -226,9 +225,12 @@ let check_const q =
try let _ = QualEnv.find q g_env.consts in true with Not_found -> false
(** { 3 Qualify functions [qualify_* name] return the qualified name
matching [name] in the global env scope (current module :: opened modules).
@raise [Not_found] if not in scope } *)
(** {3 Qualify functions}
[qualify_* name] return the qualified name matching [name] in the global env
scope (current module :: opened modules).
@raise Not_found if not in scope *)
let _qualify env name =
let tries m =
@ -247,11 +249,11 @@ let qualify_const name = _qualify g_env.consts name
(** @return the name as qualified with the current module
(should not be used..)*)
(should not be used..)*)
let current_qual n = { qual = g_env.current_mod; name = n }
(** { 3 Fresh functions return a fresh qualname for the current module } *)
(** {3 Fresh functions return a fresh qualname for the current module} *)
let rec fresh_value pass_name name =
let fname =
@ -306,7 +308,9 @@ let rec fresh_constr pass_name name =
exception Undefined_type of qualname
(** @return the unaliased version of a type. @raise Undefined_type *)
(** @return the unaliased version of a type.
@raise Undefined_type . *)
let rec unalias_type t = match t with
| Tid ({ qual = q } as ty_name) ->
_load_module q;
@ -320,7 +324,7 @@ let rec unalias_type t = match t with
| Tinvalid -> Tinvalid
(** Return the current module as a [module_object] *)
(** Return the current module as a {!module_object} *)
let current_module () =
(* Filter and transform a qualified env into the current module object env *)
let unqualify env = (* unqualify and filter env keys *)
@ -342,4 +346,3 @@ let current_module () =
m_constrs = unqualify_all g_env.constrs;
m_fields = unqualify_all g_env.fields;
m_format_version = g_env.format_version }

5
compiler/global/signature.ml
View file

@ -77,7 +77,7 @@ type type_def =
type const_def = { c_type : ty; c_value : static_exp }
(** { 3 Signature helper functions } *)
(** {3 Signature helper functions} *)
let rec ck_to_sck ck =
let ck = Clocks.ck_repr ck in
@ -120,6 +120,3 @@ let rec field_assoc f = function
| { f_name = n; f_type = ty }::l ->
if f = n then ty
else field_assoc f l

10
compiler/global/static.ml
View file

@ -28,9 +28,8 @@
(***********************************************************************)
(** This module defines static expressions, used in params and for constants.
const n: int = 3;
var x : int^n; var y : int^(n + 2);
x[n - 1], x[1 + 3],... *)
[const n: int = 3;
var x : int^n; var y : int^(n + 2); x[n - 1], x[1 + 3],...] *)
open Names
open Format
@ -193,14 +192,14 @@ let rec simplify_type env ty = match ty with
(** [eval env e] does the same as [simplify]
but if it returns, there are no variables nor op left.
@raise [Errors.Error] when it cannot fully evaluate. *)
@raise Errors.Error when it cannot fully evaluate. *)
let eval env se =
try eval_core false env se
with exn -> message exn
(** [int_of_static_exp env e] returns the value of the expression
[e] in the environment [env], mapping vars to integers.
@raise [Errors.Error] if it cannot be computed.*)
@raise Errors.Error if it cannot be computed.*)
let int_of_static_exp env se = match (eval env se).se_desc with
| Sint i -> i
| _ -> Misc.internal_error "static int_of_static_exp"
@ -258,4 +257,3 @@ let instanciate_constr m constr =
| Cfalse -> Cfalse in
List.map (replace_one m) constr
*)

9
compiler/global/types.ml
View file

@ -28,7 +28,6 @@
(***********************************************************************)
open Names
open Misc
open Location
@ -43,9 +42,9 @@ and static_exp_desc =
| Sconstructor of constructor_name
| Sfield of field_name
| Stuple of static_exp list
| Sarray_power of static_exp * (static_exp list) (** power : 0^n^m : [[0,0,..],[0,0,..],..] *)
| Sarray of static_exp list (** [ e1, e2, e3 ] *)
| Srecord of (field_name * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sarray_power of static_exp * (static_exp list) (** power : [0^n^m : [[0,0,..],[0,0,..],..]] *)
| Sarray of static_exp list (** [[ e1, e2, e3 ]] *)
| Srecord of (field_name * static_exp) list (** [{ f1 = e1; f2 = e2; ... }] *)
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
and ty =
@ -66,5 +65,3 @@ let unprod = function
let mk_static_exp ?(loc = no_location) ty desc = (*note ~ty: replace as first arg*)
{ se_desc = desc; se_ty = ty; se_loc = loc }

7
compiler/heptagon/analysis/causal.ml
View file

@ -29,10 +29,7 @@
(* causality check of scheduling constraints *)
open Misc
open Names
open Idents
open Heptagon
open Location
open Sgraph
open Format
@ -148,7 +145,7 @@ let rec ctuple l =
norm_tuple l before (ac::newl)
| ((Aac _) as ac)::l ->
norm_tuple l (cand before ac) newl
| (Aor _)::l -> assert false
| (Aor _)::_ -> assert false
in
norm_tuple l Aempty []
@ -217,7 +214,7 @@ let build ac =
with
| Not_found -> () in
let rec add_dependence g = function
let add_dependence g = function
| Aread(n) -> attach g n; attach_lin g n
| Alinread(n) -> attach g n
| _ -> ()

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

@ -30,11 +30,8 @@
(* causality check *)
open Misc
open Names
open Idents
open Heptagon
open Location
open Sgraph
open Linearity
open Causal
@ -227,7 +224,7 @@ and typing_automaton state_handlers =
cseq t2 (cseq tb t1) in
corlist (List.map handler state_handlers)
and typing_block { b_local = dec; b_equs = eq_list; b_loc = loc } =
and typing_block { b_local = _dec; b_equs = eq_list; b_loc = _loc } =
(*let teq = typing_eqs eq_list in
Causal.check loc teq;
clear (build dec) teq *)
@ -236,7 +233,7 @@ and typing_block { b_local = dec; b_equs = eq_list; b_loc = loc } =
let typing_contract loc contract =
match contract with
| None -> cempty
| Some { c_block = b;
| Some { c_block = b;
c_assume = e_a;
c_assume_loc = e_a_loc;
c_enforce = e_g;
@ -264,4 +261,3 @@ let typing_node { n_contract = contract;
let program ({ p_desc = pd } as p) =
List.iter (function Pnode n -> typing_node n | _ -> ()) pd;
p

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

@ -37,15 +37,12 @@
*)
open Misc
open Names
open Idents
open Heptagon
open Hept_utils
open Global_printer
open Hept_printer
open Signature
open Types
open Clocks
open Location
open Format
@ -113,7 +110,7 @@ let rec typing h pat e =
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
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)
| Emerge (x, c_e_list) ->
let ck = ck_of_name h x in
@ -134,7 +131,7 @@ let rec typing h pat e =
typing_app h base_ck pat op (pargs@args)
| Imapi -> (* clocking the node with the extra i input on [ck_r] *)
let il (* stubs i as 0 *) =
List.map (fun x -> mk_exp
List.map (fun _ -> mk_exp
(Econst (Initial.mk_static_int 0))
~ct_annot:(Some(Ck(base_ck)))
Initial.tint
@ -145,12 +142,12 @@ let rec typing h pat e =
| Ifold | Imapfold ->
(* clocking node with equality constaint on last input and last output *)
let ct = typing_app h base_ck pat op (pargs@args) in
Misc.optional (unify (Ck(Clocks.last_clock ct)))
(Misc.last_element args).e_ct_annot;
ignore (Misc.optional (unify (Ck(Clocks.last_clock ct)))
(Misc.last_element args).e_ct_annot);
ct
| Ifoldi -> (* clocking the node with the extra i and last in/out constraints *)
let il (* stubs i as 0 *) =
List.map (fun x -> mk_exp
List.map (fun _ -> mk_exp
(Econst (Initial.mk_static_int 0))
~ct_annot:(Some(Ck(base_ck)))
Initial.tint
@ -163,8 +160,8 @@ let rec typing h pat e =
| h::l -> h::(insert_i l)
in
let ct = typing_app h base_ck pat op (pargs@(insert_i args)) in
Misc.optional (unify (Ck (Clocks.last_clock ct)))
(Misc.last_element args).e_ct_annot;
ignore (Misc.optional (unify (Ck (Clocks.last_clock ct)))
(Misc.last_element args).e_ct_annot);
ct
in
ct, base_ck
@ -183,7 +180,7 @@ let rec typing h pat e =
ct, base
and expect h pat expected_ct e =
let actual_ct,base = typing h pat e in
let actual_ct,_base = typing h pat e in
(try unify actual_ct expected_ct
with Unify -> error_message e.e_loc (Etypeclash (actual_ct, expected_ct)))
@ -237,7 +234,7 @@ and typing_app h base pat op e_list = match op with
let append_env h vds =
List.fold_left (fun h { v_ident = n; v_clock = ck } -> Env.add n ck h) h vds
let rec typing_eq h ({ eq_desc = desc; eq_loc = loc } as eq) =
let rec typing_eq h ({ eq_desc = desc; eq_loc = loc } as _eq) =
match desc with
| Eeq(pat,e) ->
let ct,_ = typing h pat e in
@ -253,7 +250,7 @@ let rec typing_eq h ({ eq_desc = desc; eq_loc = loc } as eq) =
and typing_eqs h eq_list = List.iter (typing_eq h) eq_list
and typing_block h
({ b_local = l; b_equs = eq_list; b_loc = loc } as b) =
({ b_local = l; b_equs = eq_list } as _b) =
let h' = append_env h l in
typing_eqs h' eq_list;
h'
@ -270,7 +267,7 @@ let typing_contract h contract =
expect h' (Etuplepat []) (Ck Cbase) e_a;
(* property *)
expect h' (Etuplepat []) (Ck Cbase) e_g;
append_env h c_list
let typing_local_contract h contract =
@ -318,4 +315,3 @@ let program p =
| _ -> pd
in
{ p with p_desc = List.map program_desc p.p_desc; }

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

@ -39,12 +39,10 @@
(* Requis : typage *)
open Misc
open Names
open Idents
open Heptagon
open Types
open Location
open Format
type typ =
| Iproduct of typ list
@ -349,7 +347,7 @@ and typing_automaton h state_handlers =
let initialized h { s_block = { b_defnames = l } } =
let env_update x h =
try
let xl = IEnv.find_last x h in (* it's a last in the env, good. *)
let _xl = IEnv.find_last x h in (* it's a last in the env, good. *)
IEnv.add_last x (IEnv.find_var x h) h
with Not_found -> h (* nothing to do *)
in
@ -412,5 +410,3 @@ let typing_node { n_input = i_list; n_output = o_list;
let program ({ p_desc = pd } as p) =
List.iter (function Pnode n -> typing_node n | _ -> ()) pd;
p

10
compiler/heptagon/analysis/linear_typing.ml
View file

@ -32,7 +32,6 @@ open Names
open Location
open Misc
open Signature
open Modules
open Heptagon
type error =
@ -203,7 +202,7 @@ let check_fresh_lin_var (env, used_vars, init_vars) loc lin =
(** Substitutes linearity variables (Lvar r) with their value
given by the map. *)
let rec subst_lin m lin_list =
let subst_lin m lin_list =
let subst_one = function
| Lvar r ->
(try
@ -253,7 +252,7 @@ let subst_from_lin (s,m) expect_lin lin =
)
| _, _ -> s,m
let rec not_linear_for_exp e =
let not_linear_for_exp e =
lin_skeleton Ltop e.e_ty
let check_init env loc init lin =
@ -399,7 +398,7 @@ let rec fuse_args_lin args_lin collect_lins =
(** [extract_not_lin_var_exp args_lin e_list] returns the linearities
and expressions from e_list that are not yet set to Lvar r.*)
let rec extract_not_lin_var_exp args_lin e_list =
let extract_not_lin_var_exp args_lin e_list =
match args_lin, e_list with
| [], [] -> [], []
| arg_lin::args_lin, e::e_list ->
@ -791,7 +790,7 @@ and typing_eq env eq =
| Eeq(Evarpat y, { e_desc = Efby(e_1, e_2) }) ->
let lin = lin_of_ident y env in
let _, env = check_init env eq.eq_loc eq.eq_inits lin in
safe_expect env Ltop e_1;
ignore (safe_expect env Ltop e_1);
safe_expect env lin e_2
| Eeq(pat, e) ->
let lin_pat = typing_pat env pat in
@ -917,4 +916,3 @@ let node f =
let program ({ p_desc = pd } as p) =
List.iter (function Pnode n -> node n | _ -> ()) pd;
p

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

@ -27,7 +27,6 @@
(* *)
(***********************************************************************)
(* Checks that a node declared stateless is stateless, and set possible nodes as stateless. *)
open Names
open Location
open Signature
open Modules

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

@ -39,7 +39,6 @@ open Static
open Types
open Global_printer
open Heptagon
open Hept_mapfold
open Pp_tools
open Format
@ -440,7 +439,7 @@ let rec _unify cenv t1 t2 =
_unify cenv ty1 ty2
| _ -> raise Unify
(** { 3 Constraints related functions } *)
(** {3 Constraints related functions} *)
and (curr_constrnt : constrnt list ref) = ref []
and solve ?(unsafe=false) c_l =
@ -1193,7 +1192,7 @@ let typing_contract cenv h contract =
let typed_e_g = expect cenv h' (Tid Initial.pbool) e_g in
let typed_e_g_loc = expect cenv h' (Tid Initial.pbool) e_g_loc in
let typed_c, (c_names, h) = build cenv h c in
let typed_c, (_c_names, h) = build cenv h c in
Some { c_block = typed_b;
c_assume = typed_e_a;
@ -1222,7 +1221,7 @@ let node ({ n_name = f; n_input = i_list; n_output = o_list;
try
let typed_params, cenv =
build_node_params QualEnv.empty node_params in
let typed_i_list, (input_names, h) = build cenv Env.empty i_list in
let typed_i_list, (_input_names, h) = build cenv Env.empty i_list in
let typed_o_list, (output_names, h) = build cenv h o_list in
(* typing contract *)

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

@ -27,7 +27,6 @@
(* *)
(***********************************************************************)
(* Checks that a node not declared unsafe is safe, and set app unsafe flag. *)
open Names
open Location
open Signature
open Modules

9
compiler/heptagon/hept_mapfold.ml
View file

@ -216,7 +216,7 @@ and block_it funs acc b = funs.block funs acc b
and block funs acc b =
let b_local, acc = mapfold (var_dec_it funs) acc b.b_local in
let b_equs, acc = mapfold (eq_it funs) acc b.b_equs in
let b_defnames, acc =
let b_defnames, acc =
Idents.Env.fold
(fun v v_dec (env,acc) ->
let v, acc = var_ident_it funs.global_funs acc v in
@ -332,7 +332,7 @@ and program_desc_it funs acc pd =
with Fallback -> program_desc funs acc pd
and program_desc funs acc pd = match pd with
| Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc
| Ptype td -> pd, acc (* TODO types *)
| Ptype _td -> pd, acc (* TODO types *)
| Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc
let defaults = {
@ -380,8 +380,3 @@ let defaults_stop = {
program = stop;
program_desc = stop;
global_funs = Global_mapfold.defaults_stop }

8
compiler/heptagon/hept_printer.ml
View file

@ -28,18 +28,12 @@
(***********************************************************************)
(* The Heptagon printer *)
open Location
open Misc
open Names
open Idents
open Modules
open Static
open Format
open Global_printer
open Pp_tools
open Types
open Linearity
open Signature
open Heptagon
let iterator_to_string i =
@ -334,7 +328,7 @@ and print_sblock sep ff { b_local = v_list; b_equs = eqs } =
fprintf ff "@[<v>%a@,%a@]" (print_local_vars sep) v_list print_eq_list eqs
let rec print_type_def ff { t_name = name; t_desc = tdesc } =
let print_type_def ff { t_name = name; t_desc = tdesc } =
let print_type_desc ff = function
| Type_abs -> ()
| Type_alias ty -> fprintf ff " =@ %a" print_type ty

4
compiler/heptagon/hept_utils.ml
View file

@ -28,10 +28,7 @@
(***********************************************************************)
(* the internal representation *)
open Location
open Misc
open Names
open Idents
open Static
open Signature
open Types
open Linearity
@ -139,4 +136,3 @@ let signature_of_node n =
node_param_constraints = n.n_param_constraints;
node_external = false;
node_loc = n.n_loc }

4
compiler/heptagon/heptagon.ml
View file

@ -28,15 +28,12 @@
(***********************************************************************)
(* the internal representation *)
open Location
open Misc
open Names
open Idents
open Static
open Signature
open Types
open Linearity
open Clocks
open Initial
type state_name = name
@ -217,4 +214,3 @@ and interface_desc =
| Itypedef of type_dec
| Iconstdef of const_dec
| Isignature of signature

2
compiler/heptagon/main/hept_compiler.ml
View file

@ -29,8 +29,6 @@
open Compiler_options
open Compiler_utils
open Location
open Global_printer
let pp p = if !verbose then Hept_printer.print stdout p

2
compiler/heptagon/main/hept_parser_scoper.ml
View file

@ -30,7 +30,6 @@
open Compiler_options
open Compiler_utils
open Location
open Global_printer
let pp p = if !verbose then Hept_printer.print stdout p
@ -72,4 +71,3 @@ let parse_interface modname lexbuf =
(* Convert the parse tree to Heptagon AST *)
let i = do_silent_pass "Scoping" Hept_scoping.translate_interface i in
i

2
compiler/heptagon/parsing/hept_parser.mly
View file

@ -28,10 +28,8 @@
(* *)
(***********************************************************************)
open Signature
open Location
open Names
open Types
open Linearity
open Hept_parsetree

7
compiler/heptagon/parsing/hept_parsetree.ml
View file

@ -29,7 +29,6 @@
open Location
open Signature
(** var_names will be converted to idents *)
type var_name = Names.name
@ -64,9 +63,9 @@ and static_exp_desc =
| Sconstructor of constructor_name
| Sfield of field_name
| Stuple of static_exp list
| Sarray_power of static_exp * (static_exp list) (** power : 0^n : [0,0,0,0,0,..] *)
| Sarray of static_exp list (** [ e1, e2, e3 ] *)
| Srecord of (field_name * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sarray_power of static_exp * (static_exp list) (** power : 0^n : [[0,0,0,0,0,..]] *)
| Sarray of static_exp list (** [[ e1, e2, e3 ]] *)
| Srecord of (field_name * static_exp) list (** [{ f1 = e1; f2 = e2; ... }] *)
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
type iterator_type =

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

@ -54,7 +54,6 @@
op<a1,a2> (a3) ==> op <a1> (a2,a3) ==> op (a1,a2,a3) *)
open Location
open Types
open Hept_parsetree
open Names
open Idents
@ -221,7 +220,7 @@ let build_const loc vd_list =
List.fold_left build NamesSet.empty vd_list
(** { 3 Translate the AST into Heptagon. } *)
(** {3 Translate the AST into Heptagon} *)
let translate_iterator_type = function
| Imap -> Heptagon.Imap
| Imapi -> Heptagon.Imapi
@ -236,7 +235,7 @@ let rec translate_static_exp se =
with
| ScopingError err -> message se.se_loc err
and translate_static_exp_desc loc ed =
and translate_static_exp_desc _loc ed =
let t = translate_static_exp in
match ed with
| Svar (Q q) -> Types.Svar q
@ -579,7 +578,7 @@ let translate_signature s =
let p, _ = params_of_var_decs Rename.empty s.sig_params in
let c = List.map translate_constrnt s.sig_param_constraints in
let sig_node =
Signature.mk_node
Signature.mk_node
~extern:s.sig_external s.sig_loc i o s.sig_stateful s.sig_unsafe p in
Check_signature.check_signature sig_node;
safe_add s.sig_loc add_value n sig_node;

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

@ -30,7 +30,6 @@
(* TODO deal correctly with [stateful] and [unsafe] *)
open Misc
open Types
open Names
open Idents
@ -38,7 +37,6 @@ open Heptagon
open Hept_utils
open Hept_mapfold
open Initial
open Modules
type var = S | NS | R | NR | PNR
let fresh = Idents.gen_fresh "automata"
@ -130,9 +128,9 @@ let translate_automaton v eq_list handlers =
in
let strong { s_state = n; s_unless = su } =
let rst_vd = mk_var_dec resetname (Tid Initial.pbool) Linearity.Ltop in
let rst_vd = mk_var_dec resetname (Tid Initial.pbool) ~linearity:Linearity.Ltop in
let defnames = Env.add resetname rst_vd Env.empty in
let state_vd = mk_var_dec statename tstatetype Linearity.Ltop in
let state_vd = mk_var_dec statename tstatetype ~linearity:Linearity.Ltop in
let defnames = Env.add statename state_vd defnames in
let st_eq = mk_simple_equation
(Etuplepat[Evarpat(statename); Evarpat(resetname)])
@ -142,9 +140,9 @@ let translate_automaton v eq_list handlers =
in
let weak { s_state = n; s_block = b; s_until = su } =
let nextrst_vd = mk_var_dec next_resetname (Tid Initial.pbool) Linearity.Ltop in
let nextrst_vd = mk_var_dec next_resetname (Tid Initial.pbool) ~linearity:Linearity.Ltop in
let defnames = Env.add next_resetname nextrst_vd b.b_defnames in
let nextstate_vd = mk_var_dec next_statename tstatetype Linearity.Ltop in
let nextstate_vd = mk_var_dec next_statename tstatetype ~linearity:Linearity.Ltop in
let defnames = Env.add next_statename nextstate_vd defnames in
let ns_eq = mk_simple_equation
(Etuplepat[Evarpat(next_statename); Evarpat(next_resetname)])
@ -195,7 +193,7 @@ let translate_automaton v eq_list handlers =
(mk_exp_fby_false (boolvar (next_resetname))) in
v, ns_switch_eq :: switch_eq :: pnr_eq :: eq_list
let rec eq funs (v, eq_list) eq =
let eq funs (v, eq_list) eq =
let eq, (v, eq_list) = Hept_mapfold.eq funs (v, eq_list) eq in
match eq.eq_desc with
| Eautomaton state_handlers ->

7
compiler/heptagon/transformations/completion.ml
View file

@ -28,9 +28,7 @@
(***********************************************************************)
(* complete partial definitions with [x = last(x)] *)
open Misc
open Heptagon
open Global_mapfold
open Hept_utils
open Hept_mapfold
open Idents
@ -67,7 +65,7 @@ let funs_collect =
(* adds an equation [x = last(x)] for every partially defined variable *)
(* in a control structure *)
let complete_with_last defined_names local_defined_names eq_list =
let last n vd = mk_exp (Elast n) vd.v_type Linearity.Ltop in
let last n vd = mk_exp (Elast n) vd.v_type ~linearity:Linearity.Ltop in
let equation n vd eq_list =
(mk_equation (Eeq(Evarpat n, last n vd)))::eq_list in
let d = Env.diff defined_names local_defined_names in
@ -86,11 +84,10 @@ let eqdesc funs _ ed = match ed with
let ed, defnames =
Hept_mapfold.eqdesc funs_collect Env.empty ed in
(* add missing defnames *)
let ed, defnames = Hept_mapfold.eqdesc funs defnames ed in
let ed, _defnames = Hept_mapfold.eqdesc funs defnames ed in
ed, Env.empty
| _ -> raise Errors.Fallback
let funs = { Hept_mapfold.defaults with eqdesc = eqdesc; block = block; }
let program p = let p, _ = program_it funs Env.empty p in p

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

@ -93,7 +93,7 @@ let mk_unique_node nd =
let subst_contract funs subst c =
let c_block, subst' = subst_contract_block funs subst c.c_block in
let c_assume, subst' = exp_it funs subst' c.c_assume in
let c_enforce, subst' = exp_it funs subst' c.c_enforce in
let c_enforce, _subst' = exp_it funs subst' c.c_enforce in
let subst =
List.fold_left
(fun subst vd ->
@ -323,4 +323,3 @@ let program p =
assert (newequs = []);
assert (contracts = []);
p

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

@ -95,7 +95,7 @@ let tuple_of_vd_list l =
mk_exp (Eapp (mk_app Etuple, el, None)) ty ~linearity:lin
let vd_of_arg ad =
mk_var_dec (fresh_vd_of_arg ad) ad.a_type ad.a_linearity
mk_var_dec (fresh_vd_of_arg ad) ad.a_type ~linearity:ad.a_linearity
(** @return the lists of inputs and outputs (as var_dec) of
an app object. *)
@ -150,7 +150,7 @@ let edesc funs acc ed =
let new_inp, e, acc_eq_list = mk_call g acc_eq_list in
new_inp @ inp, acc_eq_list, e::largs, local_args @ args, true
| _ ->
let vd = mk_var_dec (fresh_var ()) e.e_ty e.e_linearity in
let vd = mk_var_dec (fresh_var ()) e.e_ty ~linearity:e.e_linearity in
vd::inp, acc_eq_list, (exp_of_vd vd)::largs, e::args, b
in
@ -162,7 +162,7 @@ let edesc funs acc ed =
let _, outp = get_node_inp_outp f in
let f_out_type = type_of_vd_list outp in
let f_out_lin = linearity_of_vd_list outp in
let call = mk_exp (Eapp(f, largs, None)) f_out_type f_out_lin in
let call = mk_exp (Eapp(f, largs, None)) f_out_type ~linearity:f_out_lin in
let eq = mk_equation (Eeq(pat_of_vd_list outp, call)) in
(* create the lambda *)
let anon = mk_app

5
compiler/heptagon/transformations/last.ml
View file

@ -46,10 +46,11 @@ let last (eq_list, env, v) { v_ident = n; v_type = t; v_linearity = lin; v_last
let eq =
mk_equation (Eeq (Evarpat lastn,
mk_exp (Epre (default,
mk_exp (Evar n) t Linearity.Ltop)) t lin)) in
mk_exp (Evar n) t ~linearity:Linearity.Ltop))
t ~linearity:lin)) in
eq:: eq_list,
Env.add n lastn env,
(mk_var_dec lastn t lin) :: v
(mk_var_dec lastn t ~linearity:lin) :: v
let extend_env env v = List.fold_left last ([], env, []) v

13
compiler/heptagon/transformations/normalize.ml
View file

@ -27,14 +27,11 @@
(* *)
(***********************************************************************)
open Misc
open Names
open Idents
open Location
open Heptagon
open Hept_utils
open Hept_mapfold
open Types
open Clocks
open Linearity
open Format
@ -86,7 +83,7 @@ let flatten_e_list l =
let equation (d_list, eq_list) e =
let add_one_var ty lin d_list =
let n = Idents.gen_var "normalize" "v" in
let d_list = (mk_var_dec n ty lin) :: d_list in
let d_list = (mk_var_dec n ty ~linearity:lin) :: d_list in
n, d_list
in
match e.e_ty with
@ -102,7 +99,7 @@ let equation (d_list, eq_list) e =
let pat_list = List.map (fun n -> Evarpat n) var_list in
let eq_list = (mk_equation (Eeq (Etuplepat pat_list, e))) :: eq_list in
let e_list = Misc.map3
(fun n ty lin -> mk_exp (Evar n) ty lin) var_list ty_list lin_list in
(fun n ty lin -> mk_exp (Evar n) ty ~linearity:lin) var_list ty_list lin_list in
let e = Eapp(mk_app Etuple, e_list, None) in
(d_list, eq_list), e
| _ ->
@ -111,7 +108,7 @@ let equation (d_list, eq_list) e =
(d_list, eq_list), Evar n
(* [(e1,...,ek) when C(n) = (e1 when C(n),...,ek when C(n))] *)
let rec whenc context e c n e_orig =
let whenc context e c n e_orig =
let when_on_c c n context e =
(* If memalloc is activated, there cannot be a stateful exp inside a when. Indeed,
the expression inside the when will be called on a fast rhythm and write its result
@ -268,7 +265,7 @@ and merge context e x c_e_list =
let context, e = translate ExtValue context e in
(tag, e), context
in
let rec mk_merge x c_list e_lists =
let mk_merge x c_list e_lists =
let ty = (List.hd (List.hd e_lists)).e_ty in
let lin = (List.hd (List.hd e_lists)).e_linearity in
let rec build_c_e_list c_list e_lists =
@ -347,7 +344,7 @@ and translate_eq_list d_list eq_list =
(fun context eq -> translate_eq context eq)
(d_list, []) eq_list
let eq funs context eq =
let eq _funs context eq =
let context = translate_eq context eq in
eq, context

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

@ -31,7 +31,6 @@
(* REQUIRES automaton stateful present *)
open Misc
open Idents
open Heptagon
open Hept_utils
open Types
@ -117,7 +116,7 @@ let block funs (res,_) b =
(* Transform reset blocks in blocks with reseted exps,
create a var to store the reset condition evaluation if not already a var. *)
let eqdesc funs (res,stateful) = function
| Ereset(b, ({ e_desc = Evar x } as e)) ->
| Ereset(b, ({ e_desc = Evar _ } as e)) ->
let r = if stateful then merge_resets res (Some e) else res in
let b, _ = Hept_mapfold.block_it funs (r,stateful) b in
Eblock(b), (res,stateful)

11
compiler/heptagon/transformations/switch.ml
View file

@ -59,7 +59,6 @@ with one defined var y ( defnames = {y} ) and used var x
open Misc
open Heptagon
open Hept_utils
open Hept_mapfold
@ -81,7 +80,6 @@ module Env = struct
open Idents
open Names
open Clocks
type t = Base | Level of ck * IdentSet.t * t
@ -152,7 +150,7 @@ let level_up defnames constr h =
let add_to_locals vd_env locals h =
let add_one n nn (locals,vd_env) =
let orig_vd = Idents.Env.find n vd_env in
let vd_nn = mk_var_dec nn orig_vd.v_type orig_vd.v_linearity in
let vd_nn = mk_var_dec nn orig_vd.v_type ~linearity:orig_vd.v_linearity in
vd_nn::locals, Idents.Env.add vd_nn.v_ident vd_nn vd_env
in
fold add_one h (locals, vd_env)
@ -197,7 +195,7 @@ let eqdesc funs (vd_env,env,h) eqd = match eqd with
(* create a clock var corresponding to the switch condition [e] *)
let ck = fresh_clock_id () in
let e, (vd_env,env,h) = exp_it funs (vd_env,env,h) e in
let locals = [mk_var_dec ck e.e_ty e.e_linearity] in
let locals = [mk_var_dec ck e.e_ty ~linearity:e.e_linearity] in
let equs = [mk_equation (Eeq (Evarpat ck, e))] in
(* typing have proved that defined variables are the same among states *)
@ -246,8 +244,3 @@ let program p =
exp = exp; eq = eq; eqdesc = eqdesc } in
let p, _ = program_it funs (Idents.Env.empty,Env.Base,Rename.empty) p in
p

7
compiler/main/hept2mls.ml
View file

@ -33,14 +33,11 @@ open Location
open Misc
open Names
open Idents
open Static
open Types
open Clocks
open Format
open Minils
open Mls_utils
open Signature
module Error =
struct
@ -84,7 +81,7 @@ let translate_iterator_type = function
| Heptagon.Ifoldi -> Ifoldi
| Heptagon.Imapfold -> Imapfold
let rec translate_op = function
let translate_op = function
| Heptagon.Eifthenelse -> Eifthenelse
| Heptagon.Efun f -> Efun f
| Heptagon.Enode f -> Enode f
@ -180,7 +177,7 @@ let rec translate_pat = function
| Heptagon.Evarpat(n) -> Evarpat n
| Heptagon.Etuplepat(l) -> Etuplepat (List.map translate_pat l)
let rec translate_eq { Heptagon.eq_desc = desc; Heptagon.eq_loc = loc } =
let translate_eq { Heptagon.eq_desc = desc; Heptagon.eq_loc = loc } =
match desc with
| Heptagon.Eeq(p, e) ->
begin match e.Heptagon.e_desc with

21
compiler/main/mls2obc.ml
View file

@ -37,7 +37,6 @@ open Obc_utils
open Obc_mapfold
open Types
open Clocks
open Static
open Initial
@ -83,7 +82,7 @@ let fresh_for = fresh_for "mls2obc"
let op_from_string op = { qual = Pervasives; name = op; }
let rec pattern_of_idx_list p l =
let pattern_of_idx_list p l =
let rec aux p l = match Modules.unalias_type p.pat_ty, l with
| _, [] -> p
| Tarray (ty',_), idx :: l -> aux (mk_pattern ty' (Larray (p, idx))) l
@ -103,7 +102,7 @@ let rec extvalue_of_idx_list w l = match Modules.unalias_type w.w_ty, l with
extvalue_of_idx_list (mk_ext_value ty' (Warray (w, idx))) l
| _ -> internal_error "mls2obc extvalue_of_idx_list"
let rec ext_value_of_trunc_idx_list p l =
let ext_value_of_trunc_idx_list p l =
let mk_between idx se =
mk_exp_int (Eop (mk_pervasives "between", [idx; mk_ext_value_exp se.se_ty (Wconst se)]))
in
@ -116,7 +115,7 @@ let rec ext_value_of_trunc_idx_list p l =
let rec ty_of_idx_list ty idx_list = match ty, idx_list with
| _, [] -> ty
| Tarray(ty, _), idx::idx_list -> ty_of_idx_list ty idx_list
| Tarray(ty, _), _idx::idx_list -> ty_of_idx_list ty idx_list
| _, _ -> internal_error "mls2obc ty_of_idx_list"
let mk_static_array_power ty c params = match params with
@ -133,7 +132,7 @@ let array_elt_of_exp idx e =
mk_ext_value_exp ty (Warray(ext_value_of_exp e, idx))
| _ -> internal_error "mls2obc array_elt_of_exp"
let rec array_elt_of_exp_list idx_list e =
let array_elt_of_exp_list idx_list e =
match e.e_desc, Modules.unalias_type e.e_ty with
| Eextvalue { w_desc = Wconst { se_desc = Sarray_power (c, params) } }, Tarray (ty,n) ->
let new_params, _ = Misc.split_at (List.length params - List.length idx_list) params in
@ -244,7 +243,7 @@ let rec translate_extvalue map w = match w.Minils.w_desc with
| _ ->
let desc = match w.Minils.w_desc with
| Minils.Wconst v -> Wconst v
| Minils.Wvar x -> assert false
| Minils.Wvar _ -> assert false
| Minils.Wfield (w1, f) -> Wfield (translate_extvalue map w1, f)
| Minils.Wwhen (w1, _, _) | Minils.Wreinit(_, w1) -> (translate_extvalue map w1).w_desc
in
@ -318,7 +317,7 @@ and translate_act map pat
let cpt1, cpt1d = fresh_it () in
let cpt2, cpt2d = fresh_it () in
let x = var_from_name map x in
let t = x.pat_ty in
let _t = x.pat_ty in
(match e1.Minils.w_ty, e2.Minils.w_ty with
| Tarray (t1, n1), Tarray (t2, n2) ->
let e1 = translate_extvalue_to_exp map e1 in
@ -391,7 +390,7 @@ and translate_act map pat
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_trunc }, e1::idx, _) ->
let x = var_from_name map x in
let bounds = Mls_utils.bounds_list e1.Minils.w_ty in
let _bounds = Mls_utils.bounds_list e1.Minils.w_ty in
let e1 = translate_extvalue map e1 in
let idx = List.map (translate_extvalue_to_exp map) idx in
let w = ext_value_of_trunc_idx_list e1 idx in
@ -459,7 +458,7 @@ let rec translate_eq map call_context
(v, si, j, s) =
let { Minils.e_desc = desc; Minils.e_loc = loc } = e in
match (pat, desc) with
| pat, Minils.Ewhen (e,_,_) ->
| _pat, Minils.Ewhen (e,_,_) ->
translate_eq map call_context {eq with Minils.eq_rhs = e} (v, si, j, s)
(* TODO Efby and Eifthenelse should be dealt with in translate_act, no ? *)
| Minils.Evarpat n, Minils.Efby (opt_c, e) ->
@ -485,7 +484,7 @@ let rec translate_eq map call_context
let action = mk_ifthenelse cond true_act false_act in
v, si, j, (control map ck action) :: s
| pat, Minils.Eapp({ Minils.a_op =
| _pat, Minils.Eapp({ Minils.a_op =
Minils.Efun ({ qual = Module "Iostream"; name = "printf" | "fprintf" } as q)},
args, _) ->
let action = Aop (q, List.map (translate_extvalue_to_exp map) args) in
@ -784,7 +783,7 @@ let program { Minils.p_modname = p_modname; Minils.p_opened = p_o; Minils.p_desc
| Minils.Pnode n when not (Itfusion.is_anon_node n.Minils.n_name) ->
Pclass (translate_node n) :: acc
(* dont't translate anonymous nodes, they will be inlined *)
| Minils.Pnode n -> acc
| Minils.Pnode _ -> acc
| Minils.Ptype t -> Ptype (translate_ty_def t) :: acc
| Minils.Pconst c -> Pconst (translate_const_def c) :: acc
in

3
compiler/main/mls2seq.ml
View file

@ -29,9 +29,6 @@
open Compiler_utils
open Compiler_options
open Obc
open Minils
open Misc
(** Definition of a target. A target starts either from
dataflow code (ie Minils) or sequential code (ie Obc),

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

@ -37,14 +37,12 @@
*)
open Misc
open Idents
open Names
open Minils
open Global_printer
open Mls_printer
open Signature
open Types
open Clocks
open Location
open Format
@ -179,7 +177,7 @@ let typing_eq h ({ eq_lhs = pat; eq_rhs = e; eq_loc = loc } as eq) =
Ck ck, ck
| 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 = 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
| Emerge (x, c_e_list) ->
@ -201,7 +199,7 @@ let typing_eq h ({ eq_lhs = pat; eq_rhs = e; eq_loc = loc } as eq) =
typing_app h base_ck pat op (pargs@args)
| Imapi -> (* clocking the node with the extra i input on [ck_r] *)
let il (* stubs i as 0 *) =
List.map (fun x -> mk_extvalue ~ty:Initial.tint ~linearity:Linearity.Ltop
List.map (fun _ -> mk_extvalue ~ty:Initial.tint ~linearity:Linearity.Ltop
~clock:base_ck (Wconst (Initial.mk_static_int 0))) nl
in
typing_app h base_ck pat op (pargs@args@il)
@ -212,7 +210,7 @@ let typing_eq h ({ eq_lhs = pat; eq_rhs = e; eq_loc = loc } as eq) =
ct
| Ifoldi -> (* clocking the node with the extra i and last in/out constraints *)
let il (* stubs i as 0 *) =
List.map (fun x -> mk_extvalue ~ty:Initial.tint ~linearity:Linearity.Ltop
List.map (fun _ -> mk_extvalue ~ty:Initial.tint ~linearity:Linearity.Ltop
~clock:base_ck (Wconst (Initial.mk_static_int 0))) nl
in
let rec insert_i args = match args with
@ -303,4 +301,3 @@ let program p =
| _ -> pd
in
{ p with p_desc = List.map program_desc p.p_desc; }

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

@ -34,7 +34,6 @@ open Minils
open Linearity
open Interference_graph
open Containers
open Printf
let print_interference_graphs = false
let verbose_mode = false
@ -421,7 +420,7 @@ let init_interference_graph () =
TyEnv.add_element ty (mk_node iv) env
in
(** Adds a node for the variable and all fields of a variable. *)
let rec add_ivar env iv ty =
let add_ivar env iv ty =
let ivars = all_ivars [] iv None ty in
List.fold_left add_tyenv env ivars
in
@ -440,7 +439,7 @@ let init_interference_graph () =
the list. If force is true, then interference is added
whatever the variables are, without checking if interference
is real. *)
let rec add_interferences_from_list force vars =
let add_interferences_from_list force vars =
let add_interference ivx ivy =
if force or should_interfere (ivx, ivy) then
add_interference_link_from_ivar ivx ivy
@ -629,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 Ltop (Wconst (Initial.mk_static_int 0))) in
(mk_extvalue_exp 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 Ltop (tuple_from_dec_and_mem_list f.n_output)) in
(mk_exp 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 *)

42
compiler/minils/minils.ml
View file

@ -33,7 +33,6 @@ open Location
open Names
open Idents
open Signature
open Static
open Types
open Linearity
open Clocks
@ -71,7 +70,7 @@ and extvalue_desc =
| Wconst of static_exp (*no tuple*)
| Wvar of var_ident
| Wfield of extvalue * field_name
| Wwhen of extvalue * constructor_name * var_ident (** extvalue when Constructor(ident) *)
| Wwhen of extvalue * constructor_name * var_ident (** {!extvalue} [when Constructor(ident)] *)
| Wreinit of extvalue * extvalue
and exp = {
@ -85,17 +84,17 @@ and exp = {
and edesc =
| Eextvalue of extvalue
| Efby of static_exp option * extvalue
(** static_exp fby extvalue *)
(** {!static_exp} [fby] {!extvalue} *)
| Eapp of app * extvalue list * var_ident option
(** app ~args=(extvalue,extvalue...) reset ~r=ident *)
| Ewhen of exp * constructor_name * var_ident (** e when C(c) *)
(** [app ~args=(]{!extvalue}[,extvalue...) reset ~r=ident] *)
| Ewhen of exp * constructor_name * var_ident (** [e when C(c)] *)
| Emerge of var_ident * (constructor_name * extvalue) list
(** merge ident (Constructor -> extvalue)+ *)
(** [merge ident (Constructor -> ]{!extvalue}[)+] *)
| Estruct of (field_name * extvalue) list
(** { field=extvalue; ... } *)
(** [{ field=extvalue; ... }] *)
| Eiterator of iterator_type * app * static_exp list
* extvalue list * extvalue list * var_ident option
(** map f <<n>> <(extvalue)> (extvalue) reset ident *)
(** [map f <<n>> <(extvalue)> (extvalue) reset ident] *)
and app = { a_op: op;
a_params: static_exp list;
@ -106,19 +105,19 @@ and app = { a_op: op;
and be delicate about optimizations, !be careful! *)
and op =
| Eequal (** arg1 = arg2 *)
| Efun of fun_name (** "Stateless" longname <<a_params>> (args) reset r *)
| Enode of fun_name (** "Stateful" longname <<a_params>> (args) reset r *)
| Eifthenelse (** if arg1 then arg2 else arg3 *)
| Efield_update (** { arg1 with a_param1 = arg2 } *)
| Earray (** [ args ] *)
| Earray_fill (** [arg1^a_param1^..^a_paramn] *)
| Eselect (** arg1[a_params] *)
| Eselect_slice (** arg1[a_param1..a_param2] *)
| Eselect_dyn (** arg1.[arg3...] default arg2 *)
| Eselect_trunc (** arg1[>arg_2 ...<]*)
| Eupdate (** [ arg1 with arg3..arg_n = arg2 ] *)
| Econcat (** arg1@@arg2 *)
| Eequal (** [arg1 = arg2] *)
| Efun of fun_name (** "Stateless" [longname <<a_params>> (args) reset r] *)
| Enode of fun_name (** "Stateful" [longname <<a_params>> (args) reset r] *)
| Eifthenelse (** [if arg1 then arg2 else arg3] *)
| Efield_update (** [{ arg1 with a_param1 = arg2 }] *)
| Earray (** [[ args ]] *)
| Earray_fill (** [[arg1^a_param1^..^a_paramn]] *)
| Eselect (** [arg1[a_params]] *)
| Eselect_slice (** [arg1[a_param1..a_param2]] *)
| Eselect_dyn (** [arg1.[arg3...] default arg2] *)
| Eselect_trunc (** [arg1[>arg_2 ...<]]*)
| Eupdate (** [[ arg1 with arg3..arg_n = arg2 ]] *)
| Econcat (** [arg1\@\@arg2] *)
type pat =
| Etuplepat of pat list
@ -264,4 +263,3 @@ let mk_const_dec id ty e loc =
let mk_app ?(params=[]) ?(unsafe=false) ?(id=None) ?(inlined=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe;
a_id = id; a_inlined = inlined }

7
compiler/minils/mls_printer.ml
View file

@ -28,12 +28,7 @@
(***********************************************************************)
open Misc
open Names
open Signature
open Idents
open Types
open Linearity
open Clocks
open Static
open Format
open Global_printer
open Pp_tools
@ -225,7 +220,7 @@ and print_eqs ff = function
let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name)
let rec print_type_dec ff { t_name = name; t_desc = tdesc } =
let print_type_dec ff { t_name = name; t_desc = tdesc } =
let print_type_desc ff = function
| Type_abs -> ()
| Type_alias ty -> fprintf ff " =@ %a" print_type ty

6
compiler/minils/mls_utils.ml
View file

@ -33,10 +33,8 @@ open Location
open Names
open Idents
open Signature
open Static
open Types
open Clocks
open Misc
(** Error Kind *)
type err_kind = | Enot_static_exp
@ -48,7 +46,7 @@ let err_message exp ?(loc=exp.e_loc) = function
print_exp exp;
raise Errors.Error
let rec static_exp_of_exp e =
let static_exp_of_exp e =
match e.e_desc with
| Eextvalue w -> (match w.w_desc with
| Wconst se -> se
@ -215,7 +213,7 @@ end
let node_memory_vars n =
let rec eq funs acc ({ eq_lhs = pat; eq_rhs = e } as equ) =
match pat, e.e_desc with
| Evarpat x, Ewhen(e,_,_) -> eq funs acc {equ with eq_rhs = e}
| Evarpat _, Ewhen(e,_,_) -> eq funs acc {equ with eq_rhs = e}
| Evarpat x, Efby(_, _) ->
let acc = (x, e.e_ty) :: acc in
equ, acc

6
compiler/minils/sigali/sigali.ml
View file

@ -166,9 +166,6 @@ module Printer =
fprintf ff "%s@ " sep;
print_list ff print sep l
let print_string ff s =
fprintf ff "%s" s
let print_name ff n =
fprintf ff "%s" n
@ -432,7 +429,7 @@ module Printer =
fprintf ff "%s_triang : Triang(constraint(%s),controllables,phantom_vars);@,"
name name;
let states =
match !Compiler_options.nosink with
true -> states
@ -465,4 +462,3 @@ module Printer =
let print dir p_l =
List.iter (print_processus dir) p_l
end

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

@ -27,7 +27,6 @@
(* *)
(***********************************************************************)
open Names
open Idents
open Types
open Misc
open Location

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

@ -27,18 +27,12 @@
(* *)
(***********************************************************************)
open Misc
open Names
open Idents
open Signature
open Minils
open Mls_utils
open Mls_printer
open Global_printer
open Types
open Clocks
open Pp_tools
open Mls_compare
(*
Help tomato by inlining extended values.

24
compiler/minils/transformations/normalize_mem.ml
View file

@ -27,26 +27,20 @@
(* *)
(***********************************************************************)
open Idents
open Signature
open Minils
open Mls_mapfold
open Mls_utils
(** Adds an extra equation for outputs that are also memories.
For instance, if o is an output, then:
o = v fby e
becomes
mem_o = v fby e;
o = mem_o
(** Adds an extra equation for outputs that are also memories. For instance, if
o is an output, then:
We also need to add one copy if two (or more) registers are defined by each other, eg:
x = v fby y;
y = v fby x;
becomes
mem_x = v fby y;
x = mem_x;
y = v fby x
*)
[ o = v fby e ] becomes [ mem_o = v fby e; o = mem_o; ]
We also need to add one copy if two (or more) registers are defined by each
other, eg:
[ x = v fby y; y = v fby x; ] becomes [ mem_x = v fby y; x = mem_x; y = v
fby x; ] *)
let normalize_outputs = ref true

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

@ -29,11 +29,8 @@
(* scheduling of equations *)
open Misc
open Minils
open Mls_utils
open Sgraph
open Dep
(* possible overlapping between clocks *)
let join ck1 ck2 =

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

@ -31,7 +31,6 @@
open Idents
open Minils
open Mls_utils
open Misc
open Sgraph
(** In order to put together equations with the same control structure, we have to take into

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

@ -28,12 +28,10 @@
(***********************************************************************)
open Misc
open Names
open Idents
open Signature
open Minils
open Mls_utils
open Mls_printer
open Global_printer
open Types
open Clocks
@ -312,8 +310,8 @@ and extvalue is_input w class_id_list =
(* Regroup classes from a minimization environment *)
(*******************************************************************)
let rec compute_classes tenv =
let rec add_eq_repr _ repr cenv =
let compute_classes tenv =
let add_eq_repr _ repr cenv =
let repr_list = try IntMap.find repr.er_class cenv with Not_found -> [] in
IntMap.add repr.er_class (repr :: repr_list) cenv in
PatMap.fold add_eq_repr tenv IntMap.empty
@ -375,15 +373,15 @@ let construct_mapping (_, cenv) =
IntMap.fold construct_mapping_eq_repr cenv Env.empty
let rec reconstruct ((tenv, cenv) as env) mapping =
let rec reconstruct ((_tenv, cenv) as _env) mapping =
let reconstruct_class id eq_repr_list eq_list =
let reconstruct_class _id eq_repr_list eq_list =
assert (List.length eq_repr_list > 0);
let repr = List.hd eq_repr_list in
let e =
let children =
let _children =
Misc.take (List.length repr.er_children - repr.er_when_count) repr.er_children in
let ed = reconstruct_exp_desc mapping repr.er_head.e_desc repr.er_children in
@ -433,7 +431,7 @@ and reconstruct_exp_desc mapping headd children =
| Ewhen _ -> assert false (* no Ewhen in exprs *)
| Emerge (x_ref, clause_list) ->
| Emerge (_x_ref, clause_list) ->
let x_ref, children = List.hd children, List.tl children in
Emerge (reconstruct_class_ref mapping x_ref,
reconstruct_clauses clause_list children)
@ -534,7 +532,7 @@ module EqClasses = Map.Make(
(if unsafe e2 then -1 else list_compare compare_children cr_list1 cr_list2))
end)
let rec path_environment tenv =
let path_environment tenv =
let enrich_env pat { er_class = id } env =
let rec enrich pat path env = match pat with
| Evarpat x -> Env.add x (id, path) env
@ -576,11 +574,11 @@ let compute_new_class (tenv : tom_env) =
in
let classes = PatMap.fold add_eq_repr tenv EqClasses.empty in
let _classes = PatMap.fold add_eq_repr tenv EqClasses.empty in
(get_id (), tenv)
let rec separate_classes tenv =
let separate_classes tenv =
let rec fix (id, tenv) =
let new_id, tenv = compute_new_class tenv in
debug_do (fun () -> Format.printf "New tenv %d:\n%a@." id debug_tenv tenv) ();
@ -639,7 +637,7 @@ let update_node nd =
ignore (Modules.replace_value nd.n_name sign)
let node nd =
debug_do (fun () -> Format.eprintf "Minimizing %a@." print_qualname nd.n_name);
debug_do (fun () -> Format.eprintf "Minimizing %a@." print_qualname nd.n_name) ();
Idents.enter_node nd.n_name;
(* Initial environment *)
@ -649,7 +647,7 @@ let node nd =
| None -> []
| Some c -> c.c_controllables in
let inputs = nd.n_input @ controllables in
let is_input id =
let is_input id =
List.exists (fun vd -> ident_compare vd.v_ident id = 0) inputs in
List.fold_left (add_equation is_input) PatMap.empty nd.n_equs in

2
compiler/myocamlbuild_config.ml
View file

@ -46,6 +46,8 @@ let ocamlfind_after_rules () =
flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
end (find_syntaxes ());
flag ["ocaml"; "doc"; "thread"] & S[A"-I"; A"+threads"];
(* Use both ml and mli files to build documentation: *)
rule "ocaml: ml & mli -> odoc"
~insert:`top

5
compiler/obc/c/c.ml
View file

@ -29,7 +29,6 @@
open Format
open List
open Modules
open Names
let print_list ff print sep l = Pp_tools.print_list_r print "" sep "" ff l
@ -38,7 +37,7 @@ let print_list ff print sep l = Pp_tools.print_list_r print "" sep "" ff l
Copied verbatim from the old C backend. *)
let cname_of_name name =
let buf = Buffer.create (String.length name) in
let rec convert c =
let convert c =
match c with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
Buffer.add_char buf c
@ -91,7 +90,7 @@ and cexpr =
| Cbop of string * cexpr * cexpr (** Binary operator. *)
| Cfun_call of string * cexpr list (** Function call with its parameters. *)
| Caddrof of cexpr (** Take the address of an 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, ...\]]. *)
| Cconst of cconst (** Constants. *)
| Cvar of string (** A local variable. *)

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

@ -635,7 +635,7 @@ let global_name = ref "";;
(** {2 step() and reset() functions generation *)
(** {2 step() and reset() functions generation} *)
let qn_append q suffix =
{ qual = q.qual; name = q.name ^ suffix }

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

@ -27,20 +27,15 @@
(* *)
(***********************************************************************)
open Format
open List
open Misc
open Names
open Idents
open Obc
open Obc_utils
open Types
open Modules
open Signature
open C
open Cgen
open Location
open Format
open Compiler_utils
(** {1 Main C function generation} *)
@ -102,7 +97,7 @@ let assert_node_res cd =
Cif (Cuop ("!", Cfield (Cvar (fst out), local_qn outn)),
[Csexpr (Cfun_call ("fprintf",
[Cvar "stderr";
Cconst (Cstrlit ("Node \""
Cconst (Cstrlit ("Node \""
^ (Names.fullname cd.cd_name)
^ "\" failed at step" ^
" %d.\n"));
@ -248,17 +243,17 @@ let main_def_of_class_def cd =
:: ep))],
match nbuf_opt with
| None -> []
| Some _ -> [(varn, Cty_arr (20, Cty_char))])
| Some _ -> [(varn, Cty_arr (20, Cty_char))])
end
| Tprod _ | Tinvalid -> failwith("write_lhs_of_ty: untranslatable type")
in
let stepm = find_step_method cd in
let (scanf_calls, scanf_decls) =
let read_lhs_of_ty_for_vd vd =
read_lhs_of_ty (Cvar (Idents.name vd.v_ident)) vd.v_type in
split (map read_lhs_of_ty_for_vd stepm.m_inputs) in
let (printf_calls, printf_decls) =
let write_lhs_of_ty_for_vd vd =
let (stm, vars) =

8
compiler/obc/c/cunroll.ml
View file

@ -29,13 +29,9 @@
(* Unroll loops *)
open Format
open List
open Modules
open Names
open C
let rec unroll id start stop body =
let unroll id start stop body =
let rec aux i l =
let rec exp e = match e with
| Cuop (s, e) -> Cuop (s, exp e)
@ -77,7 +73,7 @@ let rec unroll id start stop body =
aux start []
let rec static_eval e = match e with
let static_eval e = match e with
| Cconst (Ccint i) -> Some i
| _ -> None

5
compiler/obc/control.ml
View file

@ -31,11 +31,8 @@
(* TODO could optimize for loops ? *)
open Idents
open Misc
open Obc
open Obc_utils
open Clocks
open Signature
open Obc_mapfold
@ -58,7 +55,7 @@ let appears_in_exp, appears_in_lhs =
let used_vars e =
let add x acc = if List.mem x acc then acc else x::acc in
let lhsdesc funs acc ld = match ld with
let lhsdesc _funs acc ld = match ld with
| Lvar y -> ld, add y acc
| Lmem y -> ld, add y acc
| _ -> raise Errors.Fallback

4
compiler/obc/java/java.ml
View file

@ -130,7 +130,7 @@ type program = classe list
(** [jname_of_name name] translates the string [name] to a valid Java identifier. *)
let jname_of_name name =
let buf = Buffer.create (String.length name) in
let rec convert c =
let convert c =
match c with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
Buffer.add_char buf c
@ -142,7 +142,7 @@ let jname_of_name name =
Buffer.contents buf
let rec default_value ty = match ty with
let default_value ty = match ty with
| Tclass _ -> Snull
| Tgeneric _ -> Snull
| Tbool -> Sbool true

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

@ -56,14 +56,14 @@ let program p =
let exp_current_arg = Earray_elem(exp_args, exp_argnb) in
*)
let body =
let vd_main, e_main, q_main, ty_main =
let vd_main, e_main, q_main, _ty_main =
let q_main = Obc2java14.qualname_to_package_classe q_main in (*java qual*)
let id = Idents.gen_var "java_main" "main" in
mk_var_dec id false (Tclass q_main), Evar id, q_main, ty_main
in
let acts =
let out = Eclass(Names.qualname_of_string "java.lang.System.out") in
let jarrays = Eclass(Names.qualname_of_string "java.util.Arrays") in
let _jarrays = Eclass(Names.qualname_of_string "java.util.Arrays") in
let jint = Eclass(Names.qualname_of_string "Integer") in
let jfloat = Eclass(Names.qualname_of_string "Float") in
let jbool = Eclass(Names.qualname_of_string "Boolean") in
@ -98,15 +98,7 @@ let program p =
mk_block [Aassgn(pat_step, Evar id_step_dnb)]);
in
let ret = Emethod_call(e_main, "step", []) in
let print_ret = match ty_main with
| Types.Tarray (Types.Tarray _, _) -> Emethod_call(jarrays, "deepToString", [ret])
| Types.Tarray _ -> Emethod_call(jarrays, "toString", [ret])
| t when t = Initial.tint -> Emethod_call(jint, "toString", [ret])
| t when t = Initial.tfloat -> Emethod_call(jfloat, "toString", [ret])
| t when t = Initial.tbool -> Emethod_call(jbool, "toString", [ret])
| _ -> Emethod_call(ret, "toString", [])
in
let main_for_loop i =
let main_for_loop _ =
(* [Aexp (Emethod_call(out, "printf", *)
(* [Sstring "%d => %s\\n"; Evar i; print_ret]))] *)
[Aexp ret]

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

@ -100,7 +100,7 @@ let program p =
let jminus = pervasives_qn "-" in
(* num args to give to the main *)
let rec num_args = List.length ty_main_args in
let num_args = List.length ty_main_args in
(* parse arguments to give to the main *)
let rec parse_args t_l i = match t_l with
@ -140,7 +140,7 @@ let program p =
else [Aexp (Emethod_call(out, "printf", [Sstring "%d => \n"; Evar i]))]
| _ ->
if !Compiler_options.hepts_simulation
then
then
[Aexp (Emethod_call(out, "printf",
[Sstring "%s\n";
Emethod_call(java_pervasives,

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

@ -32,7 +32,6 @@
open Java
open Pp_tools
open Format
open Misc
let print_ident ff id = Format.fprintf ff "%s" (jname_of_name (Idents.name id))
@ -295,4 +294,3 @@ let output_classe base_dir c =
let output_program dir (p:Java.program) =
List.iter (output_classe dir) p

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

@ -41,7 +41,6 @@
open Format
open Misc
open Names
open Modules
open Signature
open Obc
open Obc_utils
@ -86,7 +85,7 @@ let fresh_nfor s_l body =
(* current module is not translated to keep track,
there is no issue since printed without the qualifier *)
let rec translate_modul m = m (*match m with
let translate_modul m = m (*match m with
| Pervasives
| LocalModule -> m
| _ when m = g_env.current_mod -> m
@ -189,7 +188,7 @@ let rec static_exp param_env se = match se.Types.se_desc with
| Types.Sarray se_l ->
Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l)
| Types.Srecord f_e_l ->
let ty_name =
let ty_name =
match se.Types.se_ty with
| Types.Tid ty_name -> qualname_to_package_classe ty_name
| _ -> Misc.internal_error "Obc2java"
@ -220,7 +219,7 @@ and boxed_ty param_env t = match Modules.unalias_type t with
Tarray (t, s_l)
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
and tuple_ty param_env ty_l =
and tuple_ty _param_env ty_l =
let ln = ty_l |> List.length |> Pervasives.string_of_int in
Tclass (java_pervasive_class ("Tuple"^ln))
@ -319,7 +318,7 @@ let obj_ref param_env o = match o with
let jop_of_op param_env op_name e_l =
match op_name with
| { qual = Module "Iostream"; name = "printf" } ->
Emethod_call (Eclass(Names.qualname_of_string "java.lang.System.out"),
Emethod_call (Eclass(Names.qualname_of_string "java.lang.System.out"),
"printf",
(exp_list param_env e_l))
| _ ->
@ -371,7 +370,7 @@ let rec act_list param_env act_l acts =
let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in
(Aifelse (exp param_env e, block param_env _then, block param_env _else)) :: acts)
| Obc.Acase (e, c_b_l) ->
let _c_b (c,b) =
let _c_b (c,b) =
Senum (translate_constructor_name c),
block param_env b in
let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
@ -426,7 +425,7 @@ let class_def_list classes cd_l =
let class_name = qualname_to_package_classe cd.cd_name in
(* [param_env] is an env mapping local param name to ident *)
(* [params] : fields to stock the static parameters, arguments of the constructors *)
let fields_params, vds_params, exps_params, param_env =
let fields_params, vds_params, _exps_params, param_env =
let v, env = sig_params_to_vds cd.cd_params in
let f = vds_to_fields ~protection:Pprotected v in
let e = vds_to_exps v in
@ -550,18 +549,18 @@ let type_dec_list classes td_l =
mk_field jty field
in
let f_l =
List.sort
List.sort
(fun f1 f2 ->
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_body =
let cons_body =
List.map
(fun f -> Aassgn ((Pthis f.f_ident),(Evar f.f_ident)))
fields in
let cons =
mk_methode
mk_methode
~args:cons_params
(mk_block cons_body)
classe_name.name in
@ -602,6 +601,3 @@ let program p =
let classes = type_dec_list classes ts in
let p = class_def_list classes ns in
get_classes()@p

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

@ -86,7 +86,7 @@ let fresh_nfor s_l body =
(* current module is not translated to keep track,
there is no issue since printed without the qualifier *)
let rec translate_modul m = m (*match m with
let translate_modul m = m (*match m with
| Pervasives
| LocalModule -> m
| _ when m = g_env.current_mod -> m
@ -189,7 +189,7 @@ let rec static_exp param_env se = match se.Types.se_desc with
| Types.Sarray se_l ->
Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l)
| Types.Srecord f_e_l ->
let ty_name =
let ty_name =
match se.Types.se_ty with
| Types.Tid ty_name -> qualname_to_package_classe ty_name
| _ -> Misc.internal_error "Obc2java14"
@ -208,7 +208,7 @@ and boxed_ty param_env t = match Modules.unalias_type t with
| Types.Tid t when t = Initial.pbool -> Tclass (Names.local_qn "Boolean")
| Types.Tid t when t = Initial.pint -> Tclass (Names.local_qn "Integer")
| Types.Tid t when t = Initial.pfloat -> Tclass (Names.local_qn "Float")
| Types.Tid t ->
| Types.Tid t ->
begin try
let ty = find_type t in
begin match ty with
@ -228,7 +228,7 @@ and boxed_ty param_env t = match Modules.unalias_type t with
Tarray (t, s_l)
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
and tuple_ty param_env ty_l =
and tuple_ty _param_env ty_l =
let ln = ty_l |> List.length |> Pervasives.string_of_int in
Tclass (java_pervasive_class ("Tuple"^ln))
@ -335,7 +335,7 @@ let obj_ref param_env o = match o with
let jop_of_op param_env op_name e_l =
match op_name with
| { qual = Module "Iostream"; name = "printf" } ->
Emethod_call (Eclass(Names.qualname_of_string "java.lang.System.out"),
Emethod_call (Eclass(Names.qualname_of_string "java.lang.System.out"),
"print",
(exp_list param_env e_l))
| _ ->
@ -371,8 +371,8 @@ let rec act_list param_env act_l acts =
let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in
(Aifelse (exp param_env e, block param_env _then, block param_env _else)) :: acts)
| Obc.Acase (e, c_b_l) ->
let _c_b (c,b) =
let type_name =
let _c_b (c,b) =
let type_name =
match e.e_ty with
Types.Tid n -> qualname_to_package_classe n
| _ -> failwith("act_list: translating case") in
@ -431,7 +431,7 @@ let class_def_list classes cd_l =
let class_name = qualname_to_package_classe cd.cd_name in
(* [param_env] is an env mapping local param name to ident *)
(* [params] : fields to stock the static parameters, arguments of the constructors *)
let fields_params, vds_params, exps_params, param_env =
let fields_params, vds_params, _exps_params, param_env =
let v, env = sig_params_to_vds cd.cd_params in
let f = vds_to_fields ~protection:Pprotected v in
let e = vds_to_exps v in
@ -514,7 +514,7 @@ let class_def_list classes cd_l =
in
let ostep = find_step_method cd in
let vd_output = var_dec_list param_env ostep.m_outputs in
let output_fields =
let output_fields =
List.map (fun vd -> mk_field vd.vd_type vd.vd_ident) vd_output in
let fields = fields @ output_fields in
let build_output_methods i f =
@ -550,7 +550,7 @@ let type_dec_list classes td_l =
let mk_constr_field (acc_fields,i) c =
let init_value = Sint i in
let c = translate_constructor_name_2 c classe_name in
let field =
let field =
mk_field ~static:true ~final:true ~value:(Some init_value)
Tint (Idents.ident_of_name c.name) in
(field::acc_fields),(i+1) in
@ -566,18 +566,18 @@ let type_dec_list classes td_l =
mk_field jty field
in
let f_l =
List.sort
List.sort
(fun f1 f2 ->
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_body =
let cons_body =
List.map
(fun f -> Aassgn ((Pthis f.f_ident),(Evar f.f_ident)))
fields in
let cons =
mk_methode
mk_methode
~args:cons_params
(mk_block cons_body)
classe_name.name in
@ -618,6 +618,3 @@ let program p =
let classes = type_dec_list classes ts in
let p = class_def_list classes ns in
get_classes()@p

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

@ -26,8 +26,6 @@
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
(* *)
(***********************************************************************)
open Misc
open Location
open Compiler_utils
open Compiler_options

1
compiler/obc/obc.ml
View file

@ -31,7 +31,6 @@
(** See the manual for the semantics of the language *)
open Misc
open Names
open Idents
open Types

3
compiler/obc/obc_printer.ml
View file

@ -29,8 +29,6 @@
open Obc
open Format
open Pp_tools
open Types
open Idents
open Names
open Global_printer
@ -235,4 +233,3 @@ let print oc p =
let ff = formatter_of_out_channel oc in
fprintf ff "@[-- Code generated by the MiniLucid Compiler@.";
fprintf ff "@[<v>"; print_prog ff p; fprintf ff "@]@]@."

3
compiler/obc/obc_utils.ml
View file

@ -30,7 +30,6 @@
open Names
open Idents
open Location
open Misc
open Types
open Linearity
open Obc
@ -293,6 +292,6 @@ let rec ext_value_of_pattern patt =
| Larray (p, e) -> Warray (ext_value_of_pattern p, e) in
mk_ext_value ~loc:patt.pat_loc patt.pat_ty desc
let rec exp_of_pattern patt =
let exp_of_pattern patt =
let w = ext_value_of_pattern patt in
mk_exp w.w_ty (Eextvalue w)

3
compiler/obc/transformations/scalarize.ml
View file

@ -47,7 +47,6 @@
*)
open Misc
open Obc
open Obc_utils
open Obc_mapfold
@ -95,5 +94,3 @@ let act funs () a = match a with
let program p =
let p, _ = program_it { defaults with act = act } () p in
p

3
compiler/obc/transformations/unroll.ml
View file

@ -29,7 +29,6 @@
(** Temporary hack to unroll for loops *)
open Misc
open Obc
open Types
open Obc_utils
@ -72,5 +71,3 @@ let act funs () a =
let program p =
let p, _ = program_it { defaults with act = act } () p in
p

4
compiler/preproc.ml
View file

@ -77,8 +77,8 @@ let env = [("DATE", date); ("STDLIB", stdlib)]
environment defined above. *)
let filter =
object
inherit Ast.map as super
method expr e = match e with
inherit Ast.map
method! expr e = match e with
| <:expr< $str:s$ >> when List.mem_assoc s env ->
let repl = try Sys.getenv s with Not_found -> List.assoc s env in
<:expr@here< $str:repl$ >>

8
compiler/utilities/global/compiler_timings.ml
View file

@ -27,8 +27,6 @@
(* *)
(***********************************************************************)
open Unix
let current_module = ref ""
let timings = ref []
let compilation_start = ref 0.
@ -76,7 +74,7 @@ let report_statistics () =
let display (name, time) =
print_string name;
for i = 1 to max_size - String.length name do
for _i = 1 to max_size - String.length name do
print_string " "
done;
@ -84,7 +82,7 @@ let report_statistics () =
in
let print_sep () =
for i = 1 to max_size + 22 + String.length big_space do
for _i = 1 to max_size + 22 + String.length big_space do
print_string "#"
done;
Printf.printf "\n"
@ -101,7 +99,7 @@ let report_statistics () =
print_sep ();
Printf.printf "TOTAL";
for i = 1 to max_size - 5 do
for _i = 1 to max_size - 5 do
print_string " "
done;
let percent = List.fold_left (+) 0 (List.map compute_percent (List.map snd !timings)) in

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

@ -61,9 +61,9 @@ let comment ?(sep=separateur) s =
let do_pass d f p pp =
comment (d ^ " ...\n");
let start = Unix.gettimeofday () in
let _start = Unix.gettimeofday () in
let r = Compiler_timings.time_pass d f p in
let stop = Unix.gettimeofday () in
let _stop = Unix.gettimeofday () in
pp r;
comment ~sep:"*** " (d ^ " done.");
r
@ -138,4 +138,3 @@ let print_header_info ff cbeg cend =
cend
let errmsg = "Options are:"

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

@ -44,7 +44,7 @@ module Make (Read:READ) =
struct
let build eqs =
(* associate a graph node for each name declaration *)
let rec nametograph g var_list is_antidep n_to_graph =
let nametograph g var_list is_antidep n_to_graph =
let add_node env x =
if Env.mem x env then
let l = Env.find x env in
@ -54,7 +54,7 @@ struct
in
List.fold_left add_node n_to_graph var_list in
let rec nametograph_env g var_list node_env =
let nametograph_env g var_list node_env =
List.fold_left (fun env x -> Env.add x g env) node_env var_list in
let rec init_graph eqs g_list n_to_graph lin_map node_env =
@ -99,4 +99,3 @@ struct
make_graph g_list names_to_graph lin_map;
g_list, node_env
end

1
compiler/utilities/global/printf_parser.ml
View file

@ -26,7 +26,6 @@
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
(* *)
(***********************************************************************)
open Types
exception Bad_format

2
compiler/utilities/minils/dcoloring.ml
View file

@ -64,7 +64,7 @@ module Dsatur = struct
G.fold_succ_e color g v ColorSet.empty
(** Returns the smallest value not in the list of colors. *)
let rec find_min_available_color interf_colors =
let find_min_available_color interf_colors =
let rec aux i =
if not (ColorSet.mem i interf_colors) then i else aux (i+1)
in

8
compiler/utilities/misc.ml
View file

@ -99,7 +99,7 @@ let rec split_last = function
(** [split_nlasts l] returns l without its last n elements and
the last n elements of l. *)
let rec split_nlast n l =
let split_nlast n l =
let rec aux l = match l with
| [] -> [], [], 0
| a::l ->
@ -133,8 +133,8 @@ let drop n l =
l
let rec nth_of_list n l = match n, l with
| 1, h::t -> h
| n, h::t -> nth_of_list (n-1) t
| 1, h::_ -> h
| n, _::t -> nth_of_list (n-1) t
| _ -> raise List_too_short
@ -190,7 +190,7 @@ let rec list_diff l dl = match l with
let l = list_diff l dl in
if List.mem x dl then l else x::l
(** { 3 Compiler iterators } *)
(** {3 Compiler iterators} *)
(** Mapfold *) (* TODO optim : in a lot of places we don't need the List.rev *)
let mapfold f acc l =

19
compiler/utilities/pp_tools.ml
View file

@ -9,7 +9,7 @@
open Format
let rec print_list print lp sep rp ff = function
let print_list print lp sep rp ff = function
| [] -> ()
| x::l ->
fprintf ff "%s%a" lp print x;
@ -17,7 +17,7 @@ let rec print_list print lp sep rp ff = function
fprintf ff "%s" rp
let rec print_list_r print lp sep rp ff = function
let print_list_r print lp sep rp ff = function
| [] -> ()
| x :: l ->
fprintf ff "%s%a" lp print x;
@ -25,7 +25,7 @@ let rec print_list_r print lp sep rp ff = function
fprintf ff "%s" rp
let rec print_list_l print lp sep rp ff = function
let print_list_l print lp sep rp ff = function
| [] -> ()
| x :: l ->
fprintf ff "%s%a" lp print x;
@ -54,16 +54,3 @@ let print_record print_field ff record =
let print_type_params ff pl =
fprintf ff "@[%a@]"
(print_list_r (fun ff s -> fprintf ff "'%s" s) "("","") ") pl
let print_set iter print_element ff set =
fprintf ff "@[{@ ";
iter (fun e -> fprintf ff "%a@ " print_element e) set;
fprintf ff "}@]"
let print_map iter print_key print_element ff map =
fprintf ff "@[<hv 2>[@ ";
iter (fun k x -> fprintf ff "| %a -> %a@ " print_key k print_element x) map;
fprintf ff "]@]"

3
compiler/utilities/sgraph.ml
View file

@ -98,7 +98,7 @@ let cycle g_list =
(* store nodes in a stack *)
let s = Stack.create () in
(* flush the connected component *)
let rec flush index =
let rec flush _index =
if Stack.is_empty s then []
else let v = Stack.pop s in
v.g_containt :: flush v.g_tag in
@ -164,4 +164,3 @@ let print_node print g =
g.g_depends_on;
printf "@]"
*)