Better check signature error message

compiler/global/check_signature.ml

@@ -0,0 +1,59 @@
+open Names
+open Location
+open Signature
+
+
+type error =
+  | Eckvar_unbound_input of name option * name
+  | Eckvar_unbound_ouput of name option * name
+
+exception SignatureError of name option * name
+
+let message loc (s,e) =
+  Format.eprintf "%aInfered signature :@\n%a@\n"
+    print_location loc
+    Global_printer.print_interface_value ("",s);
+  begin match e with
+  | Eckvar_unbound_input(var_name,ck_name) ->
+      let a,name = match var_name with None -> "A","" | Some n -> "The"," "^n in
+      Format.eprintf "%s sampled input%s should come together with its sampling variable %s.@."
+        a name ck_name
+  | Eckvar_unbound_ouput (var_name,ck_name) ->
+      let a,name = match var_name with None -> "A","" | Some n -> "The"," "^n in
+      Format.eprintf "%s sampled ouput%s should be returned with its sampling value %s.@."
+        a name ck_name
+  end;
+  Format.eprintf "@.";
+  raise Errors.Error
+
+
+(** @raise Errors.Error after printing the error *)
+let check_signature s =
+  (* a simple env of defined names will be used, represented by a Set *)
+  let rec append env sa_l = match sa_l with
+    | [] -> env
+    | sa::sa_l -> match sa.a_name with
+        | None -> append env sa_l
+        | Some x -> append (NamesSet.add x env) sa_l
+  in
+  (* the clock of [arg] is correct if all the vars used are in [env] *)
+  let check env arg =
+    let n = arg.a_name in
+    let rec f = function
+      | Cbase -> ()
+      | Con(ck,_,x) ->
+          if not (NamesSet.mem x env)
+          then raise (SignatureError (n,x));
+          f ck
+    in
+    f arg.a_clock
+  in
+  (*initial env with only the inputs*)
+  let env = append NamesSet.empty s.node_inputs in
+  (try List.iter (check env) s.node_inputs
+  with SignatureError (x,c) ->
+    message s.node_loc (s, Eckvar_unbound_input (x,c)));
+  let env = append env s.node_outputs in
+  try List.iter (check env) s.node_outputs
+  with SignatureError (x,c) ->
+    message s.node_loc (s, Eckvar_unbound_ouput (x,c))

compiler/global/names.ml

@@ -85,9 +85,12 @@ let is_infix s =
       ["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]
       StrSet.empty in
   if StrSet.mem s infix_set then true
-  else (match String.get s 0 with
+  else begin
+    try match String.get s 0 with
           | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' | '~' -> false
-          | _ -> true)
+          | _ -> true
+    with Invalid_argument _ -> (* empty string *) false
+  end
 
 open Format
 

compiler/global/signature.ml

@@ -58,59 +58,6 @@ type const_def = { c_type : ty; c_value : static_exp }
 
 (** { 3 Signature helper functions } *)
 
-type error =
-  | Eckvar_unbound_input of name option * name
-  | Eckvar_unbound_ouput of name option * name
-
-exception SignatureError of name option * name
-
-let message loc e = begin match e with
-  | Eckvar_unbound_input(var_name,ck_name) ->
-      let a,name = match var_name with None -> "A","" | Some n -> "The"," "^n in
-      Format.eprintf "%a%s sampled input%s should come together with its sampling variable %s.@."
-        print_location loc
-        a name ck_name
-  | Eckvar_unbound_ouput (var_name,ck_name) ->
-      let a,name = match var_name with None -> "A","" | Some n -> "The"," "^n in
-      Format.eprintf "%a%s sampled ouput%s should be returned with its sampling value %s.@."
-        print_location loc
-        a name ck_name
-  end;
-  raise Errors.Error
-
-
-(** @raise Errors.Error after printing the error *)
-let check_signature s =
-  (* a simple env of defined names will be used, represented by a Set *)
-  let rec append env sa_l = match sa_l with
-    | [] -> env
-    | sa::sa_l -> match sa.a_name with
-        | None -> append env sa_l
-        | Some x -> append (NamesSet.add x env) sa_l
-  in
-  (* the clock of [arg] is correct if all the vars used are in [env] *)
-  let check env arg =
-    let n = arg.a_name in
-    let rec f = function
-      | Cbase -> ()
-      | Con(ck,_,x) ->
-          if not (NamesSet.mem x env)
-          then raise (SignatureError (n,x));
-          f ck
-    in
-    f arg.a_clock
-  in
-  (*initial env with only the inputs*)
-  let env = append NamesSet.empty s.node_inputs in
-  (try List.iter (check env) s.node_inputs
-  with SignatureError (x,c) ->
-    message s.node_loc (Eckvar_unbound_input (x,c)));
-  let env = append env s.node_outputs in
-  try List.iter (check env) s.node_outputs
-  with SignatureError (x,c) ->
-    message s.node_loc (Eckvar_unbound_ouput (x,c))
-
-
 let rec ck_to_sck ck =
   let ck = Clocks.ck_repr ck in
   match ck with

compiler/heptagon/analysis/hept_clocking.ml

@@ -251,7 +251,7 @@ let update_signature h node =
   let sign =
     { sign with node_inputs = List.map2 set_arg_clock node.n_input sign.node_inputs;
                 node_outputs = List.map2 set_arg_clock node.n_output sign.node_outputs } in
-  Signature.check_signature sign;
+  Check_signature.check_signature sign;
   Modules.replace_value node.n_name sign
 
 let typing_node node =

compiler/heptagon/parsing/hept_scoping.ml

@@ -548,7 +548,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 s.sig_loc i o s.sig_stateful s.sig_unsafe p in
-  Signature.check_signature sig_node;
+  Check_signature.check_signature sig_node;
   safe_add s.sig_loc add_value n sig_node;
   mk_signature n i o s.sig_stateful p c s.sig_loc
 

compiler/minils/analysis/clocking.ml

@@ -244,17 +244,6 @@ let typing_contract h contract =
         expect_extvalue h' Cbase e_g;
         append_env h c_list
 
-(* check signature causality and update it in the global env *)
-let update_signature h node =
-  let set_arg_clock vd ad =
-    { ad with a_clock = Signature.ck_to_sck (ck_repr (Env.find vd.v_ident h)) }
-  in
-  let sign = Modules.find_value node.n_name in
-  let sign =
-    { sign with node_inputs = List.map2 set_arg_clock node.n_input sign.node_inputs;
-                node_outputs = List.map2 set_arg_clock node.n_output sign.node_outputs } in
-  Signature.check_signature sign;
-  Modules.replace_value node.n_name sign
 
 let typing_node node =
   let h0 = append_env Env.empty node.n_input in
@@ -270,7 +259,9 @@ let typing_node node =
                          n_output = List.map set_clock node.n_output;
                          n_local = List.map set_clock node.n_local }
   in
