licDump.ml

(* Time-stamp: <modified the 12/02/2013 (at 18:03) 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 string_of_ident x =
   if !Global.no_prefix
   then Ident.no_pack_string_of_long x
   else Ident.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 "%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  = 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, _) -> (string_of_ident name)
  | Array_type_eff (ty, sz) ->
    Printf.sprintf "%s^%d" (string_of_type_eff ty) sz
  | Struct_type_eff (name, _) -> (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 "%d" 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,_) -> (string_of_ident s)
  | Struct_const_eff (fl, t) -> 
    let string_of_field (id, veff) =
      (Ident.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) ^ " " ^
    (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)^
    (string_of_clock (snd x.var_clock_eff)^"("^ (Ident.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 (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)

(* 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
     if !Global.ec then vt_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,_) -> 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), 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) ^
                (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 
                )
            )
        | (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)
        | 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, [({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.lv4 then (
        "if " ^ (Ident.to_string ve.it) ^ " then current (" ^
          (string_of_val_exp_eff ct) ^ ") else current (" ^ 
          (string_of_val_exp_eff cf) ^")" 
      ) else  (
      "merge " ^ (Ident.to_string ve.it) ^ " (true -> " ^
        (string_of_val_exp_eff ct) ^ ") (false -> "^  (string_of_val_exp_eff cf) ^")"
    )
    | Merge (ve, cl) -> (
      "merge " ^ (Ident.to_string ve.it) ^ " " ^
        (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, _dft_opt) -> (Ident.string_of_long long)
        | 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
)