licDump.ml

(* Time-stamp: <modified the 26/08/2016 (at 16:49) 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 (dump_entete : out_channel -> unit) =
 fun oc -> if global_opt.kcg then 
     (Lv6util.entete oc "/*" "*/") 
   else 
     (Lv6util.entete oc "(*" "*)")  

(******************************************************************************)    
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.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



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, el) -> 
     (match global_opt.Lv6MainArgs.expand_enums with
      | AsEnum | AsConst -> string_of_ident name
      | AsInt  -> if global_opt.kcg then dump_long name else "int"
      | AsBool -> if global_opt.kcg then dump_long name else 
                    let get_n x = (* returns the n s.t., 2^(n-1) < x <= 2^n *)
                      assert(x>0);
                      let rec f n acc = 
                        if x > acc then f (n+1) (2*acc) else n 
                      in
                      f 0 1
                    in
                    let size = get_n  (List.length el) in
                    ("bool^"^(string_of_int size))
     )
  | 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 global_opt.kcg then Lv6Id.no_pack_string_of_long ik else
                  if no_prefix 
                  then Lv6Id.no_pack_string_of_long ik 
                  else Lv6Id.string_of_long ik
  | (ik, salst) ->
     if global_opt.kcg then  ((* recursive nodes have been unfold *)
	    (*assert (List.mem ik ["map"]);*)
	    (* not yet working : 
	      - cas des noeuds itérés prédéfinis
	      - il genere des alias des noeuds que scade ne comprend pas
	     *)
	    let rec get_node sl = 
	      match sl with 
	      | [] -> assert false
	      | s::sl -> (match s with
	                  | NodeStaticArgLic  (_,nk) -> nk,sl
	                  | ConstStaticArgLic (_, _) 
	                  | TypeStaticArgLic  (_,_) -> 
		                  let n,sl = get_node sl in
		                  n, s::sl
	                 )
	    in
	    let nk, salst = get_node salst in
	    let astrings = List.map static_arg2string_kcg salst in
	    let name = sprintf "(%s %s <<%s>>)" (Lv6Id.no_pack_string_of_long ik)
	                       (string_of_node_key_rec no_prefix nk) (String.concat "," astrings) 
	    in
	    (FreshName.node_key nkey name)

     )	
     else 
       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.no_pack_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)

and static_arg2string_kcg (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,_)) -> assert false (* should not occur *)


(* 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 global_opt.kcg then
             String.concat ", " (List.map string_of_leff l) 

           else
             (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 if global_opt.kcg then
	     ("#" ^ (dump_array_no_square ve1)) *)
	    (* do later *)
	    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 _,_ -> (* transform to merge in kcg mode *) 
	    if global_opt.kcg then assert false 
	    else
	      "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) -> (
    if global_opt.lv4 then (
      let c1, cl = match cl with c1::cl -> c1,cl | [] -> assert false (*sno*) in
      let get_cond_and_then (id,ve) =
        let clk = match ve.ve_clk with
          | [On((cc,cv,Bool_type_eff),_)] -> cv
          | _ -> assert false (* SNO *)
        in
        let expr = string_of_val_exp_eff ve in
        clk, expr
      in
      let print_case c =
        let clk,expr = get_cond_and_then c in
        Printf.sprintf " if %s then current(%s) else " clk expr
      in
      let cl_str = List.map print_case cl in
      let clk1,expr1 = get_cond_and_then c1 in
      let last_case = "current("^expr1^") (*"^clk1^"*)\n" in
      let str = (String.concat "" cl_str) ^ last_case in
      str
    ) else (
    "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 "[ \t]+") 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 (
      if global_opt.kcg then "assume " ^ FreshName.local_var "A" ^ ": " ^ string_of_val_exp_eff eq_eff.it ^ ";"
      else
        "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)

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 _ ->
      if global_opt.kcg then 
	     "const imported " ^ (dump_long tname) ^ " : " ^ 
          (string_of_type_eff (Lic.type_of_const ceff)) ^ (";\n")
	   else
        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
)