(* Time-stamp: <modified the 03/03/2015 (at 14:26) by Erwan Jahier> *)
open Lv6errors
open Printf
open Lxm
open Lic
open List
open Lv6MainArgs
(* XXX changer le nom de cette fonction *)
let (dump_long : Lv6Id.long -> string) = fun x ->
if global_opt.kcg then
Lv6Id.no_pack_string_of_long x
else
if global_opt.no_prefix then
Lv6Id.no_pack_string_of_long x
else
Lv6Id.string_of_long x
(* fun id -> *)
(* let str = Lv6Id.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 }, [ve]) -> is_a_tuple ve
| CallByPosLic ({ it = TUPLE }, vel) -> List.length vel > 1
| _ -> false
(******************************************************************************)
let string_of_ident x =
if global_opt.no_prefix
then Lv6Id.no_pack_string_of_long x
else Lv6Id.string_of_long2 x
let rec string_of_const_eff =
function
| Bool_const_eff true -> "true"
| Bool_const_eff false -> "false"
| Int_const_eff i -> (sprintf "%s" 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,Enum_type_eff(_,ll)) -> Lic.enum_to_string s ll
| Enum_const_eff (_) -> assert false
| Struct_const_eff (fl, t) -> (
let string_of_field =
function (id, veff) ->
(Lv6Id.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 (s:Bytes.t) = Bytes.of_string s in
let (res:Bytes.t)= Bytes.copy s in
let cpt = ref 0 in
let f c = (
let _ = match c with
| '-' -> (Bytes.set res !cpt 'm')
| '+' -> (Bytes.set res !cpt 'p')
| '.' -> (Bytes.set res !cpt 'd')
| _ -> ()
in incr cpt
) in
Bytes.iter f s;
Bytes.to_string 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,_) -> Lv6Id.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 ^ (Lv6Id.to_string id) ^ " : " ^
(string_of_type_eff type_eff) ^
match const_eff_opt with
None -> ""
| Some ce -> " = " ^ (string_of_const_eff ce)
in
if global_opt.kcg then
(List.fold_left (f ", ") (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
else
"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 = function
| Bool_type_eff -> "bool"
| Int_type_eff -> "int"
| Real_type_eff -> "real"
| External_type_eff (name) -> (string_of_ident name)
| Abstract_type_eff (name, t) -> (string_of_ident name)
| Enum_type_eff (name, _) ->
(match global_opt.Lv6MainArgs.expand_enums with
| AsEnum | AsConst -> string_of_ident name
| AsInt ->if global_opt.kcg then dump_long name else "int"
)
| Array_type_eff (ty, sz) ->
Printf.sprintf "%s^%d" (string_of_type_eff ty) sz
| Struct_type_eff (name, _) -> (if global_opt.kcg then dump_long name else string_of_ident name)
| TypeVar Any -> "any"
| (TypeVar AnyNum) -> "anynum"
and string_of_type_list = function
| [] -> ""
| [x] -> string_of_type_eff x
| l -> String.concat " * " (List.map string_of_type_eff l)
and string_of_type_profile (i, o) =
(string_of_type_list i)^" -> "^(string_of_type_list o)
and string_of_const = function
| Bool_const_eff true -> "true"
| Bool_const_eff false -> "false"
| Int_const_eff i -> (sprintf "%s" i)
| Real_const_eff r -> r
| Extern_const_eff (s,_) -> (string_of_ident s)
| Abstract_const_eff (s,t,v,_) -> (string_of_ident s)
| Enum_const_eff (s,Enum_type_eff(_,ll)) -> (string_of_int (Lv6util.pos_in_list 0 s ll))
| Enum_const_eff _ -> assert false
| Struct_const_eff (fl, t) ->
let string_of_field (id, veff) =
(Lv6Id.to_string id)^" = "^ (string_of_const veff)
in
Printf.sprintf "%s{%s}"
(string_of_type_eff t)
(String.concat "; " (List.map string_of_field fl))
| Array_const_eff (ctab, t) ->
Printf.sprintf "[%s]"
(String.concat ", " (List.map string_of_const ctab))
| Tuple_const_eff cl ->
Printf.sprintf "(%s)"
(String.concat ", " (List.map string_of_const cl))
and string_of_var_info x =
(AstCore.string_of_var_nature x.var_nature_eff) ^ " " ^
(Lv6Id.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)^
(string_of_clock (snd x.var_clock_eff)^"("^ (Lv6Id.to_string (fst x.var_clock_eff)) ^","^
(string_of_int x.var_number_eff)^")")
and string_of_var_list vl = String.concat " ; " (List.map string_of_var_info vl)
and string_of_node_key = function
| (ik, []) ->
(string_of_ident ik)
| (ik, sargs) -> Printf.sprintf "%s<<%s>>"
(string_of_ident ik)
(String.concat ", " (List.map string_of_static_arg sargs))
and string_of_static_arg = function
| ConstStaticArgLic(id, ceff) -> Printf.sprintf "const %s = %s" id (string_of_const ceff)
| TypeStaticArgLic (id, teff) -> Printf.sprintf "type %s = %s" id (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
| NodeStaticArgLic (id, nk) ->
Printf.sprintf "node %s = %s" id (string_of_node_key nk)
and string_of_type_var tv = string_of_type_eff (TypeVar tv)
and string_of_type_matches pm =
let sotm (tv,t) = Printf.sprintf "%s <- %s"
(string_of_type_var tv) (string_of_type_eff t)
in
String.concat ", " (List.map sotm pm)
(* for printing recursive node *)
and string_of_node_key_rec (no_prefix:bool) (nkey: node_key) =
match nkey with
| (ik, []) ->
if no_prefix
then Lv6Id.no_pack_string_of_long ik
else Lv6Id.string_of_long ik
| (ik, salst) ->
let astrings = List.map static_arg2string_bis salst in
let name = sprintf "%s_%s" (Lv6Id.no_pack_string_of_long ik) (String.concat "_" astrings) in
(FreshName.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>>" (Lv6Id.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>>" (Lv6Id.string_of_long ik) (String.concat ", " astrings)
(* 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" (Lv6Id.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 global_opt.no_prefix (long,sargs)
(* sprintf "%s" (dump_long long) *)
and (string_of_var_info_eff: Lic.var_info -> string) =
fun x ->
(Lv6Id.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 =
(Lv6Id.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
if global_opt.ec then
if clk_str = "" then vt_str
else "("^vt_str ^")"^ clk_str
else 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,_) -> Lv6Id.to_string vi_eff.var_name_eff
| LeftFieldLic(leff,id,_) -> (string_of_leff leff) ^ "." ^ (Lv6Id.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 (array_of_size_one : Lic.val_exp -> bool) =
function
| {ve_typ= [Array_type_eff(Bool_type_eff, size)] } -> size = 1
| {ve_typ= [_] } -> true
| _ -> false
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
| CONST c,_ -> string_of_const_eff c
| CALL ({it=("Lustre","not"),[]}), [ve1]
| PREDEF_CALL ({it=("Lustre","not"),[]}), [ve1] ->
((op2string AstPredef.NOT_n) ^ " " ^
(if is_a_tuple ve1 then (tuple_par [ve1]) else sov ve1))
| CALL ({it=("Lustre","diese"),[]}), [ve1]
| PREDEF_CALL ({it=("Lustre","diese"),[]}), [ve1] ->
if global_opt.lv4 && array_of_size_one ve1
then sov ve1 (* lv4 does no accept to apply # on One var only! *)
else
(("#") ^ (tuple_par [ve1]))
| CALL ({it=("Lustre","nor"),[]}), [ve1]
| PREDEF_CALL ({it=("Lustre","nor"),[]}), [ve1] ->
(("nor") ^ (tuple_par [ve1]))
| CALL ({it=("Lustre","if"),[]}), [ve1; ve2; ve3]
| PREDEF_CALL ({it=("Lustre","if"),[]}), [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
| CALL(op), vel
| PREDEF_CALL(op), vel -> (
if AstPredef.is_a_predef_op (snd(fst op.it)) then
let op_str = snd (fst op.it) in
let op_short_str = AstPredef.op2string (AstPredef.string_to_op op_str) in
if AstPredef.is_infix (AstPredef.string_to_op op_str) then (
match vel with
| [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " " ^ op_short_str ^
" " ^ (string_of_val_exp_eff ve2)
| _ -> assert false
)
else
(op_short_str ^
(match op_str with
| "not" | "true" | "false" -> tuple vel
| _ -> tuple_par vel
)
)
else
let nk = op.it in
if global_opt.lv4 then
((string_of_node_key nk) ^ (tuple_par vel))
else
((string_of_node_key_rec global_opt.no_prefix nk) ^ (tuple_par vel))
)
| CONST_REF idl, _ -> dump_long idl
| VAR_REF id, _ -> id
| PRE, _ -> "pre " ^ (tuple_par vel)
| ARROW, [ve1; ve2] -> (* if global_opt.kcg then (
"fby(" ^
(if is_a_tuple ve2 then tuple_par [ve2] else string_of_val_exp_eff ve2)
^ ";1;" ^
(if is_a_tuple ve2 then tuple_par [ve1] else string_of_val_exp_eff ve1) ^ ")"
)
else( *)
(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] ->
(* dead code ? *)
if global_opt.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 global_opt.kcg then (
"fby(" ^
(if is_a_tuple ve2 then tuple_par [ve2] else string_of_val_exp_eff ve2)
^ ";1;" ^
(if is_a_tuple ve2 then tuple_par [ve1] else string_of_val_exp_eff ve1) ^ ")"
)
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 clk)
| CURRENT Some _,_ -> "current " ^ tuple_par (if global_opt.ec then List.tl vel else vel)
| CURRENT None,_ -> "current " ^ tuple_par vel
| TUPLE,_ -> (tuple vel)
| 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)
| HAT (i), _ -> assert false
| ARRAY, vel -> tuple_square vel
| STRUCT_ACCESS(id), [ve1] ->
(string_of_val_exp_eff ve1) ^ "." ^ (Lv6Id.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({it=("Lustre","true"),[]}),_
| PREDEF_CALL({it=("Lustre","false"),[]}),_
| 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_opt.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, vel) ->
(* ICI : on pourrait afficher en commentaire l'�ventuel type_matches ? *)
(string_of_by_pos_op_eff by_pos_op_eff vel)
| Merge (ve, [({it=Bool_const_eff true }, ct); ({it=Bool_const_eff false}, cf)])
| Merge (ve, [({it=Bool_const_eff false}, cf); ({it=Bool_const_eff true}, ct)]) ->
if global_opt.lv4 then (
"if " ^ (string_of_val_exp_eff ve) ^ " then current (" ^
(string_of_val_exp_eff ct) ^ ") else current (" ^
(string_of_val_exp_eff cf) ^")"
) else (
if global_opt.kcg then (
"merge ( " ^ (string_of_val_exp_eff ve) ^ ";" ^
(string_of_val_exp_eff ct) ^ "when " ^(string_of_val_exp_eff ve) ^ ";" ^
(string_of_val_exp_eff cf) ^ "when not " ^ (string_of_val_exp_eff ve) ^ ")"
) else (
"merge " ^ (string_of_val_exp_eff ve) ^ " (true -> " ^
(string_of_val_exp_eff ct) ^ ") (false -> "^ (string_of_val_exp_eff cf) ^")"
)
)
| Merge (ve, cl) -> (
"merge " ^ (string_of_val_exp_eff ve) ^ " " ^
(String.concat " "
(List.map
(fun (id,ve) -> "( "^(string_of_const_eff id.it) ^ " -> " ^
(string_of_val_exp_eff ve)^" )")
cl
)
)
)
| CallByNameLic(by_name_op_eff, fl) ->
(match by_name_op_eff.it with
| STRUCT (long) -> (Lv6Id.string_of_long long)
| STRUCT_with (long, _dft) -> (Lv6Id.string_of_long long)
| STRUCT_anonymous -> ""
) ^ (
"{" ^ (String.concat ";"
(List.map
(fun (id,veff) ->
let str = string_of_val_exp_eff veff in
(Lv6Id.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: Lv6Id.long -> Lic.type_ -> string) =
fun tname teff -> if global_opt.kcg then
match teff with
| Enum_type_eff (_) ->
"type " ^ (dump_long tname) ^ " = " ^ (string_def_of_type_eff teff) ^ ";\n"
| External_type_eff (_)
| Abstract_type_eff(_,External_type_eff (_)) -> "type imported " ^ (dump_long tname) ^ ";\n"
| _ -> "type " ^ (dump_long tname) ^ " = " ^ (string_def_of_type_eff teff) ^ ";\n"
else
"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: Lv6Id.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_opt.ec then ".\n" else *)
(";\n")
| Struct_const_eff _
| Array_const_eff _
| Bool_const_eff _
| Int_const_eff _
| Real_const_eff _ -> if global_opt.kcg then begin_str ^ ":" ^ (string_of_type_eff (Lic.type_of_const ceff)) ^ " = " ^ end_str
else 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.is_safe_eff then "" else "unsafe "
)^(
if neff.def_eff = ExternLic && not (global_opt.lv4) && not (global_opt.kcg)
(* no extern kwd in v4 and in "scade"... *)
then "extern " else ""
)^(
if global_opt.lv4 || global_opt.kcg then (
(* node and function does not have the same meaning in scade and in lv4... *)
if neff.def_eff = ExternLic then "function " else "node "
) else (
if neff.has_mem_eff then "node " else "function "
)
)^(if global_opt.kcg then
if neff.def_eff = ExternLic
then "imported " else ""
else ""
)^(
if global_opt.kcg then
string_of_node_key_rec (not global_opt.no_prefix) neff.node_key_eff
else
string_of_node_key_rec global_opt.no_prefix neff.node_key_eff
)^(
profile_of_node_exp_eff neff
)
)^
(
match neff.def_eff with
| ExternLic -> ";\n"
| MetaOpLic -> (
(* on �crit juste un alias *)
" = "^
(string_of_node_key_def neff.node_key_eff)^
(";\n")
)
| AbstractLic _ -> "; \n"
| BodyLic _ -> (
(if global_opt.kcg then "\n" else ";\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 (not global_opt.no_prefix) 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 : Lv6Id.clk -> string) =
fun clk ->
let (cc,v) = clk in
let clk_exp_str =
match cc with
| "Lustre","true" -> (Lv6Id.to_string v)
| "Lustre","false" -> "not " ^ (Lv6Id.to_string v)
| _ ->
(* if global_opt.lv4 || global_opt.ec then *)
(* raise (Lv6errors.Global_error *)
(* ("Cannot generate V4 style Lustre for programs with enumerated "^ *)
(* "clocks (yet), sorry.")) *)
(* else *)
Lv6Id.string_of_clk clk
in
clk_exp_str
(* exported *)
and string_of_clock2 (ck : Lic.clock) =
match ck with
| BaseLic -> " on base"
| On((cc,cv,_),ceff) ->
let clk_exp_str = string_of_ident_clk (cc,cv) 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((cc,cv,_),_) ->
let clk_exp_str = string_of_ident_clk (cc,cv) 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 �tre compatible avec les outils qui mangent du ec... *)
if global_opt.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);
Lv6errors.print_compile_error lxm msg ;
flush stderr
)
let print_global_node_error lxm nkey msg = (
Printf.eprintf "%s\n" (node_error_string lxm nkey);
Lv6errors.print_global_error msg ;
flush stderr
)