-
Erwan Jahier authored
Also, force the merge to operate over an ident rather than on any val_exp.
Erwan Jahier authoredAlso, force the merge to operate over an ident rather than on any val_exp.
licDump.ml 24.71 KiB
(* Time-stamp: <modified the 01/02/2013 (at 08:27) by Erwan Jahier> *)
open Errors
open Printf
open Lxm
open Lic
open List
(* XXX changer le nom de cette fonction *)
let (dump_long : Ident.long -> string) = fun x ->
if !Global.no_prefix 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 (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 (e:Lic.val_exp) : bool =
match e.ve_core with
| CallByPosLic ({ it = TUPLE }, OperLic [ve]) -> is_a_tuple ve
| CallByPosLic ({ it = TUPLE }, OperLic vel) -> List.length vel > 1
| _ -> false
(******************************************************************************)
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) -> (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)^"]"
)
| Tuple_const_eff cl -> (
string_of_const_eff_list cl
)
and string_of_const_eff_list =
function
| [c] -> string_of_const_eff c
| cl -> "(" ^ (String.concat ", " (List.map string_of_const_eff cl)) ^ ")"
(* modify numbers notations in such a way that they
become "valid" identifiers. Policy:
- minus (-) becomes "m"
- plus (+) becomes "p"
- dot (d) becomes "d"
*)
and correct_num_string s =
let res = String.copy s in
let cpt = ref 0 in
let f c = (
let _ = match c with
| '-' -> (res.[!cpt] <- 'm')
| '+' -> (res.[!cpt] <- 'p')
| '.' -> (res.[!cpt] <- 'd')
| _ -> ()
in incr cpt
) in
String.iter f s;
res
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
| Int_const_eff _
| Real_const_eff _ ->
correct_num_string(string_of_const_eff c)
| Bool_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,_) -> Ident.no_pack_string_of_long sn
| _ -> assert false
)
| Array_const_eff (ctab, t) -> string_of_type_eff t
| Tuple_const_eff cl -> string_ident_of_const_eff_list cl
and string_ident_of_const_eff_list cl =
match cl with
| [c] -> string_ident_of_const_eff c
| _ -> "" ^ (String.concat "_" (List.map string_ident_of_const_eff cl)) ^ ""
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
| Enum_type_eff (i, sl) ->
assert (sl <>[]);
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)) ^ "}"
| TypeVar Any -> "a"
| TypeVar AnyNum -> "o"
(* exported *)
(* On prend le meme que Lic *)
and string_of_type_eff = Lic.string_of_type
(* 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_bis salst in
let name = sprintf "%s_%s" (Ident.no_pack_string_of_long ik) (String.concat "_" astrings) in
(LicName.node_key nkey name)
(* for printing iterators *)
and string_of_node_key_iter (nkey: node_key) =
match nkey with
| (ik, []) -> dump_long ik
| (ik, salst) ->
let astrings = List.map (static_arg2string) salst in
sprintf "%s<<%s>>" (Ident.string_of_long ik) (String.concat ", " astrings)
(* pour ecrire UN NIVEAU d'arg statique (cf. LicMetaOp *)
and string_of_node_key_def (nkey: node_key) =
match nkey with
| (ik, []) -> dump_long ik
| (ik, salst) ->
let astrings = List.map (string_of_static_arg) salst in
sprintf "%s<<%s>>" (Ident.string_of_long ik) (String.concat ", " astrings)
and string_of_static_arg (sa : Lic.static_arg) =
match sa with
| ConstStaticArgLic (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
| TypeStaticArgLic (id, teff) -> sprintf "%s" (string_of_type_eff teff)
| NodeStaticArgLic (id, nk) -> string_of_node_key_rec nk
(* for inventing a name to parametrized nodes *)
and static_arg2string_bis (sa : Lic.static_arg) =
match sa with
| ConstStaticArgLic (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgLic (id, teff) -> sprintf "%s" (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long, _sargs), _, _), _) -> *)
| NodeStaticArgLic (id, (long,_)) ->
sprintf "%s" (Ident.no_pack_string_of_long long)
(* for printing recursive node and iterators *)
and static_arg2string (sa : Lic.static_arg) =
match sa with
| ConstStaticArgLic (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgLic (id, teff) -> sprintf "%s" (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
| NodeStaticArgLic (id, (long,sargs)) ->
string_of_node_key_iter (long,sargs)
(* sprintf "%s" (dump_long long) *)
and static_arg2string_rec (sa : Lic.static_arg) =
match sa with
| ConstStaticArgLic (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgLic (id, teff) -> sprintf "%s" (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
| NodeStaticArgLic (id, (long,sargs)) -> string_of_node_key_rec (long,sargs)
(* sprintf "%s" (dump_long long) *)
and (string_of_var_info_eff: Lic.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: Lic.var_info -> string) =
fun x -> (string_of_type_eff 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
BaseLic | ClockVar _ -> false
| _ -> true)
then "(" ^ vt_str ^ ")"
else vt_str
in
vt_str ^ clk_str
and (string_of_type_decl_list : Lic.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 : Lic.left -> string) =
function
| LeftVarLic (vi_eff,_) -> Ident.to_string vi_eff.var_name_eff
| LeftFieldLic(leff,id,_) -> (string_of_leff leff) ^ "." ^ (Ident.to_string id)
| LeftArrayLic(leff,i,_) -> (string_of_leff leff) ^ "[" ^ (string_of_int i) ^ "]"
| LeftSliceLic(leff,si,_) -> (string_of_leff leff) ^ (string_of_slice_info_eff si)
and (string_of_leff_list : Lic.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: Lic.by_pos_op srcflagged -> Lic.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_CALL (AstPredef.NOT_n,_), [ve1] ->
((op2string AstPredef.NOT_n) ^ " " ^
(if is_a_tuple ve1 then (tuple_par [ve1]) else sov ve1))
| PREDEF_CALL (AstPredef.DIESE_n,_), [ve1] ->
if !Global.lv4
then sov ve1 (* lv4 does no accept to apply # on One var only! *)
else ((op2string AstPredef.DIESE_n) ^ (tuple_par [ve1]))
| PREDEF_CALL (AstPredef.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_CALL(op,sargs), vel ->
if AstPredef.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
| AstPredef.ICONST_n _ | AstPredef.RCONST_n _ | AstPredef.NOT_n
| AstPredef.UMINUS_n | AstPredef.IUMINUS_n | AstPredef.RUMINUS_n
| AstPredef.FALSE_n | AstPredef.TRUE_n ->
tuple vel
| _ -> tuple_par vel
else
"<<" ^
(String.concat ", " (List.map (static_arg2string) sargs))
^ ">>" ^ (tuple_par vel)))
| (CALL nkl,_) -> (
let nk = nkl.it in
if !Global.lv4 then
(match nk 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 nk) ^ (tuple_par vel))
) else
((string_of_node_key_rec nk) ^ (tuple_par vel))
)
| CONST_REF idl, _ -> dump_long idl
| VAR_REF id, _ -> id
| 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 *)
(* 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
| VAR_REF _,_
| CONST_REF _,_
| PREDEF_CALL((AstPredef.ICONST_n _), _),_
| PREDEF_CALL((AstPredef.RCONST_n _), _),_
| PREDEF_CALL((AstPredef.FALSE_n), _),_
| PREDEF_CALL((AstPredef.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.ve_core
and string_of_val_exp_eff_core ve_core =
match ve_core with
| CallByPosLic (by_pos_op_eff, OperLic vel) ->
(* ICI : on pourrait afficher en commentaire l'éventuel type_matches ? *)
(string_of_by_pos_op_eff by_pos_op_eff vel)
| Merge (ve, cl) -> (
"merge " ^ (Ident.to_string ve.it) ^ " " ^
(String.concat " "
(List.map
(fun (id,ve) -> "| "^(dump_long id.it) ^ " => " ^ (string_of_val_exp_eff ve)^" ")
cl
)
)
)
| CallByNameLic(by_name_op_eff, fl) ->
(match by_name_op_eff.it with
| STRUCT (pn,idref) -> (
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 : Lic.val_exp srcflagged -> string ) =
fun eq_eff ->
wrap_long_line (
"assert(" ^ string_of_val_exp_eff eq_eff.it ^ ");")
and (string_of_eq : Lic.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: Lic.node_exp -> string) =
fun neff ->
("(" ^ (string_of_type_decl_list neff.inlist_eff "; ") ^ ") returns (" ^
(string_of_type_decl_list neff.outlist_eff "; ") ^ ")")
and (string_of_node_def : Lic.node_def -> string list) =
function
| ExternLic
| MetaOpLic _
| AbstractLic _ -> []
| BodyLic 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 -> Lic.type_ -> string) =
fun tname teff ->
"type " ^ (dump_long tname) ^
(match teff with
| Enum_type_eff (_) ->
" = " ^ (string_def_of_type_eff teff) ^ ";\n"
| External_type_eff (_)
| Abstract_type_eff(_,External_type_eff (_)) -> ";\n"
| _ -> " = " ^ (string_def_of_type_eff teff) ^ ";\n"
)
(* exported *)
and (const_decl: Ident.long -> Lic.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(id, t) -> ""
| Extern_const_eff _
| Abstract_const_eff _ ->
begin_str ^ " : " ^ (string_of_type_eff (Lic.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
| Tuple_const_eff _ -> print_internal_error "LicDump.const_decl" "should not have been called for a tuple";
assert false
)
(* exported *)
and node_of_node_exp_eff
(neff: Lic.node_exp)
: string =
wrap_long_profile (
(
if neff.def_eff = ExternLic && 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 = ExternLic 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
| ExternLic -> ";\n"
| MetaOpLic nk -> (
(* on écrit juste un alias *)
" = "^
(string_of_node_key_def nk)^
(";\n")
)
| AbstractLic _ -> ";\n"
| BodyLic _ -> (
";\n"^
(
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 : AstCore.clock_exp -> string) =
function
| AstCore.Base -> ""
| AstCore.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 : Lic.clock) =
match ck with
| BaseLic -> " 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 : Lic.clock) =
match ck with
| BaseLic -> ""
| 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 = AstPredef.INT2REAL_n then "real" else
AstPredef.op2string op
(*---------------------------------------------------------------------
Formatage standard des erreurs de compil
----------------------------------------------------------------------*)
let node_error_string lxm nkey = (
Printf.sprintf "While checking %s" (string_of_node_key_iter 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
)