[passes] pass to check the typing tags of the program / expressions

src/ast.ml

@@ -69,8 +69,6 @@ and t_node =
     n_local_vars: t_varlist;
     n_equations: t_eqlist;
     n_automata: t_autolist;
-    n_inputs_type : full_ty;
-    n_outputs_type : full_ty;
   }
 
 type t_nodelist = t_node list

src/main.ml

@@ -26,7 +26,7 @@ let exec_passes ast main_fn verbose debug passes f =
 let _ =
   (** Usage and argument parsing. *)
   let default_passes = ["pre2vars"; "linearization"; "equations_ordering"] in
-  let sanity_passes = ["chkvar_init_unicity"] in
+  let sanity_passes = ["chkvar_init_unicity"; "check_typing"] in
   let usage_msg =
     "Usage: main [-passes p1,...,pn] [-ast] [-verbose] [-debug] \
       [-o output_file] [-m main_function] source_file\n" in
@@ -72,6 +72,7 @@ let _ =
       ("chkvar_init_unicity", Passes.chkvar_init_unicity);
       ("linearization", Passes.pass_linearization);
       ("equations_ordering", Passes.pass_eq_reordering);
+      ("check_typing", Passes.pass_typing);
     ];
 
   (** Main functionality below *)

src/parser.mly

@@ -198,9 +198,7 @@ node_content:
           n_outputs    = (t_out, e_out);
           n_local_vars = $10;
           n_equations  = eqs;
-          n_automata = aut;
-          n_inputs_type = t_in;
-          n_outputs_type = t_out; } in
+          n_automata = aut; } in
       if Hashtbl.find_opt defined_nodes node_name <> None
         then raise (MyParsingError
                     (Format.asprintf "The node %s is already defined."
@@ -386,8 +384,8 @@ expr:
       { let name = $1 in
         let node = fetch_node name in
         let args = $3 in
-        if type_exp args = node.n_inputs_type
-          then EApp (node.n_outputs_type, fetch_node name, args)
+        if type_exp args = fst node.n_inputs
+          then EApp (fst node.n_outputs, fetch_node name, args)
           else raise (MyParsingError ("The application does not type check!",
                       current_location()))
          }

src/passes.ml

@@ -2,6 +2,7 @@
 
 open Ast
 open Passes_utils
+open Utils
 
 let pre2vars verbose debug main_fn =
   let rec all_pre expr =
@@ -13,7 +14,7 @@ let pre2vars verbose debug main_fn =
   in
   let rec pre_push expr : t_expression =
     match expr with
-    | EVar _ -> EMonOp (Utils.type_exp expr, MOp_pre, expr)
+    | EVar _ -> EMonOp (type_exp expr, MOp_pre, expr)
     | EConst _ -> expr (** pre(c) = c for any constant c *)
     | EMonOp (ty, mop, expr) ->
       begin
@@ -82,7 +83,7 @@ let pre2vars verbose debug main_fn =
       let arg = aux arg in
       EApp (ty, node, arg)
 in
-  expression_pass (Utils.somify aux)
+expression_pass (somify aux)
 
 let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option =
 let aux (node: t_node) : t_node option =
@@ -92,7 +93,7 @@ let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option
     | Some num -> Hashtbl.replace h n (num + 1)
     in
   let incr_eq h (((_, patt), _): t_equation) =
-      List.iter (fun v -> incr_aux h (Utils.name_of_var v)) patt
+    List.iter (fun v -> incr_aux h (name_of_var v)) patt
     in
   let rec incr_eqlist h = function
     | [] -> ()
@@ -161,14 +162,14 @@ let pass_linearization verbose debug main_fn =
     | ETuple (_, hexps :: texps) ->
         debug "An ETuple has been recognized, inlining...";
         let p1, p2 =
-            Utils.list_select
-              (List.length (Utils.type_exp hexps))
+          list_select
+            (List.length (type_exp hexps))
             (snd pat) in
-          let t1 = List.flatten (List.map Utils.type_var p1) in
-          let t2 = List.flatten (List.map Utils.type_var p2) in
+        let t1 = List.flatten (List.map type_var p1) in
+        let t2 = List.flatten (List.map type_var p2) in
         ((t1, p1), hexps)
           :: (tpl ((t2, p2),
-                ETuple (List.flatten (List.map Utils.type_exp texps), texps)))
+              ETuple (List.flatten (List.map type_exp texps), texps)))
     | ETuple (_, []) -> []
     | _ -> [(pat, exp)]
   in
@@ -187,8 +188,6 @@ let pass_linearization verbose debug main_fn =
       n_local_vars = new_locvars;
       n_equations = new_equations;
       n_automata = node.n_automata;
-        n_inputs_type = node.n_inputs_type;
-        n_outputs_type = node.n_outputs_type;
     }
 in
 node_pass node_lin
@@ -203,22 +202,97 @@ let pass_eq_reordering verbose debug main_fn ast =
               (fun (patt, expr) ->
                 List.for_all
                   (fun v -> List.mem v init_vars)
-                    (Utils.vars_of_expr expr))
+                  (vars_of_expr expr))
               remaining_equations with
-        | [] -> raise EquationOrderingIssue
+      | [] -> raise (PassExn "[equation ordering] The equations cannot be ordered.")
       | h :: t ->
           let init_vars =
             List.fold_left
               (fun acc vs ->
-                  acc @ (Utils.vars_of_patt (fst vs))) init_vars (h :: t) in
+                acc @ (vars_of_patt (fst vs))) init_vars (h :: t) in
           pick_equations init_vars (eqs@(h :: t))
             (List.filter (fun eq -> List.for_all (fun e -> eq <> e) (h :: t)) remaining_equations)
     end
   in
 let node_eq_reorganising  (node: t_node): t_node option =
