heptagon/compiler/global/signature.ml

148 lines
4.5 KiB
OCaml
Raw Normal View History

(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* global data in the symbol tables *)
open Names
open Types
2011-05-12 00:54:02 +02:00
open Location
(** Warning: Whenever these types are modified,
interface_format_version should be incremented. *)
2011-05-06 18:07:40 +02:00
let interface_format_version = "30"
2011-05-09 19:32:12 +02:00
type ck =
| Cbase
| Con of ck * constructor_name * name
2011-05-06 18:07:40 +02:00
(** Node argument : inputs and outputs *)
type arg = {
a_name : name option;
a_type : ty;
a_clock : ck; (** [a_clock] set to [Cbase] means at the node activation clock *)
}
2010-07-07 12:15:02 +02:00
(** Node static parameters *)
2010-07-05 15:43:51 +02:00
type param = { p_name : name; p_type : ty }
(** Constraints on size expressions *)
type constrnt = static_exp
2010-07-08 14:56:49 +02:00
(** Node signature *)
type node = {
2011-05-06 18:07:40 +02:00
node_inputs : arg list;
node_outputs : arg list;
node_stateful : bool;
node_params : param list;
node_param_constraints : constrnt list;
2011-05-12 00:54:02 +02:00
node_loc : location}
type field = { f_name : field_name; f_type : ty }
type structure = field list
type type_def =
| Tabstract
| Talias of ty
| Tenum of constructor_name list
| Tstruct of structure
type const_def = { c_type : ty; c_value : static_exp }
2011-05-12 00:54:02 +02:00
(** { 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
2011-05-12 00:54:02 +02:00
let message loc e = begin match e with
| Eckvar_unbound_input(var_name,ck_name) ->
2011-05-13 15:35:29 +02:00
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.@."
2011-05-12 00:54:02 +02:00
print_location loc
2011-05-13 15:35:29 +02:00
a name ck_name
2011-05-12 00:54:02 +02:00
| Eckvar_unbound_ouput (var_name,ck_name) ->
2011-05-13 15:35:29 +02:00
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.@."
2011-05-12 00:54:02 +02:00
print_location loc
2011-05-13 15:35:29 +02:00
a name ck_name
2011-05-12 00:54:02 +02:00
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));
2011-05-12 00:54:02 +02:00
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) ->
2011-05-12 00:54:02 +02:00
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) ->
2011-05-12 00:54:02 +02:00
message s.node_loc (Eckvar_unbound_ouput (x,c))
2011-05-09 19:32:12 +02:00
let rec ck_to_sck ck =
let ck = Clocks.ck_repr ck in
match ck with
| Clocks.Cbase -> Cbase
| Clocks.Con (ck,c,x) -> Con(ck_to_sck ck, c, Idents.source_name x)
2011-05-23 09:24:57 +02:00
| _ -> Misc.internal_error "Signature couldn't translate ck"
2011-05-09 19:32:12 +02:00
let names_of_arg_list l = List.map (fun ad -> ad.a_name) l
let types_of_arg_list l = List.map (fun ad -> ad.a_type) l
2011-05-06 18:07:40 +02:00
let mk_arg name ty ck = { a_type = ty; a_name = name; a_clock = ck }
2010-07-05 15:43:51 +02:00
let mk_param name ty = { p_name = name; p_type = ty }
2010-06-29 11:18:50 +02:00
2010-07-01 19:35:24 +02:00
let mk_field n ty = { f_name = n; f_type = ty }
let mk_const_def ty value =
{ c_type = ty; c_value = value }
2011-05-12 00:54:02 +02:00
let mk_node ?(constraints = []) loc ins outs stateful params =
{ node_inputs = ins;
node_outputs = outs;
2011-03-21 14:30:19 +01:00
node_stateful = stateful;
node_params = params;
node_param_constraints = constraints;
2011-05-12 00:54:02 +02:00
node_loc = loc}
2010-06-17 13:05:16 +02:00
let rec field_assoc f = function
| [] -> raise Not_found
| { f_name = n; f_type = ty }::l ->
if f = n then ty
2010-07-14 00:55:40 +02:00
else field_assoc f l
2011-03-23 20:31:26 +01:00