(** Time-stamp: <modified the 02/09/2008 (at 10:49) by Erwan Jahier> *)
open Printf
open Lxm
open Eff
let (long : Ident.long -> string) = Ident.string_of_long
(* fun id -> *)
(* let str = Ident.string_of_long id in *)
(* Str.global_replace (Str.regexp "::") "__" str *)
let type_alias_table = Hashtbl.create 0
(******************************************************************************)
(* exported *)
type tab_elt =
| OpProfile of Eff.type_ list * Eff.type_ list
| Subst of Eff.type_
let (polymorph_op_tab: (Lxm.t, tab_elt) Hashtbl.t) = Hashtbl.create 0
let (tabulate_poly_op : Lxm.t -> tab_elt -> unit) =
fun key value -> Hashtbl.replace polymorph_op_tab key value
let (poly_op_mem : Lxm.t -> bool) =
fun key -> Hashtbl.mem polymorph_op_tab key
let (poly_op_find : Lxm.t -> tab_elt option) =
fun x ->
try Some (Hashtbl.find polymorph_op_tab x)
with _ -> None
let last_poly_var = ref Int_type_eff
(** Un-nesting iterator calls.
The idea is the following: each time a nested iterator call
(map<<map<<n,3>>,4>>) is encountered, we create a fresh alias
name (create_alias_name) ad we add it in the node_alias_tbl. At
the end of the compilation, LicDump.dump_node_alias is called,
which prints the definition of those node aliases.
For example, the expression "map<<map<<n,3>>,4>>" is printed like this:
"map<<_node_alias1, 4>>"
and later, the node alias is defined:
node _node_alias1(x:int) returns(y:int); let y = map<<n,3>>(x); tel;
*)
(* This table associates to node its definition plus a flag indicating if that
node has been generated. *)
type node_profile = Eff.type_ list * Eff.type_ list
let (node_alias_tbl : (string, Eff.node_exp * tab_elt option * bool) Hashtbl.t) =
Hashtbl.create 0
let alias_fresh_var_cpt = ref 0
let create_alias_name long =
incr alias_fresh_var_cpt;
("_node_alias_" ^ (string_of_int !alias_fresh_var_cpt)
^ "_" ^ (Ident.string_of_long long))
(******************************************************************************)
(* 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 -> sprintf "%f" r
| Extern_const_eff (s,t,vopt) -> (long s) ^ (string_of_const_eff_opt vopt)
| Enum_const_eff (s,t) -> (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 = Array.to_list(Array.map string_of_const_eff ctab) in
"["^(String.concat ", " vl)^"]"
)
)
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 -> long i
| Enum_type_eff (i, sl) ->
assert (sl <>[]);
let f sep acc s = acc ^ sep ^ (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 ^ (long name)
| Enum_type_eff (name, _) -> prefix ^ (long name)
| Array_type_eff (ty, sz) -> array_alias ty sz
| Struct_type_eff (name, _) -> prefix ^ (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].
In order to avoid name clashes, we prefix all user name type by [prefix] (cf
at the top of this file).
*)
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 = "A_"^ 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 ->
p ("\ntype " ^ alias_name ^ " = " ^ (string_def_of_type_eff type_eff)^";")
)
type_alias_table
(******************************************************************************)
(* exported *)
and (dump_node_alias : out_channel -> unit) =
fun oc ->
let p = output_string oc in
let finished = ref true in
let f alias (node, np, dumped) =
let _ =
match np with
| Some(Subst(t)) -> last_poly_var := t
| Some(OpProfile(_)) | None -> ()
in
let get_name_and_type_string var =
let t = subst_type !last_poly_var var.var_type_eff in
(Ident.to_string var.var_name_eff) ^ ":" ^ (string_of_type_eff t)
in
let inlist = List.map get_name_and_type_string node.inlist_eff
and outlist = List.map get_name_and_type_string node.outlist_eff
in
let profile = ("("^(String.concat "; " inlist)^") returns ("^
(String.concat "; " outlist)^");\n")
in
if not dumped then (
finished := false;
p "node ";
p alias;
(* p (profile_of_node_exp_eff node); *)
p profile;
p "let\n ";
p (Ident.to_string (List.hd node.outlist_eff).var_name_eff);
p " = ";
p (string_of_node_key_iter node.lxm node.node_key_eff);
p "(";
p (String.concat ","
(List.map (fun v -> Ident.to_string v.var_name_eff) node.inlist_eff));
p ")";
p ";\ntel\n";
Hashtbl.replace node_alias_tbl alias (node, np, true)
)
in
p "\n";
Hashtbl.iter f node_alias_tbl;
if not !finished then dump_node_alias oc
(******************************************************************************)
(* exported *)
and (type_eff_list_to_string : Eff.type_ list -> string) =
fun tel ->
let str_l = List.map string_of_type_eff 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)
(* for printing recursive node *)
and string_of_node_key_rec (nkey: node_key) =
match nkey with
| (ik, []) -> long ik
| (ik, salst) ->
let astrings = List.map static_arg2string_rec salst in
sprintf "%s_%s" (long ik) (String.concat "_" astrings)
(* for printing iterators *)
and string_of_node_key_iter lxm (nkey: node_key) =
match nkey with
| (ik, []) -> long ik
| (ik, salst) ->
let astrings = List.map (static_arg2string (Some lxm)) salst in
sprintf "%s<<%s>>" (long ik) (String.concat ", " astrings)
(* for printing recursive node *)
and static_arg2string_rec (sa : Eff.static_arg) =
match sa with
| ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
| TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
| NodeStaticArgEff (id, opeff) ->
sprintf "%s" (string_of_node_key_rec opeff.node_key_eff)
(* for printing iterators *)
and static_arg2string lxm_opt (sa : Eff.static_arg) =
match sa with
| ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
| TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
| NodeStaticArgEff (id, opeff) ->
if
(snd opeff.node_key_eff) = []
then
sprintf "%s" (string_of_node_key_iter opeff.lxm opeff.node_key_eff)
else
let np =
match lxm_opt with
| None -> None
| Some lxm -> poly_op_find lxm
in
let alias = create_alias_name (fst opeff.node_key_eff) in
Hashtbl.add node_alias_tbl alias (opeff, np, false);
sprintf "%s" alias
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 x.var_clock_eff)
and string_of_decl var_info_eff =
(Ident.to_string var_info_eff.var_name_eff) ^ ":" ^
(string_of_type_eff var_info_eff.var_type_eff) ^
(string_of_clock var_info_eff.var_clock_eff)
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 (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 lxm = posop.src in
let str =
match posop.it,vel with
| Predef (Predef.IF_n,_), [ve1; ve2; ve3] ->
" if " ^ (string_of_val_exp_eff ve1) ^
" then " ^ (string_of_val_exp_eff ve2) ^
" else " ^ (string_of_val_exp_eff ve3)
| Predef(op,sargs), vel ->
if Predef.is_infix op then (
match vel with
| [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " " ^ (Predef.op2string op) ^
" " ^ (string_of_val_exp_eff ve2)
| _ -> assert false
)
else
((Predef.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 (Some lxm)) sargs))
^ ">>" ^ (tuple_par vel)))
| CALL nee, _ -> (
if nee.it.def_eff = ExternEff then
((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
| CONST (idref,pn), _ ->
Ident.string_of_idref (
match Ident.pack_of_idref idref with
| Some _ -> idref
| None -> Ident.make_idref pn (Ident.of_idref idref)
)
| PRE, _ -> "pre " ^ (tuple vel)
| ARROW, [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " -> " ^ (string_of_val_exp_eff ve2)
| FBY, [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " fby " ^ (string_of_val_exp_eff ve2)
| WHEN clk, vel -> (tuple vel) ^ " when " ^ (string_of_val_exp_eff clk)
| CURRENT,_ -> "current " ^ (tuple 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, _ -> tuple_square vel
| STRUCT_ACCESS(id), [ve1] ->
(string_of_val_exp_eff ve1) ^ "." ^ (Ident.to_string id)
| ARRAY_ACCES(i, type_eff), [ve1] ->
(string_of_val_exp_eff ve1) ^ "[" ^ (string_of_int i) ^ "]"
| ARRAY_SLICE(si_eff, type_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, type_eff), _ -> assert false
in
let do_not_parenthesize = function
| CONST _,_
| 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 = function
| 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) ->
(Ident.to_string id.it) ^ "=" ^ (string_of_val_exp_eff veff)
)
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) =
wrap_long_line (
(string_of_leff_list leff_list) ^ " = " ^ (string_of_val_exp_eff vee) ^ ";")
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 ^ (long tname) ^
(match teff with
| External_type_eff _ -> ";\n"
| _ -> " = " ^ (string_def_of_type_eff teff) ^ ";\n"
)
(* exported *)
and (const_decl: Ident.long -> Eff.const -> string) =
fun tname ceff ->
let str = "const " ^ (long tname) in
(match ceff with
| Extern_const_eff _ ->
str^":" ^ (string_of_type_eff (Eff.type_of_const ceff))^ ";\n"
| Enum_const_eff _ -> "" (* do not print those const *)
| Struct_const_eff _ -> assert false
| Array_const_eff _
| Bool_const_eff _
| Int_const_eff _
| Real_const_eff _ -> str^" = " ^ (string_of_const_eff ceff)^ ";\n"
)
(* exported *)
and (node_of_node_exp_eff: Eff.node_exp -> string) =
fun neff ->
wrap_long_profile (
(if neff.def_eff = ExternEff then "extern " 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"
)
)
(* exported *)
and string_of_clock2 (ck : Eff.clock) =
let rec string_of_clock2_aux ck =
(* to avoid printing the first level var name *)
match ck with
| BaseEff -> " on base"
| On(veff,ceff) ->" on " ^ (Ident.to_string veff) ^
(string_of_clock2_aux ceff)
| ClockVar i -> "'a" ^ string_of_int i
in
match ck with
| BaseEff -> " on base"
| On(_,ceff) -> (string_of_clock2_aux ceff)
| ClockVar i -> "'a" ^ string_of_int i
and string_of_clock (ck : Eff.clock) =
match ck with
| BaseEff -> ""
| On(_,BaseEff) -> ""
| On(v,On(id,_)) ->" when " ^ (Ident.to_string id)
(* | On(v,ClockVar i) -> " when _clock_var_"^ (string_of_int i) *)
(* | ClockVar i -> "_clock_var_" ^ (string_of_int i) *)
| _ -> assert false
and string_of_clock_list cl =
"(" ^ (String.concat ", " (List.map string_of_clock cl)) ^ ")"
(*---------------------------------------------------------------------
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
)