[C] malloc->calloc + conditions merged in free_state_*

src/ast_to_c.ml

@@ -236,11 +236,15 @@ let cp_init_aux_nodes fmt (node, h) =
     | None -> () (** All auxiliary nodes have been initialized *)
     | Some n ->
       begin
-      Format.fprintf fmt "%a\t\tstate->aux_states[%d] = malloc (sizeof (%s));\n\
-          \t\t((%s*)(state->aux_states[%d]))->is_init = true;\n"
+      Format.fprintf fmt "%a\t\tif(!state->is_reset) {\n\
+          \t\t\tstate->aux_states[%d] = calloc (1, sizeof (%s));\n\
+          \t\t}\n\
+          \t\t((%s*)(state->aux_states[%d]))->is_init = true;\n\
+          \t\t((%s*)(state->aux_states[%d]))->is_reset = state->is_reset;\n"
         aux (node, nst, i-1)
         (i-1) (Format.asprintf "t_state_%s" n.n_name)
         (Format.asprintf "t_state_%s" n.n_name) (i-1)
+        (Format.asprintf "t_state_%s" n.n_name) (i-1)
       end
   in
   let nst = Hashtbl.find h node.in_name in
@@ -310,9 +314,11 @@ let ast_to_c verbose debug prog =
   verbose "Computation of the node_states";
   let prog_st_types = make_state_types prog in
   debug (Format.asprintf "%a" dump_var_locations prog_st_types);
-  let prog: i_nodelist = ast_to_intermediate_ast prog prog_st_types in
-  Format.printf "%a\n\n%a\n\n/* Nodes: */\n%a"
+  let iprog: i_nodelist = ast_to_intermediate_ast prog prog_st_types in
+  Format.printf "%a\n\n%a\n\n%a\n\n/* Nodes: */\n%a%a\n"
     cp_includes (Config.c_includes)
     cp_state_types prog_st_types
-    cp_nodes (prog, prog_st_types)
+    cp_state_frees (iprog, prog_st_types)
+    cp_nodes (iprog, prog_st_types)
+    cp_main_fn (prog, prog_st_types)
 

src/config.ml

@@ -3,4 +3,4 @@
     * variables. *)
 let maxvar = 100
 
-let c_includes = ["stdbool"; "stdlib"]
+let c_includes = ["stdbool"; "stdlib"; "stdio"; "string"]

src/cprint.ml

@@ -19,7 +19,7 @@ let cp_node_state fmt (st: node_state) =
   if st.nt_count_app = 0
     then
       Format.fprintf fmt "typedef struct {%a%a%a\n\
-            \tbool is_init;\n\
+            \tbool is_init, is_reset;\n\
             } %s;\n\n"
         print_if_any ("int", st.nt_nb_int, "ivars")
         print_if_any ("bool", st.nt_nb_bool, "bvars")
@@ -27,7 +27,7 @@ let cp_node_state fmt (st: node_state) =
         st.nt_name
     else
       Format.fprintf fmt "typedef struct {%a%a%a\n\
-            \tbool is_init;\n\
+            \tbool is_init, is_reset;\n\
             \tvoid* aux_states[%d]; /* stores the states of auxiliary nodes */\n\
             } %s;\n\n"
         print_if_any ("int", st.nt_nb_int, "ivars")
@@ -40,6 +40,89 @@ let cp_state_types fmt (h: (ident, node_state) Hashtbl.t): unit =
     Format.fprintf fmt "/* Struct holding states of the node %s: */\n%a" n
       cp_node_state nst) h
 