-    let init_vars = List.map Utils.name_of_var (snd node.n_inputs) in
+  let init_vars = List.map name_of_var (snd node.n_inputs) in
+  try
+    begin
     match pick_equations init_vars [] node.n_equations with
     | None -> None
     | Some eqs -> Some { node with n_equations = eqs }
+    end
+  with PassExn err -> (verbose err; None)
 in
 node_pass node_eq_reorganising ast
+
+let pass_typing verbose debug main_fn ast =
+  let htbl = Hashtbl.create (List.length ast) in
+  let () = debug "[typing verification]" in
+  let () = List.iter
+    (fun n -> Hashtbl.add htbl n.n_name (fst n.n_inputs, fst n.n_outputs))
+    ast in
+  let rec check_varlist vl =
+    let t = fst vl in
+    let l = snd vl in
+    match t, l with
+    | [], [] -> true
+    | TInt  :: t, IVar _ :: l -> check_varlist (t, l)
+    | TBool :: t, BVar _ :: l -> check_varlist (t, l)
+    | TReal :: t, RVar _ :: l -> check_varlist (t, l)
+    | _, _ -> false
+    in
+  let rec check_expr vl = function
+    | EVar   (t, v) -> t = type_var v
+    | EMonOp (t, _, e) -> check_expr vl e && type_exp e = t
+    | EBinOp (t, _, e, e') -> check_expr vl e && check_expr vl e'
+                              && t = type_exp e && t = type_exp e'
+    | ETriOp (t, _, c, e, e') ->
+        check_expr vl e && check_expr vl e' && check_expr vl c
+        && type_exp c = [TBool] && type_exp e = t && type_exp e' = t
+    | EComp  (t, _, e, e') ->
+        check_expr vl e && check_expr vl e' && t = [TBool]
+    | EWhen  (t, e, e') ->
+        check_expr vl e && check_expr vl e'
+        && t = type_exp e && [TBool] = type_exp e'
+    | EReset (t, e, e') ->
+        check_expr vl e && check_expr vl e' && t = type_exp e && type_exp e' = [TBool]
+    | EConst (t, c) -> type_const c = t
+    | ETuple (t, l) ->
+        List.for_all (check_expr vl) l
+        && t = List.flatten (List.map type_exp l)
+    | EApp   (t, n, e) ->
+        check_expr vl e && t = (fst n.n_outputs) && type_exp e = (fst n.n_inputs)
+  in
+  let check_equation vl ((peq, eeq): t_equation) =
+    if check_varlist peq
+      then
+        if check_expr vl eeq
+          then fst peq = type_exp eeq
+          else false
+      else false
+  in
+  let rec check_equations vl = function
+    | [] -> true
+    | eq :: eqs ->
+        if check_equation vl eq
+          then check_equations vl eqs
+          else false
+  in
+  let check_one_node node =
+    check_varlist (node.n_inputs)
+    && check_varlist (node.n_outputs)
+    && check_varlist (node.n_local_vars)
+    && check_equations
+        (varlist_concat node.n_inputs
+          (varlist_concat node.n_outputs node.n_local_vars))
+        node.n_equations
+    in
+  let rec aux = function
+    | [] -> Some ast
+    | n :: nodes ->
+        if check_one_node n
+          then aux nodes
+          else None
+  in aux ast
+

src/passes_utils.ml

@@ -18,8 +18,6 @@ let equation_pass (f: t_equation -> t_equation option) ast: t_nodelist option =
                         n_local_vars   = node.n_local_vars;
                         n_equations    = eqs;
                         n_automata     = node.n_automata;
-                        n_inputs_type  = node.n_inputs_type;
-                        n_outputs_type = node.n_outputs_type;
                        }
     in
   node_pass aux ast
@@ -32,4 +30,4 @@ let expression_pass f: t_nodelist -> t_nodelist option =
   in
   equation_pass aux
 
-exception EquationOrderingIssue
+exception PassExn of string

src/test.node

@@ -1,4 +1,5 @@
 node diagonal_int (i: int) returns (o1, o2 : int);
+let i: int;
 let
 	(o1, o2) = (i, i);
 tel

src/test2.node

@@ -1,4 +1,7 @@
 node diagonal_int (i: int) returns (o1, o2 : int);
+var y: int;
 let
-	(o1, o2) = (i, i);
+    o2 = y;
+    y = i;
+    o1 = i;
 tel

src/utils.ml

@@ -24,6 +24,11 @@ let rec list_chk v = function
 
 exception MyParsingError of (string * location)
 
+let type_const = function
+  | CReal _ -> [TReal]
+  | CInt  _ -> [TInt ]
+  | CBool _ -> [TBool]
+
 let type_var (v: t_var) =
     match v with
     | IVar _ -> [TInt]
@@ -77,3 +82,6 @@ let rec vars_of_expr (expr: t_expression) : ident list =
       (vars_of_expr e) @ (vars_of_expr e') @ (vars_of_expr e'')
   | ETuple (_, l) -> List.flatten (List.map vars_of_expr l)
 
+let rec varlist_concat (l1: t_varlist) (l2: t_varlist): t_varlist =
+  (fst l1 @ fst l2, snd l1 @ snd l2)
+