You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
81 lines
3.6 KiB
OCaml
81 lines
3.6 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Heptagon *)
|
|
(* *)
|
|
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
|
(* Leonard Gerard, Parkas, ENS *)
|
|
(* Adrien Guatto, Parkas, ENS *)
|
|
(* Cedric Pasteur, Parkas, ENS *)
|
|
(* *)
|
|
(* Copyright 2012 ENS, INRIA, UJF *)
|
|
(* *)
|
|
(* This file is part of the Heptagon compiler. *)
|
|
(* *)
|
|
(* Heptagon is free software: you can redistribute it and/or modify it *)
|
|
(* under the terms of the GNU General Public License as published by *)
|
|
(* the Free Software Foundation, either version 3 of the License, or *)
|
|
(* (at your option) any later version. *)
|
|
(* *)
|
|
(* Heptagon is distributed in the hope that it will be useful, *)
|
|
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
|
|
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
|
|
(* GNU General Public License for more details. *)
|
|
(* *)
|
|
(* You should have received a copy of the GNU General Public License *)
|
|
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
open Misc
|
|
open Names
|
|
open Idents
|
|
open Signature
|
|
open Minils
|
|
open Mls_utils
|
|
open Mls_printer
|
|
open Global_printer
|
|
open Types
|
|
open Clocks
|
|
|
|
let add_check prefix pass nd nd_list =
|
|
if nd.n_input <> []
|
|
then (Format.eprintf "Cannot generate check for node %a with inputs"
|
|
print_qualname nd.n_name; assert false)
|
|
else
|
|
let nd'_name = { nd.n_name with name = prefix ^ "_" ^ nd.n_name.name; } in
|
|
let nd' = pass nd in
|
|
let nd' = { nd' with n_name = nd'_name; } in
|
|
let output = Idents.gen_var "checkpass" "o" in
|
|
|
|
let echeck =
|
|
let ty_r = match nd.n_output with
|
|
| [out] -> out.v_type
|
|
| _ -> Tprod (List.map (fun vd -> vd.v_type) nd.n_output) in
|
|
let mk_call nn = mk_exp ~ty:ty_r (Eapp (mk_app (Enode nn), [], None)) in
|
|
mk_exp ~ty:(Tid Initial.pbool) (Eapp (mk_app Eequal, [mk_call nd.n_name; mk_call nd'.n_name], None)) in
|
|
|
|
let nd_check =
|
|
mk_node
|
|
~output:[mk_var_dec output (Tid Initial.pbool)]
|
|
~eq:[mk_equation (Evarpat output) echeck]
|
|
{ nd.n_name with name = prefix ^ "_check_" ^ nd.n_name.name; } in
|
|
|
|
let sign = Modules.find_value nd.n_name in
|
|
Modules.add_value nd'.n_name sign;
|
|
Modules.add_value nd_check.n_name
|
|
{ node_inputs = [];
|
|
node_outputs = [{ a_name = None; a_type = Tid Initial.pbool; }];
|
|
node_stateful = true;
|
|
node_params = [];
|
|
node_param_constraints = [] };
|
|
|
|
Compiler_options.add_assert nd_check.n_name.name;
|
|
nd :: nd' :: nd_check :: nd_list
|
|
|
|
let add_checks pass prefix nnl p =
|
|
let add nd nd_list =
|
|
if List.mem nd.n_name nnl
|
|
then add_check pass prefix nd nd_list
|
|
else nd :: nd_list in
|
|
{ p with p_nodes = List.fold_right add p.p_nodes []; }
|