+
+
+(** [cp_state_frees] prints the required code to recursively free the node
+  * states. *)
+let cp_state_frees fmt (iprog, sts) =
+  let rec find_callee (i: int) (f: i_node) =
+    let rec aux_expr = function
+      | IETuple [] | IEVar   _ | IEConst _ -> None
+      | IEMonOp (_, e) -> aux_expr e
+      | IEWhen  (e, e')
+      | IEReset (e, e')
+      | IEComp  (_, e, e')
+      | IEBinOp (_, e, e') ->
+        begin
+          match aux_expr e with
+          | None -> aux_expr e'
+          | Some res -> Some res
+        end
+      | IETriOp (_, e, e', e'') ->
+        begin
+          match aux_expr e with
+          | None ->
+            (match aux_expr e' with
+            | None -> aux_expr e''
+            | Some res -> Some res)
+          | Some res -> Some res
+        end
+      | IETuple (h :: t) ->
+        begin
+          match aux_expr h with
+          | None -> aux_expr (IETuple t)
+          | Some res -> Some res
+        end
+      | IEApp   (j, n, e) ->
+          if i = j
+            then Some n.n_name
+            else aux_expr e
+    in
+    List.fold_right
+      (fun (_, expr) acc ->
+        match acc with
+        | Some _ -> acc
+        | None -> aux_expr expr)
+      f.in_equations None
+  in
+  let rec cp_free_aux fmt (i, caller_name) =
+    let idx = i - 1 in
+    match find_callee i (List.find (fun n -> n.in_name = caller_name) iprog)with
+    | None -> ()
+    | Some callee_name ->
+      let callee_st = Hashtbl.find sts callee_name in
+      if callee_st.nt_count_app > 0
+        then
+          Format.fprintf fmt "\tif (st->aux_states[%d]) {\n\
+            \t\tfree_state_%s((t_state_%s*)(st->aux_states[%d]));\n\
+            \t\tfree (st->aux_state[%d]);\n\t}\n%a"
+            idx callee_name callee_name idx
+            idx cp_free_aux (i+1, caller_name)
+        else Format.fprintf fmt "\tif (st->aux_states[%d])\n\
+            \t\tfree(st->aux_states[%d]);\n%a"
+            idx idx cp_free_aux (i+1, caller_name)
+  in
+  Hashtbl.iter
+    (fun node_name node_st ->
+      if node_st.nt_count_app = 0
+        then () (** Nothing to free for the node [node_name]. *)
+        else
+          Format.fprintf fmt "void free_state_%s(t_state_%s *);\n"
+            node_name node_name) sts;
+  Hashtbl.iter
+    (fun node_name node_st ->
+      if node_st.nt_count_app = 0
+        then () (** Nothing to free for the node [node_name]. *)
+        else
+          Format.fprintf fmt "void free_state_%s(t_state_%s *st)\n\
+            {\n\
+              %a\
+            }\n"
+            node_name node_name
+            cp_free_aux (1, node_name)) sts
+
+
+
 let cp_var' fmt = function
   | CVStored (arr, idx) -> Format.fprintf fmt "state->%s[%d]" arr idx
   | CVInput s -> Format.fprintf fmt "%s" s
@@ -75,6 +158,13 @@ let rec cp_varlist fmt vl =
     print_if_any vl
     cp_varlist vl
 
+
+
+(** [cp_prototype] prints functions prototypes (without the «;»). It is only
+  * used to write the beginning of functions right now. If we later allow to
+  * use auxiliary nodes before their definition, it might be useful to declare
+  * all the prototypes at the beginning of the file (Cf. [cp_prototypes] below.
+  *)
 let cp_prototype fmt (node, h): unit =
   match Hashtbl.find_opt h node.in_name with
   | None -> failwith "This should not happened!"
@@ -96,6 +186,10 @@ let rec cp_prototypes fmt ((nodes, h): i_nodelist * node_states) =
 
 
 
+(** [cp_value] prints values, that is unary or binary operations which can be
+  * inlined in the final code without requiring many manipulations.
+  * It uses a lot of parenthesis at the moment. An improvement would be to
+  * remove useless ones at some point. *)
 let rec cp_value fmt (value, (hloc: (ident * bool, string * int) Hashtbl.t)) =
   let string_of_binop = function
     | BOp_add -> "+"
@@ -146,6 +240,8 @@ let rec cp_value fmt (value, (hloc: (ident * bool, string * int) Hashtbl.t)) =
   | CMonOp (MOp_pre, _) ->
       failwith "The linearization should have removed this case."
 
+
+
 let prefix_ = ref "\t"
 
 (** The following function prints one transformed equation of the program into a
@@ -191,10 +287,16 @@ and cp_expression fmt (expr, hloc) =
     end
   | CReset (node_name, i, v, b) ->
     begin
-      Format.fprintf fmt "\tif (%a) {\n\t\t((t_state_%s*)(state->aux_states[%d]))->is_init = true;\n\t}\n%a\n"
+      Format.fprintf fmt "\tif (%a) {\n\
+        \t\t((t_state_%s*)(state->aux_states[%d]))->is_init = true;\n\
+        \t\t((t_state_%s*)(state->aux_states[%d]))->is_reset = true;\n\
+        \t}\n\
+        %a\n"
         cp_value (v, hloc)
         node_name
         (i - 1)
+        node_name
+        (i - 1)
         cp_block (b, hloc)
     end
   | CIf (v, b1, []) ->
@@ -218,3 +320,127 @@ and cp_expression fmt (expr, hloc) =
         p;
       prefix_  := p
 
+
+
+(** [cp_main] prints  a main function to the C code if necessary:
+  * if there is a function [main] in the lustre program, it will generate a main
+  * function in the C code, otherwise it does not do anything.
+  *)
+let cp_main_fn fmt (prog, sts) =
+  let rec cp_array fmt (vl: t_var list): unit =
+    match vl with
+    | [] -> ()
+    | v :: vl ->
+      let typ, name =
+        match v with
+        | IVar s -> ("int", s)
+        | RVar s -> ("double", s)
+        | BVar s ->
+            Format.fprintf fmt "\tchar _char_of_%s;\n" s;
+            ("bool", s)
+        in
+      Format.fprintf fmt "\t%s %s;\n%a" typ name
+      cp_array vl
+  in
+  let rec cp_inputs fmt (f, l) =
+    match l with
+    | [] -> ()
+    | h :: t ->
+      (if f
+        then Format.fprintf fmt ", %s%a"
+        else Format.fprintf fmt "%s%a")
+        (Utils.name_of_var h)
+        cp_inputs (true, t)
+  in
+  let cp_scanf fmt vl =
+    let rec cp_scanf_str fmt (b, vl) =
+      match vl with
+      | [] -> ()
+      | h :: t ->
+        (if b
+          then Format.fprintf fmt " %s%a"
+          else Format.fprintf fmt "%s%a")
+        (match h with
+        | IVar _ -> "%d"
+        | BVar _ -> "%c"
+        | RVar _ -> "%lf")
+        cp_scanf_str (true, t)
+    in
+    let rec cp_scanf_args fmt vl =
+      match vl with
+      | [] -> ()
+      | RVar s :: vl | IVar s :: vl ->
+        Format.fprintf fmt ", &%s%a" s cp_scanf_args vl
+      | BVar s :: vl ->
+        Format.fprintf fmt ", &%s%a" (Format.sprintf "_char_of_%s" s)
+          cp_scanf_args  vl
+    in
+    Format.fprintf fmt "\"%a\"%a"
+      cp_scanf_str (false, vl)
+      cp_scanf_args vl
+  in
+  let cp_printf fmt vl =
+    let rec cp_printf_str fmt (b, vl) =
+      match vl with
+      | [] -> ()
+      | h :: t ->
+        (if b
+          then Format.fprintf fmt " %s%a"
+          else Format.fprintf fmt "%s%a")
+        (match h with
+        | IVar _ -> "%d"
+        | BVar _ -> "%c"
+        | RVar _ -> "%f")
+        cp_printf_str (true, t)
+    in
+    let rec cp_printf_arg fmt (h, i) =
+      match Hashtbl.find_opt h i with
+      | None -> ()
+      | Some (s, i) ->
+        Format.fprintf fmt ", state.%s[%d]%a"
+          s i cp_printf_arg (h, i+1)
+    in
+    Format.fprintf fmt "\"%a\\n\"%a"
+      cp_printf_str (false, vl)
+      cp_printf_arg ((Hashtbl.find sts "main").nt_output_map, 0)
+  in
+  let rec cp_char_to_bool fmt vl =
+    match vl with
+    | [] -> ()
+    | RVar _ :: vl | IVar _ :: vl -> Format.fprintf fmt "%a" cp_char_to_bool vl
+    | BVar s :: vl ->
+      Format.fprintf fmt "\t\t%s = (%s == 't') ? true : false;\n%a"
+        s (Format.sprintf "_char_of_%s" s)
+        cp_char_to_bool vl
+  in
+  let cp_free fmt () =
+    let main_st = Hashtbl.find  sts "main" in
+    if main_st.nt_count_app = 0
+      then ()
+      else Format.fprintf fmt "\tfree_state_main(&state);\n"
+  in
+  match List.find_opt (fun n -> n.n_name = "main") prog with
+  | None -> ()
+  | Some node ->
+    Format.fprintf fmt "int main (int argc, char **argv)\n\
+      {\n%a\n\
+        \tchar _buffer[1024];\n\
+        \tt_state_main state;\n\
+        \tstate.is_init = true;\n\
+        \tstate.is_reset = false;\n\
+        \twhile(true) {\n\
+          \t\tscanf(\"%%s\", _buffer);\n\
+          \t\tif(!strcmp(_buffer, \"exit\")) { break; }\n\
+          \t\tsscanf(_buffer, %a);\n%a\
+          \t\tfn_main(&state, %a);\n\
+          \t\tprintf(%a);\n\
+        \t}\n\
+        %a\treturn EXIT_SUCCESS;\n\
+      }\n"
+      cp_array (snd node.n_inputs)
+      cp_scanf (snd node.n_inputs)
+      cp_char_to_bool (snd node.n_inputs)
+      cp_inputs (false, snd node.n_inputs)
+      cp_printf (snd node.n_outputs)
+      cp_free ()
+

src/lustre_pp.ml

@@ -37,7 +37,7 @@ let rec pp_varlist fmt : t_varlist -> unit = function
       Format.fprintf fmt "%s: bool, %a" h pp_varlist (tl, h' :: l)
   | (TReal :: tl, RVar h :: h' :: l) ->
       Format.fprintf fmt "%s: real, %a" h pp_varlist (tl, h' :: l)
-  | _ -> raise (MyTypeError "This exception should not have beed be raised.")
+  | _ -> raise (MyTypeError "(1) This exception should not have beed be raised.")
 
 let pp_expression =
   let upd_prefix s = s ^ " |  " in
@@ -45,11 +45,14 @@ let pp_expression =
     let rec pp_expression_list prefix fmt exprs =
       match exprs with
       | ETuple([], []) -> ()
-      | ETuple (_ :: tt, expr :: exprs) ->
+      | ETuple (typs, expr :: exprs) ->
+          let typ_h, typ_t =
+            Utils.list_select (List.length (Utils.type_exp expr)) typs in
           Format.fprintf fmt "%a%a"
             (pp_expression_aux (prefix^" |> ")) expr
-            (pp_expression_list prefix) (ETuple (tt, exprs))
-      | _ -> raise (MyTypeError "This exception should not have been raised.")
+            (pp_expression_list prefix) (ETuple (typ_t, exprs))
+      | ETuple (_, []) -> failwith "An empty tuple has a type!"
+      | _ -> failwith "This exception should never occur."
     in
     match expression with
     | EWhen (_, e1, e2) ->

src/parser.mly

@@ -63,7 +63,7 @@
 
   let make_binop_nonbool e1 e2 op error_msg =
     let t1 = type_exp e1 in let t2 = type_exp e2 in
-    (** e1 and e2 should be nunmbers here.*)
+    (** e1 and e2 should be numbers here.*)
     if list_chk t1 [[TInt]; [TReal]] && list_chk t2 [[TInt]; [TReal]]
       then
         begin
@@ -88,7 +88,7 @@
 
   let make_comp_nonbool e1 e2 op error_msg =
     let t1 = type_exp e1 in let t2 = type_exp e2 in
-    (** e1 and e2 should be nunmbers here.*)
+    (** e1 and e2 should be numbers here.*)
     if list_chk t1 [[TInt]; [TReal]] && list_chk t2 [[TInt]; [TReal]]
       then
         begin
@@ -216,8 +216,8 @@ node_content:
               if vars_distinct e_in e_out (snd $10)
                 then (Hashtbl.add defined_nodes node_name n; n)
                 else raise (MyParsingError
-                            ("There is a conflict between the names of local, input \
-                            or output variables.",
+                            ("There is a conflict between the names of local,\
+                             input or output variables.",
                             current_location()))
           end};
 
@@ -313,33 +313,33 @@ expr:
   | MO_pre expr                        { EMonOp (type_exp $2, MOp_pre, $2) }
   | MINUS expr
       { monop_neg_condition $2 [TBool]
-          "You cannot take the opposite of a boolean expression."
+          "You cannot take the opposite of an expression that is not a number."
           (EMonOp (type_exp $2, MOp_minus, $2)) }
   | PLUS expr
       { monop_neg_condition $2 [TBool]
-          "You cannot take the plus of a boolean expression." $2 }
+          "(+) expects its argument to be a number." $2 }
   /* Binary operators */
   | expr PLUS expr
       { make_binop_nonbool $1 $3 BOp_add
-          "You should know better; addition hates booleans" }
+          "Addition expects both arguments to be (the same kind of) numbers." }
   | expr MINUS expr
       { make_binop_nonbool $1 $3 BOp_sub
-          "You should know better; subtraction hates booleans" }
+          "Substraction expects both arguments to be (the same kind of) numbers." }
   | expr BO_mul expr
       { make_binop_nonbool $1 $3 BOp_mul
-          "You should know better; multiplication hates booleans" }
+          "Multiplication expects both arguments to be (the same kind of) numbers." }
   | expr BO_div expr
       { make_binop_nonbool $1 $3 BOp_div
-          "You should know better; division hates booleans" }
+          "Division expects both arguments to be (the same kind of) numbers." }
   | expr BO_mod expr
       { make_binop_nonbool $1 $3 BOp_mod
-          "You should know better; modulo hates booleans" }
+          "Modulo expects both arguments to be numbers." }
   | expr BO_and expr
       { make_binop_bool $1 $3 BOp_and
-          "You should know better; conjunction hates numbers" }
+          "Conjunction expects both arguments to be booleans." }
   | expr BO_or expr
       { make_binop_bool $1 $3 BOp_or
-          "You should know better; disjunction hates numbers" }
+          "Disjunction expects both arguments to be booleans." }
   | expr BO_arrow expr
       { let e1 = $1 in let t1 = type_exp e1 in
         let e2 = $3 in let t2 = type_exp e2 in

src/test.node

@@ -1,15 +1,18 @@
-node id (a: bool) returns (o: bool);
+node id_int (i: int) returns (o: int);
 let
-  o = a;
+  o = i -> i;
 tel
 
-node test_merge_tuples (a, b: bool) returns (o: bool);
-var t: bool;
+node aux (i, j: int) returns (o: int);
 let
-  (o, t) = if a and b then (true, false) else (false, true);
+  o = id_int(i) + id_int(j);
 tel
 
-node my_and (a, b: bool) returns (o: bool);
+node main (i: int) returns (a, b: int);
+var tmp: int;
 let
-  o = if a then b else id(false -> a);
+  a = 1;
+  b = aux (i, a);
+  tmp = aux (a+b, i);
 tel
+