(** Time-stamp: <modified the 19/03/2010 (at 14:29) by Erwan Jahier> *)
open Printf
open Lxm
open Eff
open List
(* XXX changer le nom de cette fonction *)
let (dump_long : Ident.long -> string) = fun x ->
if !Global.ec then
Ident.no_pack_string_of_long x
else
Ident.string_of_long x
(* fun id -> *)
(* let str = Ident.string_of_long id in *)
(* Str.global_replace (Str.regexp "::") "__" str *)
let type_alias_table = Hashtbl.create 0
(******************************************************************************)
(******************************************************************************)
let (get_rank : 'a -> 'a list -> int) =
fun x l ->
let rec aux i l =
match l with
| [] -> assert false
| y::l -> if x = y then i else aux (i+1) l
in
aux 1 l
let _ = assert (get_rank 5 [1;3;5] = 3)
(* check it is a non-singleton tuple *)
let rec (is_a_tuple : Eff.val_exp -> bool) =
function
| { core = CallByPosEff ({ it = TUPLE }, OperEff [ve]) } -> is_a_tuple ve
| { core = CallByPosEff ({ it = TUPLE }, OperEff vel) } -> List.length vel > 1
| _ -> false
(******************************************************************************)
(* prefix used to prefix user type name in order to avoid name clashed with
the alias type name that are generated by the compiler. *)
let prefix = "_"
let rec string_of_const_eff =
function
| Bool_const_eff true -> "true"
| Bool_const_eff false -> "false"
| Int_const_eff i -> sprintf "%d" i
| Real_const_eff r -> r
| Extern_const_eff (s,t) -> (dump_long s)
| Abstract_const_eff (s,t,v,_) ->
(dump_long s) ^ (* XXX ? *)
(string_of_const_eff v)
(* | Abstract_const_eff (s,t,v,false) -> (dump_long s) *)
| Enum_const_eff (s,t) ->
if !Global.expand_enums then
match t with
| Enum_type_eff(_,l) -> string_of_int (get_rank s l)
| _ -> assert false
else
(dump_long s)
| Struct_const_eff (fl, t) -> (
let string_of_field =
function (id, veff) ->
(Ident.to_string id)^" = "^ (string_of_const_eff veff)
in
let flst = List.map string_of_field fl in
(string_of_type_eff t)^"{"^(String.concat "; " flst)^"}"
)
| Array_const_eff (ctab, t) -> (
let vl = List.map string_of_const_eff ctab in
"["^(String.concat ", " vl)^"]"
)
and string_ident_of_const_eff c =
(* that version generates a string that is a valid lic ident, in order to use it
to generate a node name using static parameters *)
match c with
| Bool_const_eff _
| Int_const_eff _
| Real_const_eff _
| Extern_const_eff _
| Abstract_const_eff _
| Enum_const_eff _ -> string_of_const_eff c
| Struct_const_eff (_, t) -> (
match t with
| Struct_type_eff (sn,_) -> dump_long sn
| _ -> assert false
)
| Array_const_eff (ctab, t) -> string_of_type_eff t
and string_of_const_eff_opt = function
| None -> ""
| Some val_exp_eff -> string_of_const_eff val_exp_eff
and string_def_of_type_eff = function
| Bool_type_eff -> "bool"
| Int_type_eff -> "int"
| Real_type_eff -> "real"
| External_type_eff (i) -> dump_long i
| Abstract_type_eff (i, t) -> string_def_of_type_eff t ^ " -- abstract in the source "
| Enum_type_eff (i, sl) ->
assert (sl <>[]);
if !Global.expand_enums then "int" else
let f sep acc s = acc ^ sep ^ (dump_long s) in
(List.fold_left (f ", ") (f "" "enum {" (List.hd sl)) (List.tl sl)) ^ "}"
| Array_type_eff (ty, sz) -> sprintf "%s^%d" (string_of_type_eff ty) sz
| Struct_type_eff (name, fl) ->
assert (fl <>[]);
let f sep acc (id, (type_eff, const_eff_opt)) =
acc ^ sep ^ (Ident.to_string id) ^ " : " ^
(string_of_type_eff type_eff) ^
match const_eff_opt with
None -> ""
| Some ce -> " = " ^ (string_of_const_eff ce)
in
"struct " ^
(List.fold_left (f "; ") (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
| Any -> "a"
| Overload -> "o"
(* exported *)
and string_of_type_eff = function
| Bool_type_eff -> "bool"
| Int_type_eff -> "int"
| Real_type_eff -> "real"
| External_type_eff (name) -> prefix ^ (dump_long name)
| Abstract_type_eff (name, t) -> prefix ^ (dump_long name)
(* string_of_type_eff t *)
| Enum_type_eff (name, _) -> prefix ^ (dump_long name)
| Array_type_eff (ty, sz) -> array_alias ty sz
| Struct_type_eff (name, _) -> prefix ^ (dump_long name)
| Any -> string_of_type_eff (Polymorphism.get_type ())
| Overload -> string_of_type_eff (Polymorphism.get_type ())
and string_of_type_eff4msg = function
| Bool_type_eff -> "bool"
| Int_type_eff -> "int"
| Real_type_eff -> "real"
| External_type_eff (name) -> prefix ^ (dump_long name)
| Abstract_type_eff (name, t) -> prefix ^ (dump_long name)
(* string_of_type_eff4msg t *)
| Enum_type_eff (name, _) -> prefix ^ (dump_long name)
| Array_type_eff (ty, sz) -> (string_of_type_eff4msg ty) ^ "^" ^(string_of_int sz)
| Struct_type_eff (name, _) -> prefix ^ (dump_long name)
| Any -> "'a"
| Overload -> "'o"
(******************************************************************************)
(** Stuff to manage generated type alias
Indeed instead of printing:
node toto(x: int ^ 4) ...
we want to print something like :
type int4 = int ^ 4;
node toto(x: int4) ...
That may occur only for array actually.
To do that, we maintain a table of type alias that we fill each time
we want to print (via string_of_type_eff) a type that is not a named type.
Then, at the end, we will dump that table in the lic file.
This table is filled by [array_alias].
*)
and (array_alias : Eff.type_ -> int -> string) =
fun t size ->
let array_t = Array_type_eff(t,size) in
try Hashtbl.find type_alias_table array_t
with Not_found ->
let alias_t = string_of_type_eff t in
let res = Name.array_type array_t (alias_t ^ "_" ^(string_of_int size)) in
Hashtbl.add type_alias_table array_t res;
res
(* exported *)
and dump_type_alias oc =
let p = output_string oc in
if Hashtbl.length type_alias_table > 0 then p "-- automatically defined aliases:";
Hashtbl.iter
(fun type_eff alias_name ->
try
p ("\ntype " ^ alias_name ^ " = " ^ (string_def_of_type_eff type_eff)^";")
with Polymorphism.Exc -> ()
)
type_alias_table
(******************************************************************************)
(* exported *)
and (type_eff_list_to_string : Eff.type_ list -> string) =
fun tel ->
let str_l = List.map string_of_type_eff4msg tel in
String.concat "*" str_l
and string_of_type_eff_list = function
| [] -> ""
| [x] -> string_of_type_eff x
| l -> String.concat " * " (List.map string_of_type_eff l)
and string_of_type_eff_list4msg = function
| [] -> ""
| [x] -> string_of_type_eff4msg x
| l -> String.concat " * " (List.map string_of_type_eff4msg l)
(* for printing recursive node *)
and string_of_node_key_rec (nkey: node_key) =
match nkey with
| (ik, []) -> dump_long ik
| (ik, salst) ->
let astrings = List.map static_arg2string salst in
let name = sprintf "%s_%s" (dump_long ik) (String.concat "_" astrings) in
Name.node_key nkey name
(* for printing iterators *)
and string_of_node_key_iter lxm (nkey: node_key) =
match nkey with
| (ik, []) -> dump_long ik
| (ik, salst) ->
let astrings = List.map (static_arg2string) salst in
sprintf "%s<<%s>>" (dump_long ik) (String.concat ", " astrings)
(* for printing recursive node and iterators *)
and static_arg2string (sa : Eff.static_arg) =
match sa with
| ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
| NodeStaticArgEff (id, (long, _, _)) ->
sprintf "%s" (dump_long long)
and (string_of_var_info_eff4msg: Eff.var_info -> string) =
fun x ->
(Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff4msg x.var_type_eff)
and (string_of_var_info_eff: Eff.var_info -> string) =
fun x ->
(Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)
and (type_string_of_var_info_eff: Eff.var_info -> string) =
fun x -> (string_of_type_eff x.var_type_eff) ^
(string_of_clock2 (snd x.var_clock_eff))
and (type_string_of_var_info_eff4msg: Eff.var_info -> string) =
fun x -> (string_of_type_eff4msg x.var_type_eff) ^
(string_of_clock2 (snd x.var_clock_eff))
and string_of_decl var_info_eff =
let vt_str =
(Ident.to_string var_info_eff.var_name_eff) ^ ":" ^
(string_of_type_eff var_info_eff.var_type_eff)
in
let clk_str = (string_of_clock (snd var_info_eff.var_clock_eff)) in
let vt_str =
if !Global.ec &&
(match (snd var_info_eff.var_clock_eff) with
BaseEff | ClockVar _ -> false
| _ -> true)
then "(" ^ vt_str ^ ")"
else vt_str
in
vt_str ^ clk_str
and (string_of_type_decl_list : Eff.var_info list -> string -> string) =
fun tel sep ->
let str = String.concat sep (List.map string_of_decl tel) in
str
and string_of_slice_info_eff si_eff =
"[" ^ (string_of_int si_eff.se_first) ^ " .. " ^ (string_of_int si_eff.se_last) ^
(if si_eff.se_step = 1 then "" else " step " ^ (string_of_int si_eff.se_step)) ^
"]"
and (string_of_leff : Eff.left -> string) =
function
| LeftVarEff (vi_eff,_) -> Ident.to_string vi_eff.var_name_eff
| LeftFieldEff(leff,id,_) -> (string_of_leff leff) ^ "." ^ (Ident.to_string id)
| LeftArrayEff(leff,i,_) -> (string_of_leff leff) ^ "[" ^ (string_of_int i) ^ "]"
| LeftSliceEff(leff,si,_) -> (string_of_leff leff) ^ (string_of_slice_info_eff si)
and (string_of_leff_list : Eff.left list -> string) =
fun l ->
(if List.length l = 1 then "" else "(") ^
(String.concat ", " (List.map string_of_leff l)) ^
(if List.length l = 1 then "" else ")")
and sov ve = string_of_val_exp_eff ve
and (string_of_by_pos_op_eff: Eff.by_pos_op srcflagged -> Eff.val_exp list -> string) =
fun posop vel ->
let tuple vel = (String.concat ", " (List.map string_of_val_exp_eff vel)) in
let tuple_par vel = "(" ^ (tuple vel) ^ ")" in
let tuple_square vel =
"[" ^ (String.concat ", " (List.map string_of_val_exp_eff vel)) ^ "]"
in
let str =
match posop.it,vel with
| Predef (Predef.NOT_n,_), [ve1] ->
((op2string Predef.NOT_n) ^ " " ^
(if is_a_tuple ve1 then (tuple_par [ve1]) else sov ve1))
| Predef (Predef.DIESE_n,_), [ve1] ->
if !Global.lv4
then sov ve1 (* lv4 does no accept to apply # on One var only! *)
else ((op2string Predef.DIESE_n) ^ (tuple_par [ve1]))
| Predef (Predef.IF_n,_), [ve1; ve2; ve3] ->
let ve2str = string_of_val_exp_eff ve2 in
let ve2str = if is_a_tuple ve2 then "("^ve2str^")" else ve2str in
let ve3str = string_of_val_exp_eff ve3 in
let ve3str = if is_a_tuple ve3 then "("^ve3str^")" else ve3str in
" if " ^ (string_of_val_exp_eff ve1) ^
" then " ^ ve2str ^ " else " ^ ve3str
| Predef(op,sargs), vel ->
if Predef.is_infix op then (
match vel with
| [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " " ^ (op2string op) ^
" " ^ (string_of_val_exp_eff ve2)
| _ -> assert false
)
else
((op2string op) ^
(if sargs = [] then
match op with
| Predef.ICONST_n _ | Predef.RCONST_n _ | Predef.NOT_n
| Predef.UMINUS_n | Predef.IUMINUS_n | Predef.RUMINUS_n
| Predef.FALSE_n | Predef.TRUE_n ->
tuple vel
| _ -> tuple_par vel
else
"<<" ^
(String.concat ", " (List.map (static_arg2string) sargs))
^ ">>" ^ (tuple_par vel)))
| CALL nee, _ -> (
if nee.it.def_eff = ExternEff then
if !Global.lv4 then
(match nee.it.node_key_eff with
(* predef op that are iterated are translated into node_exp ;
hence, we need to do (again) a particular threatment to have
a node ouput (i.e., "2>a" vs "Lustre::lt(2,a)" *)
| ("Lustre","uminus"), [] -> " -" ^ sov (hd vel)
| ("Lustre","iuminus"), [] -> " -" ^ sov (hd vel)
| ("Lustre","ruminus"), [] -> " -" ^ sov (hd vel)
| ("Lustre","not"), [] -> " not " ^ sov (hd vel)
| ("Lustre","lt"), [] -> sov (hd vel) ^ " < " ^ sov (hd (tl vel))
| ("Lustre","lte"), [] -> sov (hd vel) ^ " <= " ^ sov (hd (tl vel))
| ("Lustre","gt"), [] -> sov (hd vel) ^ " > " ^ sov (hd (tl vel))
| ("Lustre","gte"), [] -> sov (hd vel) ^ " >= " ^ sov (hd (tl vel))
| ("Lustre","eq"), [] -> sov (hd vel) ^ " = " ^ sov (hd (tl vel))
| ("Lustre","neq"), [] -> sov (hd vel) ^ " <> " ^ sov (hd (tl vel))
| ("Lustre","diff"), [] -> sov (hd vel) ^ " <> " ^ sov (hd (tl vel))
| ("Lustre","plus"), [] -> sov (hd vel) ^ " + " ^ sov (hd (tl vel))
| ("Lustre","iplus"), [] -> sov (hd vel) ^ " + " ^ sov (hd (tl vel))
| ("Lustre","rplus"), [] -> sov (hd vel) ^ " + " ^ sov (hd (tl vel))
| ("Lustre","minus"), [] -> sov (hd vel) ^ " - " ^ sov (hd (tl vel))
| ("Lustre","iminus"), [] -> sov (hd vel) ^ " - " ^ sov (hd (tl vel))
| ("Lustre","rminus"), [] -> sov (hd vel) ^ " - " ^ sov (hd (tl vel))
| ("Lustre","div"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","idiv"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","rdiv"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","times"), [] -> sov (hd vel) ^ " * " ^ sov (hd (tl vel))
| ("Lustre","rtimes"), [] -> sov (hd vel) ^ " * " ^ sov (hd (tl vel))
| ("Lustre","itimes"), [] -> sov (hd vel) ^ " * " ^ sov (hd (tl vel))
| ("Lustre","slash"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","rslash"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","islash"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","impl"), [] -> sov (hd vel) ^ " => " ^ sov (hd (tl vel))
| ("Lustre","mod"), [] -> sov (hd vel) ^ " mod " ^ sov (hd (tl vel))
| ("Lustre","and"), [] -> sov (hd vel) ^ " and " ^ sov (hd (tl vel))
| ("Lustre","or"), [] -> sov (hd vel) ^ " or " ^ sov (hd (tl vel))
| ("Lustre","xor"), [] -> sov (hd vel) ^ " xor " ^ sov (hd (tl vel))
| ("Lustre","if"), [] ->
" if " ^ sov (hd vel) ^ " then " ^ sov (hd (tl vel))
^ " else " ^ sov (hd (tl (tl vel)))
| _ ->
((string_of_node_key_iter nee.src nee.it.node_key_eff) ^ (tuple_par vel))
)
else
((string_of_node_key_iter nee.src nee.it.node_key_eff) ^ (tuple_par vel))
else
(* recursive node cannot be extern *)
((string_of_node_key_rec nee.it.node_key_eff) ^ (tuple_par vel))
)
| IDENT idref, _ -> Ident.string_of_idref idref
| PRE, _ -> "pre " ^ (tuple_par vel)
| ARROW, [ve1; ve2] ->
(if is_a_tuple ve1 then tuple_par [ve1] else string_of_val_exp_eff ve1) ^
" -> " ^
(if is_a_tuple ve1 then tuple_par [ve2] else string_of_val_exp_eff ve2)
| FBY, [ve1; ve2] ->
if !Global.lv4 then
(if is_a_tuple ve1 then tuple_par [ve1] else string_of_val_exp_eff ve1)
^ " -> pre " ^
(if is_a_tuple ve1 then tuple_par [ve2] else string_of_val_exp_eff ve2)
else
(if is_a_tuple ve1 then tuple_par [ve1] else string_of_val_exp_eff ve1)
^ " fby " ^
(if is_a_tuple ve1 then tuple_par [ve2] else string_of_val_exp_eff ve2)
| WHEN clk, vel -> (tuple vel) ^ (string_of_clock_exp clk)
| CURRENT,_ -> "current " ^ tuple_par vel
| TUPLE,_ -> (tuple vel)
| WITH(ve),_ -> (string_of_val_exp_eff ve)
| CONCAT, [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " | " ^ (string_of_val_exp_eff ve2)
| HAT (i, ve), _ -> (string_of_val_exp_eff ve) ^ "^" ^ (string_of_int i)
| ARRAY vel, _ -> tuple_square vel
| STRUCT_ACCESS(id), [ve1] ->
(string_of_val_exp_eff ve1) ^ "." ^ (Ident.to_string id)
| ARRAY_ACCES(i), [ve1] ->
(string_of_val_exp_eff ve1) ^ "[" ^ (string_of_int i) ^ "]"
| ARRAY_SLICE(si_eff), [ve1] ->
(string_of_val_exp_eff ve1) ^ (string_of_slice_info_eff si_eff)
| ARRAY_SLICE(_), _ -> assert false (* todo *)
| MERGE _, _ -> assert false (* todo *)
(* | ITERATOR _, _ -> assert false (* todo *) *)
(* Cannot happen *)
| ARROW, _ -> assert false
| FBY, _ -> assert false
| CONCAT, _ -> assert false
| STRUCT_ACCESS(_), _ -> assert false
| ARRAY_ACCES(i), _ -> assert false
in
let do_not_parenthesize = function
| IDENT _,_
| Predef((Predef.ICONST_n _), _),_
| Predef((Predef.RCONST_n _), _),_
| Predef((Predef.FALSE_n), _),_
| Predef((Predef.TRUE_n), _),_
| ARRAY_ACCES _,_
| STRUCT_ACCESS _,_ -> true
| _,_ -> false
in
if
(* already parenthesized *)
( Str.string_match (Str.regexp "^(") str 0 &&
Str.string_match (Str.regexp ")$") str 0 )
||
(* ident or predef constants *)
(do_not_parenthesize (posop.it,vel))
||
!Global.one_op_per_equation
then
str
else
("(" ^ str ^ ")")
and string_of_val_exp_eff ve = string_of_val_exp_eff_core ve.core
and string_of_val_exp_eff_core ve_core =
match ve_core with
| CallByPosEff (by_pos_op_eff, OperEff vel) ->
(string_of_by_pos_op_eff by_pos_op_eff vel)
| CallByNameEff(by_name_op_eff, fl) ->
(match by_name_op_eff.it with
| STRUCT (pn,idref) -> prefix ^ (
match Ident.pack_of_idref idref with
| Some pn -> Ident.string_of_idref idref
| None ->
let idref = Ident.make_idref pn (Ident.of_idref idref) in
Ident.string_of_idref idref
)
| STRUCT_anonymous -> "") ^
"{" ^ (String.concat ";"
(List.map
(fun (id,veff) ->
let str = string_of_val_exp_eff veff in
(Ident.to_string id.it) ^ "=" ^
(if is_a_tuple veff then ("("^ str^")") else str)
)
fl)) ^
"}"
and wrap_long_line str =
if String.length str < 75 then str else
let str_list = Str.split (Str.regexp " ") str in
let new_str, reste =
List.fold_left
(fun (accl, acc_str) str ->
let new_acc_str = acc_str ^ " " ^ str in
if
String.length new_acc_str > 75
then
(accl ^ acc_str ^ "\n\t" , str)
else
(accl, new_acc_str)
)
("","")
str_list
in
new_str ^ " " ^ reste
and string_of_eq_info_eff (leff_list, vee) =
let str = string_of_val_exp_eff vee in
wrap_long_line (
(string_of_leff_list leff_list) ^ " = " ^
(if is_a_tuple vee then ("("^ str^")") else str) ^ ";")
and (string_of_assert : Eff.val_exp srcflagged -> string ) =
fun eq_eff ->
wrap_long_line (
"assert(" ^ string_of_val_exp_eff eq_eff.it ^ ");")
and (string_of_eq : Eff.eq_info srcflagged -> string) =
fun eq_eff ->
string_of_eq_info_eff eq_eff.it
and wrap_long_profile str =
if String.length str < 75 then str else
"\n"^(
Str.global_replace (Str.regexp "returns") "\nreturns"
(Str.global_replace (Str.regexp "(") "(\n\t"
(Str.global_replace (Str.regexp "; ") ";\n\t" str)))
and (profile_of_node_exp_eff: Eff.node_exp -> string) =
fun neff ->
("(" ^ (string_of_type_decl_list neff.inlist_eff "; ") ^ ") returns (" ^
(string_of_type_decl_list neff.outlist_eff "; ") ^ ");\n")
and (string_of_node_def : Eff.node_def -> string list) =
function
| ExternEff
| AbstractEff _ -> []
| BodyEff node_body_eff ->
List.append
(List.map string_of_assert node_body_eff.asserts_eff)
(List.map string_of_eq node_body_eff.eqs_eff)
(* exported *)
and (type_decl: Ident.long -> Eff.type_ -> string) =
fun tname teff ->
"type " ^ prefix ^ (dump_long tname) ^
(match teff with
| External_type_eff (_)
| Abstract_type_eff(_,External_type_eff (_)) -> ";\n"
| _ -> " = " ^ (string_def_of_type_eff teff) ^ ";\n"
)
(* exported *)
and (const_decl: Ident.long -> Eff.const -> string) =
fun tname ceff ->
let begin_str = ("const " ^ (dump_long tname)) in
let end_str = (string_of_const_eff ceff) ^ ";\n" in
(match ceff with
| Enum_const_eff _ ->
if !Global.expand_enums then
(begin_str ^ " = " ^ end_str)
else
(* do not print those const, because there were
introduced by the compiler *)
""
| Extern_const_eff _
| Abstract_const_eff _ ->
begin_str ^ ":" ^ (string_of_type_eff (Eff.type_of_const ceff)) ^
(* (if !Global.ec then ".\n" else *)
(";\n")
| Struct_const_eff _
| Array_const_eff _
| Bool_const_eff _
| Int_const_eff _
| Real_const_eff _ -> begin_str ^ " = " ^ end_str
)
(* exported *)
and (node_of_node_exp_eff: Eff.node_exp -> string) =
fun neff ->
wrap_long_profile (
(if
neff.def_eff = ExternEff
&& not (!Global.lv4) (* no extern kwd in v4... *)
then "extern "
else "") ^
(if !Global.lv4 then
(* node and function does not have the same meaning in v4... *)
(if neff.def_eff = ExternEff then "function " else "node ")
else
(if neff.has_mem_eff then "node " else "function ")
) ^
(string_of_node_key_rec neff.node_key_eff) ^
(profile_of_node_exp_eff neff)) ^
(match neff.def_eff with
| ExternEff -> ""
| AbstractEff _ -> ""
| BodyEff _ ->
((match neff.loclist_eff with None -> "" | Some [] -> ""
| Some l ->
"var\n " ^ (string_of_type_decl_list l ";\n ") ^ ";\n") ^
"let\n " ^
(String.concat "\n " (string_of_node_def neff.def_eff)) ^
"\ntel\n-- end of node " ^
(string_of_node_key_rec neff.node_key_eff) ^ "\n"
)
)
and (string_of_clock_exp : SyntaxTreeCore.clock_exp -> string) =
function
| SyntaxTreeCore.Base -> ""
| SyntaxTreeCore.NamedClock clk ->
" when " ^ (string_of_ident_clk clk.it)
and (string_of_ident_clk : Ident.clk -> string) =
fun clk ->
let (cc,v) = clk in
let clk_exp_str =
match Ident.string_of_idref cc with
| "True" -> (Ident.to_string v)
| "False" -> "not " ^ (Ident.to_string v)
| _ ->
if !Global.lv4 then
raise (Errors.Global_error
("*** Cannot generate V4 style Lustre for programs with enumerated "^
"clocks (yet), sorry."))
else
Ident.string_of_clk clk
in
clk_exp_str
(* exported *)
and string_of_clock2 (ck : Eff.clock) =
match ck with
| BaseEff -> " on base"
| On(clk_exp,ceff) ->
let clk_exp_str = string_of_ident_clk clk_exp in
" on " ^ clk_exp_str ^ (string_of_clock2 ceff)
| ClockVar i -> "'a" ^ string_of_int i
and string_of_clock (ck : Eff.clock) =
match ck with
| BaseEff -> ""
| On(clk_exp,_) ->
let clk_exp_str = string_of_ident_clk clk_exp in
" when " ^ clk_exp_str
| ClockVar _ ->
"" (* it migth occur that (unused) constant remain with a clock var.
But in that case, it is ok to consider then as on the base clock.
*)
(* | ClockVar i -> "_clock_var_" ^ (string_of_int i) *)
and op2string op =
(* Une verrue pour compatible avec les outils qui mangent du ec... *)
if !Global.ec && op = Predef.INT2REAL_n then "real" else
Predef.op2string op
(*---------------------------------------------------------------------
Formatage standard des erreurs de compil
----------------------------------------------------------------------*)
let node_error_string lxm nkey = (
Printf.sprintf "While checking %s" (string_of_node_key_iter lxm nkey)
)
(*---------------------------------------------------------------------
Message d'erreur (associ� � un lexeme) sur stderr
----------------------------------------------------------------------*)
let print_compile_node_error nkey lxm msg = (
Printf.eprintf "%s\n" (node_error_string lxm nkey);
Errors.print_compile_error lxm msg ;
flush stderr
)
let print_global_node_error lxm nkey msg = (
Printf.eprintf "%s\n" (node_error_string lxm nkey);
Errors.print_global_error msg ;
flush stderr
)
(* debug *)
let dump_local_env e = (
let pt i t = Printf.printf "type %s = %s\n" i (string_of_type_eff t) in
Hashtbl.iter pt e.lenv_types;
let pc i t = Printf.printf "const %s = %s\n" i (string_of_const_eff t) in
Hashtbl.iter pc e.lenv_const;
)