(* Time-stamp: <modified the 29/08/2019 (at 15:35) by Erwan Jahier> *)
open Lxm
open AstPredef
open AstV6
open AstCore
open Format
(***********************************************************************************)
(* exported *)
let rec (op2string : AstCore.by_pos_op -> string) =
fun op ->
match op with
(* unaires *)
| Predef_n(op) -> (AstPredef.op2string op.it)
| (CALL_n ne) -> string_of_node_exp ne.it
| (PRE_n ) -> "pre"
| (CURRENT_n) -> "current"
(* binaires *)
| (ARROW_n ) -> "->"
| (WHEN_n _ce) -> "when"
| (HAT_n ) -> "^"
| (CONCAT_n ) -> "|"
| (IDENT_n idref) -> Lv6Id.string_of_idref false idref
| (FBY_n ) -> "fby"
| (WITH_n(_,_,_)) -> "with"
| (TUPLE_n ) -> assert false
| (ARRAY_n ) -> assert false
| (ARRAY_ACCES_n _ ) -> assert false
| (ARRAY_SLICE_n _sl) -> assert false
| (STRUCT_ACCESS_n _fld) -> assert false
(***********************************************************************************)
(* exported *)
and t (os: Format.formatter) (tree: AstV6.t) =
match tree with
| PRPackBody(_sl,pbody) -> packbody os pbody
| PRPack_or_models(_,_) -> assert false
and packbody (os: Format.formatter) (pkg: AstV6.packbody) =
let dump_def (d: item_ident) =
try (
(match d with
| ConstItem id -> dump_const os (Hashtbl.find pkg.pk_const_table id)
| TypeItem id -> dump_type os (Hashtbl.find pkg.pk_type_table id)
| NodeItem (id,sparams) ->
let {src = lxm ; it = ninfo } = Hashtbl.find pkg.pk_node_table id in
dump_node os {src = lxm ; it = ninfo };
fprintf os " <<@\n" ;
fprintf os "@[<b 3>@ %a@]@\n" dump_static_param_list sparams;
fprintf os ">>\n"
);
Format.fprintf os "@\n"
)
with Not_found ->
print_string ("*** unable to find a definition for " ^
(match d with
ConstItem id
| TypeItem id
| NodeItem (id,_) -> Lv6Id.to_string id
)
);
flush stdout;
assert false
in
(* Format.fprintf os "@?@[<b 0>" ; *)
List.iter dump_def pkg.pk_def_list ;
(* Format.fprintf os "@]@." *)
(*******************************)
(* dump d'une def de constante *)
(*******************************)
and dump_const (os: Format.formatter) (x: const_info srcflagged) = (
let lxm = x.src and info = x.it in
fprintf os "-- %s@\n" (Lxm.details lxm) ;
fprintf os "const %s " (Lxm.str lxm) ;
dump_const_def os info ;
fprintf os " ;@\n" ;
)
and dump_const_def (os: Format.formatter) (info: const_info) = (
match info with
| ExternalConst (_id, ty,None) -> fprintf os ": %a " dump_type_exp ty
| ExternalConst (_id, ty, Some v) ->
fprintf os ": %a = %a" dump_type_exp ty dump_val_exp v
| DefinedConst (_id, None, exp) -> fprintf os "= %a " dump_val_exp exp
| DefinedConst (_id, Some ty, exp) ->
fprintf os ": %a = %a " dump_type_exp ty dump_val_exp exp
| EnumConst (_id, _ty) -> fprintf os "XXX printme!"
)
(**************************)
(* dump d'une def de type *)
(**************************)
and dump_type (os: Format.formatter) (x: type_info srcflagged) = (
let lxm = x.src and info = x.it in
let id = Lxm.str lxm in
fprintf os "-- %s@\n" (Lxm.details lxm) ;
fprintf os "type %s " id ;
dump_type_def os info ;
fprintf os " ;@\n" ;
)
and dump_type_def (os: Format.formatter) (info: type_info ) = (
match info with
| ExternalType _id -> ()
| AliasedType (_id, te) -> fprintf os "= %a" dump_type_exp te
| EnumType (_id, clist) ->
(* fprintf os "= enum {@[<b 3>@,%a@,@]}" dump_id_list clist *)
fprintf os "= enum { %a}" dump_id_list clist
| StructType {st_name = _id; st_flist = fl; st_ftable = ft} ->
let filst = List.map (function id -> (Hashtbl.find ft id).it) fl in
fprintf os "= struct {@\n@[<b 3> %a@]@\n}"
dump_field_list filst
| ArrayType (_id, texp, vexp) ->
fprintf os " = %a" dump_type_exp texp;
fprintf os "^%a" dump_val_exp vexp;
)
(****************************)
(* dump d'une liste de noms *)
(****************************)
and dump_id_list (os : formatter) (idlst : Lv6Id.t srcflagged list) = (
match idlst with
[] -> ()
| h::[] -> ( fprintf os "%s" (Lv6Id.to_string h.it))
| h::t -> ( fprintf os "%s, %a" (Lv6Id.to_string h.it) dump_id_list t)
)
(*****************************)
(* dump d'une liste de field *)
(*****************************)
and dump_field_list (os: Format.formatter) (filst: field_info list) = (
match filst with
[] -> ()
| h::[] -> ( fprintf os "%a" dump_field h )
| h::t -> ( fprintf os "%a;@\n%a" dump_field h dump_field_list t)
)
and dump_field (os: Format.formatter) (finfo: field_info) = (
match finfo with
{fd_name=id; fd_type=ty; fd_value=None} -> (
fprintf os "%s : %a" (Lv6Id.to_string id) dump_type_exp ty
)
|
{fd_name=id; fd_type=ty; fd_value=Some ex} -> (
fprintf os "%s : %a = %a" (Lv6Id.to_string id)
dump_type_exp ty dump_val_exp ex
)
)
and _dump_param_list
(os: Format.formatter)
(plst: (Lv6Id.t option * type_exp) list) =
(
match plst with
[] -> ()
| h::[] -> ( fprintf os "%a" _dump_param h )
| h::t -> ( fprintf os "%a; %a" _dump_param h _dump_param_list t)
)
and _dump_param (os: Format.formatter) (p: (Lv6Id.t option * type_exp)) = (
match p with
(None, ty) -> (fprintf os "%a" dump_type_exp ty)
| (Some id, ty) -> (fprintf os "%s : %a" (Lv6Id.to_string id) dump_type_exp ty)
)
(**************************)
(* dump d'une eq. de node *)
(**************************)
and dump_item_info_list
(os: Format.formatter)
(lst: item_info srcflagged list) =
(
match lst with
[] -> ()
| h::[] -> dump_item_info os h
| h::t -> fprintf os "%a;@\n%a" dump_item_info h dump_item_info_list t
)
and dump_item_info
(os: Format.formatter)
(ie: item_info srcflagged) = (
match ie.it with
| ConstInfo ci -> dump_const os (Lxm.flagit ci ie.src)
| TypeInfo ti -> dump_type os (Lxm.flagit ti ie.src)
| NodeInfo ni -> dump_node os (Lxm.flagit ni ie.src)
)
and dump_static_param_list
(os: Format.formatter)
(lst: static_param srcflagged list) =
(
match lst with
[] -> ()
| h::[] -> dump_static_param os h
| h::t -> fprintf os "%a;@\n%a" dump_static_param h dump_static_param_list t
)
and dump_static_param
(os: Format.formatter)
(sp: static_param srcflagged) =
(
match sp.it with
| StaticParamType id -> fprintf os "type %s" (Lv6Id.to_string id)
| StaticParamConst (id, exp) -> fprintf os "const %s : %a"
(Lv6Id.to_string id) dump_type_exp exp
| StaticParamNode (id, ins, outs, has_mem,is_safe) -> (
fprintf os "%s%s %s(@,%a@,)returns(@,%a@,)"
(if is_safe then "" else "unsafe ")
(if has_mem then "node" else "function")
(Lv6Id.to_string id)
dump_line_var_decl_list ins dump_line_var_decl_list outs
)
)
(**************************)
(* dump d'une def de node *)
(**************************)
and dump_node (os: Format.formatter) (x: node_info srcflagged) = (
let lxm = x.src and ninfo = x.it in
fprintf os "-- %s" (Lxm.details lxm) ;
fprintf os " (node definition)@\n" ;
fprintf os "node %s" (Lv6Id.to_string ninfo.name);
fprintf os " <<@\n" ;
fprintf os "@[<b 3>@ %a@]@\n" dump_static_param_list ninfo.static_params;
fprintf os ">>\n";
(match ninfo.vars with
| None -> ()
| Some {
inlist = inlist;
outlist = outlist;
loclist = loclist_opt;
vartable = vartab;
} ->
let get_info (id: Lv6Id.t) = (Hashtbl.find vartab id).it in
let inlst = List.map get_info inlist in
let outlst = List.map get_info outlist in
fprintf os "(@\n" ;
fprintf os "@[<b 3>@ %a@]@\n" dump_var_decl_list inlst ;
fprintf os ") returns (@\n" ;
fprintf os "@[<b 3>@ %a@]@\n" dump_var_decl_list outlst ;
fprintf os ");@\n" ;
match loclist_opt with
| None -> ()
| Some loclist ->
let loclst = List.map get_info loclist in
fprintf os "var@\n";
fprintf os "@[<b 3> %a;@]@\n" dump_var_decl_list loclst;
);
(match ninfo.def with
| Extern -> fprintf os "extern"
| Abstract -> fprintf os "abstract"
| Body body -> dump_node_body os body
| Alias {it = _nexp; src = _lxm} -> assert false
(* fprintf os " = @,%a;@\n" dump_by_pos_exp nexp *)
);
if ninfo.has_mem then () else ();
if ninfo.is_safe then () else ();
)
and dump_node_body (os: Format.formatter) (nbody: node_body) = (
fprintf os "@[<b 3>let" ;
(* les assertions *)
dump_assert_list os nbody.asserts ;
(* les equations *)
dump_eq_list os nbody.eqs ;
fprintf os "@]@\ntel" ;
)
(* d�clarations sur plusieurs lignes, indent�es ... *)
and dump_var_decl_list (os: Format.formatter) (lst: var_info list) = (
match lst with
[] -> ()
| h::[] -> ( fprintf os "%a" dump_var_decl h )
| h::t -> ( fprintf os "%a;@\n%a" dump_var_decl h dump_var_decl_list t )
)
(* d�clarations sur une ligne AVEC SOURCE ... *)
and dump_line_var_decl_list (os: Format.formatter) (lst: var_info srcflagged list) = (
match lst with
[] -> ()
| h::[] -> ( fprintf os "%a" dump_var_decl h.it )
| h::t -> ( fprintf os "%a;@,%a" dump_var_decl h.it dump_line_var_decl_list t )
)
and dump_var_decl (os: Format.formatter) (vinfo: var_info ) = (
fprintf os "%s : %a" (Lv6Id.to_string vinfo.var_name) dump_type_exp vinfo.var_type ;
(
match vinfo.var_clock with
Base -> ()
| NamedClock({it=cc,id;src=_lxm}) ->
let cc_str = Lv6Id.string_of_long false cc in
let id_str = Lv6Id.to_string id in
let clk_str =
if cc_str = "true" then id_str
else if cc_str = "false" then ("not " ^ id_str)
else (cc_str ^ "(" ^ id_str ^ ")")
in
(fprintf os " when %s" ) clk_str
)
)
(**************************)
(* dump d'un type imm�diat*)
(**************************)
and dump_type_exp (os: Format.formatter) (x: type_exp) = (
match x.it with
Bool_type_exp -> fprintf os "bool"
| Int_type_exp -> fprintf os "int"
| Real_type_exp -> fprintf os "real"
| Named_type_exp id -> fprintf os "%s" (Lv6Id.string_of_idref false id)
| Array_type_exp (te, sz) -> (
dump_type_exp os te ;
fprintf os "^" ;
dump_val_exp os sz
)
)
(**************************)
(* dump des assertions *)
(**************************)
and dump_assert_list (os: Format.formatter) (af: (val_exp srcflagged) list) = (
match af with
[] -> ()
| a :: reste -> (
Format.fprintf os "@\nassert %a;" dump_val_exp a.it ;
Format.fprintf os "%a" dump_assert_list reste
)
)
(**************************)
(* dump des equations *)
(**************************)
and dump_eq_list (os: Format.formatter) (eqfs: (eq_info srcflagged) list) = (
match eqfs with
[] -> ()
| {it=(lflst,exp); src=_lxm} :: reste -> (
Format.fprintf os "@\n%a = %a;%a"
dump_left_part_list lflst
dump_val_exp exp
dump_eq_list reste
)
)
and dump_left_part_list (os: Format.formatter) (lfts: left_part list) =
(
match lfts with
l::[] -> dump_left_part os l
| l::reste -> fprintf os "%a,@,%a" dump_left_part l dump_left_part_list reste
| _ -> assert false
)
and dump_left_part (os: Format.formatter) (lft: left_part) =
(
match lft with
LeftVar idflg -> fprintf os "%s" (Lv6Id.to_string idflg.it)
| LeftField (l, idflg) -> fprintf os "%a.%s" dump_left_part l (Lv6Id.to_string idflg.it)
| LeftArray (l, expflg) ->
fprintf os "%a[@,%a@,]" dump_left_part l dump_val_exp expflg.it
| LeftSlice (l, slcflg) ->
fprintf os "%a[@,%a@,]" dump_left_part l dump_slice_info slcflg.it
)
(**************************)
(* dump d'une expression *)
(**************************)
and dump_val_exp (os: Format.formatter) (x: val_exp) = (
match x with
| CallByPos ( {it=oper; src=_lxm} , pars ) -> dump_by_pos_exp os oper pars
| CallByName ({it=oper; src=_lxm},nm_pars) -> dump_by_name_exp os oper nm_pars
| Merge_n (id, _) -> (* finish me *)
fprintf os "merge %a (...) " dump_val_exp id.it
| Merge_bool_n({it=id;_}, t, f) ->
fprintf os "merge %a (true -> %a) (false -> %a)"
dump_val_exp id dump_val_exp t dump_val_exp f
)
and dump_val_exp_list (os : formatter) (xl: val_exp list) = (
match xl with
[] -> ()
| h::[] -> ( fprintf os "%a" dump_val_exp h )
| h::t -> ( fprintf os "%a,@,%a" dump_val_exp h dump_val_exp_list t)
)
(****************************)
(* Appels "par position" *)
(****************************)
and dump_by_pos_exp (os: Format.formatter) (oper: by_pos_op) (pars: operands) =
(
match (oper, pars) with
| (IDENT_n id,Oper []) -> dump_leaf_exp os (Lv6Id.string_of_idref false id)
| (PRE_n, Oper [p0]) -> dump_unary_exp os "pre" p0
| (CURRENT_n, Oper [p0]) -> dump_unary_exp os "current" p0
| (ARROW_n, Oper [p0;p1]) -> dump_binary_exp os "->" p0 p1
| (FBY_n, Oper [p0;p1]) -> dump_binary_exp os "fby" p0 p1
| (WHEN_n _, Oper [p0;p1]) -> dump_binary_exp os "when" p0 p1
| (Predef_n (x), _) -> (
match (x.it, pars) with
| (TRUE_n, Oper []) -> dump_leaf_exp os "true"
| (FALSE_n, Oper []) -> dump_leaf_exp os "false"
| (ICONST_n s, Oper []) -> dump_leaf_exp os (Lv6Id.to_string s)
| (RCONST_n s, Oper []) -> dump_leaf_exp os (Lv6Id.to_string s)
(* unaires *)
| (NOT_n, Oper [p0]) -> dump_unary_exp os "not" p0
| (UMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
| (RUMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
| (IUMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
| (REAL2INT_n, Oper [p0]) -> dump_unary_exp os "int" p0
| (INT2REAL_n, Oper [p0]) -> dump_unary_exp os "real" p0
(* binaires *)
| (AND_n, Oper [p0;p1]) -> dump_binary_exp os "and" p0 p1
| (OR_n, Oper [p0;p1]) -> dump_binary_exp os "or" p0 p1
| (XOR_n, Oper [p0;p1]) -> dump_binary_exp os "xor" p0 p1
| (IMPL_n, Oper [p0;p1]) -> dump_binary_exp os "=>" p0 p1
| (EQ_n, Oper [p0;p1]) -> dump_binary_exp os "=" p0 p1
| (NEQ_n, Oper [p0;p1]) -> dump_binary_exp os "<>" p0 p1
| (LT_n, Oper [p0;p1]) -> dump_binary_exp os "<" p0 p1
| (LTE_n, Oper [p0;p1]) -> dump_binary_exp os "<=" p0 p1
| (GT_n, Oper [p0;p1]) -> dump_binary_exp os ">" p0 p1
| (GTE_n, Oper [p0;p1]) -> dump_binary_exp os ">=" p0 p1
| (DIV_n, Oper [p0;p1]) -> dump_binary_exp os "div" p0 p1
| (MOD_n, Oper [p0;p1]) -> dump_binary_exp os "mod" p0 p1
| (MINUS_n, Oper [p0;p1]) -> dump_binary_exp os "-" p0 p1
| (RMINUS_n, Oper [p0;p1]) -> dump_binary_exp os "-" p0 p1
| (IMINUS_n, Oper [p0;p1]) -> dump_binary_exp os "-" p0 p1
| (PLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
| (RPLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
| (IPLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
| (SLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
| (RSLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
| (ISLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
| (TIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
| (RTIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
| (ITIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
| (IF_n, Oper [p0;p1;p2]) -> dump_ternary_exp os "if" "then" "else" p0 p1 p2
| (NOR_n, Oper pl) -> dump_nary_exp os "nor" pl
| (DIESE_n, Oper pl) -> dump_nary_exp os "#" pl
| (_,_) -> (
Lv6errors.print_internal_error "AstV6Dump.dump_by_pos_exp"
(Printf.sprintf "unexpected op '%s'" (AstPredef.op2string_long x.it));
assert false
)
)
| (HAT_n, Oper [p0;p1]) -> dump_binary_exp os "^" p0 p1
| (CONCAT_n, Oper [p0;p1]) -> dump_binary_exp os "|" p0 p1
| (WITH_n(_), Oper [p0;p1;p2]) -> dump_ternary_exp os "with" "then" "else" p0 p1 p2
| (TUPLE_n, Oper pl) -> dump_nary_exp os "" pl
| (CALL_n s, Oper pl) -> fprintf os "%a(@,%a@,)"
dump_node_exp s.it dump_val_exp_list pl
| (ARRAY_n, Oper pl) -> fprintf os "[@,%a@,]" dump_val_exp_list pl
| (ARRAY_ACCES_n ix, Oper [p0]) -> fprintf os "%a[@,%a@,]"
dump_val_exp p0 dump_val_exp ix
| (ARRAY_SLICE_n sl, Oper [p0]) -> fprintf os "%a[@,%a@,]"
dump_val_exp p0 dump_slice_info sl
| (STRUCT_ACCESS_n fld, Oper [p0]) -> fprintf os "%a.%s"
dump_val_exp p0 (Lv6Id.to_string fld)
| (FBY_n, _) -> assert false
| (STRUCT_ACCESS_n _, _) -> assert false
| (ARRAY_SLICE_n _, _) -> assert false
| (ARRAY_ACCES_n _, _) -> assert false
| (WITH_n(_), _) -> assert false
| (CONCAT_n, _) -> assert false
| (HAT_n, _) -> assert false
| (WHEN_n _, _) -> assert false
| (ARROW_n, _) -> assert false
| (CURRENT_n, _) -> assert false
| (PRE_n, _) -> assert false
| (IDENT_n _, _) -> assert false
)
(* les procs standard pour les operateurs predefs *)
and dump_leaf_exp (os : Format.formatter) (s : string) = (
fprintf os "%s" s
)
and dump_unary_exp
(os : Format.formatter)
(s : string)
(op0: val_exp)
= (
fprintf os "(@,%s %a@,)" s dump_val_exp op0
)
and dump_binary_exp
(os : Format.formatter)
(s : string)
(op0: val_exp)
(op1: val_exp)
= (
fprintf os "(@,%a %s %a@,)" dump_val_exp op0 s dump_val_exp op1
)
and dump_ternary_exp
(os : Format.formatter)
(s : string)
(t : string)
(e : string)
(op0: val_exp)
(op1: val_exp)
(op2: val_exp)
= (
fprintf os "(@,%s %a %s %a %s %a@,)"
s dump_val_exp op0 t dump_val_exp op1 e dump_val_exp op2
)
and dump_nary_exp
(os : Format.formatter)
(s: string)
(ops: val_exp list)
= (
fprintf os "%s(@,%a@,)" s dump_val_exp_list ops
)
and string_of_node_exp (id, sal) =
(Lv6Id.string_of_idref false id) ^
(if sal = [] then "" else
"<<" ^ (String.concat ", " (List.map static_arg_to_string sal)) ^ ">>")
and static_arg_to_string arg =
match arg.it with
| StaticArgLv6Id id -> Lv6Id.string_of_idref false id
| StaticArgConst _ve -> "const xxx"
| StaticArgType _te -> "type xxx"
| StaticArgNode op -> "node "^(op2string op)
and dump_node_exp os ne =
fprintf os "%s" (string_of_node_exp ne)
and _dump_static_sarg_list
(os : Format.formatter)
(lst: (static_arg srcflagged) list)
= (
match lst with
| [] -> ()
| [sa] -> fprintf os "%a" _dump_static_sarg sa.it
| sa::reste ->
fprintf os "%a, @,%a" _dump_static_sarg sa.it _dump_static_sarg_list reste
)
and _dump_static_sarg
(os : Format.formatter)
(sa: static_arg)
=
match sa with
| StaticArgLv6Id id -> fprintf os "%s" (Lv6Id.string_of_idref false id)
| StaticArgConst ve -> fprintf os "const %a" dump_val_exp ve
| StaticArgType te -> fprintf os "type %a" dump_type_exp te
| StaticArgNode op -> fprintf os "node %s" (op2string op)
and dump_static_arg_list
(os : Format.formatter)
(lst: (Lv6Id.t * static_arg srcflagged) list)
= (
match lst with
| [] -> ()
| [sa] -> fprintf os "%a" dump_static_arg sa
| sa::reste ->
fprintf os "%a, @,%a" dump_static_arg sa dump_static_arg_list reste
)
and dump_static_arg
(os : Format.formatter)
((id,sa): Lv6Id.t * static_arg srcflagged)
=
fprintf os "%s = " (Lv6Id.to_string id);
match sa.it with
| StaticArgLv6Id id -> fprintf os "%s" (Lv6Id.string_of_idref false id)
| StaticArgConst ve -> fprintf os "const %a" dump_val_exp ve
| StaticArgType te -> fprintf os "type %a" dump_type_exp te
| StaticArgNode op -> fprintf os "node %s" (op2string op)
(* | StaticArgFunc ne -> fprintf os "function %a" dump_node_exp ne *)
and dump_slice_info
(os : Format.formatter)
(sl: slice_info)
= (
fprintf os "%a@, .. @,%a" dump_val_exp sl.si_first dump_val_exp sl.si_last ;
match sl.si_step with
Some e -> fprintf os "@, step %a" dump_val_exp e
| None -> ()
)
(****************************)
(* Appels "par noms" *)
(****************************)
and dump_by_name_exp
(os: Format.formatter)
(oper: by_name_op)
(pars: (Lv6Id.t srcflagged * val_exp) list) =
(
match (oper, pars) with
| (STRUCT_n id, pl) -> (
fprintf os "%s{@,%a@,}" (Lv6Id.string_of_idref false id) dump_named_pars pl
)
| (STRUCT_WITH_n (id1,id2), pl) -> (
fprintf os "%s{ %s with @,%a@,}" (Lv6Id.string_of_idref false id1)
(Lv6Id.string_of_idref false id2) dump_named_pars pl
)
| (STRUCT_anonymous_n, pl) -> (
fprintf os "{@,%a@,}" dump_named_pars pl
)
)
and dump_named_pars
(os: Format.formatter)
(pars: (Lv6Id.t srcflagged * val_exp) list) =
( match pars with
[] -> ()
|(v,e)::[] -> fprintf os "%s = %a" (Lv6Id.to_string v.it) dump_val_exp e
|(v,e)::l ->
fprintf os "%s = %a;@,%a" (Lv6Id.to_string v.it) dump_val_exp e
dump_named_pars l
)
let dump_packinstance (os: Format.formatter) (pi: AstV6.pack_instance) = (
Format.fprintf os "= %s(%a);@\n"
(Lv6Id.to_string pi.pi_model)
dump_static_arg_list pi.pi_args ;
)
let dump_packgiven (os: Format.formatter) (pg: AstV6.pack_given) = (
(
match (pg.pg_provides) with
Some pl -> (
Format.fprintf os "provides@\n@[<b 3> %a@]@,;@\n"
dump_item_info_list pl
) | _ -> ()
);
Format.fprintf os "body@\n@[<b 3> %a@]@\nend@\n"
packbody pg.pg_body ;
)
(***********************************************************************************)
(* exported *)
let packinfo (os: Format.formatter) (pf: AstV6.pack_info srcflagged) = (
let (p, lxm) = (pf.it, pf.src) in
Format.fprintf os "@?@[<b 0>" ;
Format.fprintf os "-----------------------------\n";
Format.fprintf os "-- PACKAGE DEF \"%s\"\n" (Lv6Id.pack_name_to_string p.pa_name);
Format.fprintf os "-----------------------------\n";
Format.fprintf os "-- %s\n" (Lxm.details lxm) ;
(
match (p.pa_def) with
PackGiven pg -> dump_packgiven os pg
| PackInstance pi -> dump_packinstance os pi
);
Format.fprintf os "-----------------------------\n";
Format.fprintf os "@]@."
)
(***********************************************************************************)
(* exported *)
let modelinfo (os: Format.formatter) (mf: AstV6.model_info srcflagged) = (
let (m, lxm) = (mf.it, mf.src) in
Format.fprintf os "@?@[<b 0>" ;
Format.fprintf os "-----------------------------\n";
Format.fprintf os "-- MODEL DEF \"%s\"\n" (Lv6Id.pack_name_to_string m.mo_name);
Format.fprintf os "-----------------------------\n";
Format.fprintf os "-- %s\n" (Lxm.details lxm) ;
Format.fprintf os "model %s@\n" (Lv6Id.pack_name_to_string m.mo_name);
( match (m.mo_needs) with
[] -> ()
| _ -> (
Format.fprintf os "needs@\n@[<b 3> %a@]@,;@\n"
dump_static_param_list m.mo_needs
)
);
( match (m.mo_provides) with
Some pl -> (
Format.fprintf os "provides@\n@[<b 3> %a@]@,;@\n"
dump_item_info_list pl
) | _ -> ()
);
Format.fprintf os "body@\n@[<b 3> %a@]@\nend@\n"
packbody m.mo_body ;
Format.fprintf os "-----------------------------\n";
Format.fprintf os "@]@."
)
let print_val_exp oc ve =
let os = Format.formatter_of_out_channel oc in
dump_val_exp os ve;
pp_print_flush os ()
let print_node_exp oc ne =
let os = Format.formatter_of_out_channel oc in
dump_node_exp os ne;
pp_print_flush os ()
(* on one line for debug ... *)
let print_short_val_exp oc ve =
let os = Format.formatter_of_out_channel oc in
let fof : Format.formatter_out_functions =
pp_get_formatter_out_functions os ()
in
let fof = {
fof
with
Format.out_string = (fun s p n -> output_string oc (String.sub s p n));
Format.out_newline = (fun () -> ());
Format.out_spaces = (fun _ -> ());
(* This one has been introduced in ocaml 4.06; hence we use
the default formater ti ovoid braking backward compatility
Format.out_indent = (fun _ -> ()); *)
Format.out_flush = (fun () -> flush oc);
}
in
Format.pp_set_formatter_out_functions os fof;
dump_val_exp os ve;
pp_print_flush os ()