-  update_signature h node;
+  let sign = Mls_utils.signature_of_node node in
+  Check_signature.check_signature sign;
+  Modules.replace_value node.n_name sign;
   node
 
 let program p =

compiler/minils/mls_printer.ml

@@ -29,8 +29,8 @@ let rec print_pat ff = function
   | Etuplepat pat_list ->
       fprintf ff "@[<2>(%a)@]" (print_list_r print_pat """,""") pat_list
 
-let print_vd ff { v_ident = n; v_type = ty; v_linearity = lin; v_clock = ck } =
- if !Compiler_options.full_type_info then
+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
     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
 
@@ -61,7 +61,10 @@ and print_w_tuple ff l =
   fprintf ff "@[<2>(%a)@]" (print_list_r print_extvalue """,""") l
 
 and print_vd_tuple ff l =
-  fprintf ff "@[<2>%a@]" (print_list_r print_vd "("";"")") l
+  fprintf ff "@[<2>%a@]" (print_list_r (print_vd ~show_ck:false) "("";"")") l
+
+and print_full_vd_tuple ff l =
+  fprintf ff "@[<2>%a@]" (print_list_r (print_vd ~show_ck:true) "("";"")") l
 
 and print_index ff idx =
   fprintf ff "@[<2>%a@]" (print_list print_static_exp "[""][""]") idx

compiler/minils/mls_utils.ml

@@ -247,3 +247,18 @@ let remove_eqs_from_node nd ids =
   let vd_list = List.fold_right walk_vd nd.n_local [] in
   let eq_list = List.fold_right walk_eq nd.n_equs [] in
   { nd with n_local = vd_list; n_equs = eq_list; }
+
+let args_of_var_decs =
+ List.map
+   (fun vd -> Signature.mk_arg (Some (Idents.source_name vd.v_ident))
+                               vd.v_type (Linearity.check_linearity vd.v_linearity)
+                               (ck_to_sck (Clocks.ck_repr vd.v_clock)))
+
+let signature_of_node n =
+  { node_inputs = args_of_var_decs n.n_input;
+    node_outputs  = args_of_var_decs n.n_output;
+    node_stateful = n.n_stateful;
+    node_unsafe = n.n_unsafe;
+    node_params = n.n_params;
+    node_param_constraints = n.n_param_constraints;
+    node_loc = n.n_loc }

compiler/minils/transformations/tomato.ml

@@ -593,7 +593,7 @@ let update_node nd =
   let change_name vd arg = { arg with a_name = Some (name vd.v_ident) } in
   let sign = Modules.find_value nd.n_name in
   let sign = { sign with node_outputs = List.map2 change_name nd.n_output sign.node_outputs } in
-  Signature.check_signature sign;
+  Check_signature.check_signature sign;
   ignore (Modules.replace_value nd.n_name sign)
 
 let node nd =

tools/decade.sty

@@ -0,0 +1,39 @@
+\ProvidesPackage{decade}
+
+\RequirePackage{listings}
+
+\lstdefinelanguage{lustre}{
+morekeywords={
+node, returns, var, allocate, mutable, let, tel, const, pre, last,fby,
+merge, at, if, then, else},
+otherkeywords={=, [, ], :, ;, <<, >>, <-},
+sensitive=true,
+morecomment=[n]{(*}{*)},
+morestring=[b]",
+morestring=[b]'
+}
+
+\lstdefinelanguage{decade}{
+morekeywords={
+async,fun,future,node,returns,var,let,tel,const,pre,last,do,reset, every,fby,at,
+type,merge,automaton,end,switch,case,state,until,if,then,else,
+map,with,default,mapfold,fold,new,int,float,init,fun,split,for},
+otherkeywords={->},
+sensitive=true,
+morecomment=[n]{(*}{*)},
+morestring=[b]",
+morestring=[b]'
+}
+
+\lstdefinelanguage{obc}{
+morekeywords={
+machine,registers,instances,switch,step,float,int,var,case,mutable,for,to},
+otherkeywords={},
+sensitive=true,
+morecomment=[n]{(*}{*)},
+morestring=[b]",
+morestring=[b]'
+}
+
+
+\lstset{language=decade}