2010-09-09 00:35:06 +02:00
|
|
|
open Names
|
2010-11-01 01:04:35 +01:00
|
|
|
open Idents
|
2010-09-09 00:35:06 +02:00
|
|
|
open Signature
|
|
|
|
open Types
|
|
|
|
open Clocks
|
|
|
|
open Modules
|
|
|
|
open Format
|
|
|
|
open Pp_tools
|
|
|
|
|
2011-02-07 14:24:17 +01:00
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let rec _aux_print_modul ?(full=false) ff m = match m with
|
2011-02-07 14:24:17 +01:00
|
|
|
| Pervasives -> ()
|
|
|
|
| LocalModule -> ()
|
2011-02-14 15:21:57 +01:00
|
|
|
| _ when m = g_env.current_mod && not full -> ()
|
2011-02-07 14:24:17 +01:00
|
|
|
| Module m -> fprintf ff "%a." print_name m
|
2011-05-09 20:58:07 +02:00
|
|
|
| QualModule { qual = m; name = n } ->
|
|
|
|
fprintf ff "%a%a." (_aux_print_modul ~full:full) m print_name n
|
2011-02-07 14:24:17 +01:00
|
|
|
|
|
|
|
(** Prints a [modul] with a [.] at the end when not empty *)
|
2011-02-14 15:21:57 +01:00
|
|
|
let _print_modul ?(full=false) ff m = match m with
|
2011-02-07 14:24:17 +01:00
|
|
|
| Pervasives -> ()
|
|
|
|
| LocalModule -> ()
|
2011-02-14 15:21:57 +01:00
|
|
|
| _ when m = g_env.current_mod && not full -> ()
|
2011-02-07 14:24:17 +01:00
|
|
|
| Module m -> fprintf ff "%a" print_name m
|
2011-05-09 20:58:07 +02:00
|
|
|
| QualModule { qual = m; name = n } ->
|
|
|
|
fprintf ff "%a%a" (_aux_print_modul ~full:full) m print_name n
|
2011-05-13 15:35:29 +02:00
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let print_full_modul ff m = _print_modul ~full:true ff m
|
|
|
|
let print_modul ff m = _print_modul ~full:false ff m
|
2011-02-07 14:24:17 +01:00
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let _print_qualname ?(full=false) ff { qual = q; name = n} = match q with
|
2011-02-07 14:24:17 +01:00
|
|
|
| Pervasives -> print_name ff n
|
|
|
|
| LocalModule -> print_name ff n
|
2011-02-14 15:21:57 +01:00
|
|
|
| _ when q = g_env.current_mod && not full -> print_name ff n
|
|
|
|
| _ -> fprintf ff "%a%a" (_aux_print_modul ~full:full) q print_name n
|
2011-05-13 15:35:29 +02:00
|
|
|
|
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let print_qualname ff qn = _print_qualname ~full:false ff qn
|
|
|
|
let print_full_qualname ff qn = _print_qualname ~full:true ff qn
|
2010-09-09 00:35:06 +02:00
|
|
|
|
2011-01-20 23:05:18 +01:00
|
|
|
let print_shortname ff {name = n} = print_name ff n
|
|
|
|
|
2011-05-13 15:35:29 +02:00
|
|
|
let print_ident ff id = Format.fprintf ff "%s" (name id)
|
|
|
|
|
|
|
|
let rec print_ck ff = function
|
|
|
|
| Cbase -> fprintf ff "."
|
|
|
|
| Con (ck, c, n) -> fprintf ff "%a on %a(%a)" print_ck ck print_qualname c print_ident n
|
|
|
|
| Cvar { contents = Cindex i } -> fprintf ff "'a%i" i
|
|
|
|
| Cvar { contents = Clink ck } -> print_ck ff ck
|
|
|
|
|
|
|
|
let rec print_ct ff = function
|
|
|
|
| Ck ck -> print_ck ff ck
|
|
|
|
| Cprod ct_list ->
|
|
|
|
fprintf ff "@[<2>(%a)@]" (print_list_r print_ct """ *""") ct_list
|
|
|
|
|
|
|
|
let rec print_sck ff = function
|
|
|
|
| Signature.Cbase -> fprintf ff "."
|
|
|
|
| Signature.Con (ck, c, n) -> fprintf ff "%a on %a(%a)" print_sck ck print_qualname c print_name n
|
|
|
|
|
2010-09-09 00:35:06 +02:00
|
|
|
|
2011-04-28 09:28:07 +02:00
|
|
|
let rec print_static_exp_desc ff sed = match sed with
|
2010-09-09 00:35:06 +02:00
|
|
|
| Sint i -> fprintf ff "%d" i
|
|
|
|
| Sbool b -> fprintf ff "%b" b
|
|
|
|
| Sfloat f -> fprintf ff "%f" f
|
2011-05-10 16:55:46 +02:00
|
|
|
| Sstring s -> fprintf ff "\"%s\"" s
|
2010-09-09 00:35:06 +02:00
|
|
|
| Sconstructor ln -> print_qualname ff ln
|
2010-09-13 12:05:10 +02:00
|
|
|
| Sfield ln -> print_qualname ff ln
|
2010-09-09 00:35:06 +02:00
|
|
|
| Svar id -> fprintf ff "%a" print_qualname id
|
|
|
|
| Sop (op, se_list) ->
|
|
|
|
if is_infix (shortname op)
|
|
|
|
then
|
2011-02-07 14:24:17 +01:00
|
|
|
let e1,e2 = Misc.assert_2 se_list in
|
|
|
|
fprintf ff "(@[%a@ %a %a@])" print_static_exp e1 print_qualname op print_static_exp e2
|
2010-09-09 00:35:06 +02:00
|
|
|
else
|
|
|
|
fprintf ff "@[<2>%a@,%a@]"
|
|
|
|
print_qualname op print_static_exp_tuple se_list
|
2011-05-26 18:39:33 +02:00
|
|
|
| Sarray_power (se, n_list) ->
|
2011-06-28 14:45:15 +02:00
|
|
|
fprintf ff "%a^%a" print_static_exp se (print_list print_static_exp """^""") n_list
|
2010-09-09 00:35:06 +02:00
|
|
|
| Sarray se_list ->
|
|
|
|
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "["";""]") se_list
|
|
|
|
| Stuple se_list -> print_static_exp_tuple ff se_list
|
|
|
|
| Srecord f_se_list ->
|
|
|
|
print_record (print_couple print_qualname
|
|
|
|
print_static_exp """ = """) ff f_se_list
|
2011-04-28 09:28:07 +02:00
|
|
|
|
|
|
|
and print_static_exp ff se =
|
|
|
|
if !Compiler_options.full_type_info then
|
|
|
|
fprintf ff "(%a : %a)"
|
|
|
|
print_static_exp_desc se.se_desc print_type se.se_ty
|
|
|
|
else
|
|
|
|
fprintf ff "%a" print_static_exp_desc se.se_desc
|
2010-09-09 00:35:06 +02:00
|
|
|
|
|
|
|
and print_static_exp_tuple ff l =
|
|
|
|
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
|
|
|
|
|
|
|
|
and print_type ff = function
|
2011-04-14 18:06:54 +02:00
|
|
|
| Tinvalid -> fprintf ff "INVALID TYPE"
|
2010-09-09 00:35:06 +02:00
|
|
|
| Tprod ty_list ->
|
|
|
|
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
|
|
|
|
| Tid id -> print_qualname ff id
|
|
|
|
| Tarray (ty, n) ->
|
|
|
|
fprintf ff "@[<hov2>%a^%a@]" print_type ty print_static_exp n
|
|
|
|
|
2010-09-10 14:06:19 +02:00
|
|
|
let print_field ff field =
|
|
|
|
fprintf ff "@[%a: %a@]" print_qualname field.f_name print_type field.f_type
|
|
|
|
|
|
|
|
let print_struct ff field_list = print_record print_field ff field_list
|
|
|
|
|
2011-06-09 14:38:58 +02:00
|
|
|
let print_constrnt ff c = print_static_exp ff c
|
|
|
|
|
|
|
|
let print_constraints ff c_l =
|
|
|
|
fprintf ff "@[%a@]" (print_list_r print_constrnt "|"";"";") c_l
|
2010-09-09 00:35:06 +02:00
|
|
|
|
|
|
|
let print_param ff p =
|
|
|
|
fprintf ff "%a:%a" Names.print_name p.p_name print_type p.p_type
|
|
|
|
|
2011-05-18 09:36:41 +02:00
|
|
|
let print_interface_type ff (name,tdesc) =
|
2010-09-10 14:06:19 +02:00
|
|
|
match tdesc with
|
|
|
|
| Tabstract -> fprintf ff "@[type %s@]" name
|
|
|
|
| Tenum tag_name_list ->
|
|
|
|
fprintf ff "@[<2>type %s =@ %a@]"
|
|
|
|
name
|
|
|
|
(print_list_r print_qualname "" " |" "") tag_name_list;
|
|
|
|
| Tstruct f_ty_list ->
|
|
|
|
fprintf ff "@[<2>type %s =@ %a@]" name print_struct f_ty_list
|
|
|
|
| Talias t -> fprintf ff "@[<2>type %s = %a@]" name print_type t
|
|
|
|
|
2011-05-18 09:36:41 +02:00
|
|
|
let print_interface_const ff (name,c) =
|
2010-09-10 14:06:19 +02:00
|
|
|
fprintf ff "@[<2>const %a : %a = %a@]@."
|
|
|
|
print_name name
|
|
|
|
print_type c.Signature.c_type
|
|
|
|
print_static_exp c.Signature.c_value
|
|
|
|
|
2011-05-18 09:36:41 +02:00
|
|
|
let print_sarg ff arg = match arg.a_name with
|
|
|
|
| None ->
|
|
|
|
fprintf ff "@[%a :: %a@]" print_type arg.a_type print_sck arg.a_clock
|
|
|
|
| Some(name) ->
|
|
|
|
fprintf ff "@[%a : %a :: %a@]"
|
|
|
|
print_name name
|
|
|
|
print_type arg.a_type
|
|
|
|
print_sck arg.a_clock
|
|
|
|
|
|
|
|
let print_interface_value ff (name,node) =
|
2011-06-09 14:38:58 +02:00
|
|
|
let print_node_params ff (p_list, constraints) =
|
|
|
|
fprintf ff "@[<2><<@[%a@]%a>>@]"
|
|
|
|
(print_list_r (fun ff p -> print_name ff p.p_name) "" "," "") p_list
|
|
|
|
print_constraints constraints
|
2010-09-10 14:06:19 +02:00
|
|
|
in
|
2011-06-09 14:38:58 +02:00
|
|
|
fprintf ff "@[<v 2>val %a%a@[%a@] returns @[%a@]@]"
|
2010-09-10 14:06:19 +02:00
|
|
|
print_name name
|
2011-06-09 14:38:58 +02:00
|
|
|
print_node_params (node.node_params, node.node_param_constraints)
|
2011-05-18 09:36:41 +02:00
|
|
|
(print_list_r print_sarg "(" ";" ")") node.node_inputs
|
|
|
|
(print_list_r print_sarg "(" ";" ")") node.node_outputs
|
2010-09-10 14:06:19 +02:00
|
|
|
|
2010-09-14 09:39:02 +02:00
|
|
|
let print_interface ff =
|
2010-09-10 14:06:19 +02:00
|
|
|
let m = Modules.current_module () in
|
|
|
|
NamesEnv.iter
|
2011-05-18 09:36:41 +02:00
|
|
|
(fun key typdesc -> print_interface_type ff (key,typdesc)) m.m_types;
|
2010-09-10 14:06:19 +02:00
|
|
|
NamesEnv.iter
|
2011-05-18 09:36:41 +02:00
|
|
|
(fun key constdec -> print_interface_const ff (key,constdec)) m.m_consts;
|
2010-09-10 14:06:19 +02:00
|
|
|
NamesEnv.iter
|
2011-05-18 09:36:41 +02:00
|
|
|
(fun key sigtype -> print_interface_value ff (key,sigtype)) m.m_values;
|
2010-09-10 14:06:19 +02:00
|
|
|
Format.fprintf ff "@."
|
2010-09-09 00:35:06 +02:00
|
|
|
|
2010-11-01 01:04:35 +01:00
|
|
|
|