1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
|
(***********************************************************************)
(* *)
(* Caml Special Light *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1995 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* To print values *)
open Misc
open Obj
open Format
open Longident
open Path
open Typedtree
(* Given an exception value, we cannot recover its type,
hence we cannot print its arguments in general.
Here, we do a feeble attempt to print
integer, string and float arguments... *)
let print_exception obj =
print_string (Obj.magic(Obj.field(Obj.field obj 0) 0) : string);
if Obj.size obj > 1 then begin
open_hovbox 1;
print_string "(";
for i = 1 to Obj.size obj - 1 do
if i > 1 then begin print_string ","; print_space() end;
let arg = Obj.field obj i in
if not (Obj.is_block arg) then
print_int(Obj.magic arg : int) (* Note: this could be a char! *)
else if Obj.tag arg = 252 then begin
print_string "\"";
print_string (String.escaped (Obj.magic arg : string));
print_string "\""
end else if Obj.tag arg = 253 then
print_float (Obj.magic arg : float)
else
print_string "_"
done;
print_string ")";
close_box()
end
(* Recover a constructor by its tag *)
exception Constr_not_found
let rec find_constr tag num_const num_nonconst = function
[] ->
raise Constr_not_found
| (name, [] as cstr) :: rem ->
if tag = Cstr_constant num_const
then cstr
else find_constr tag (num_const + 1) num_nonconst rem
| (name, _ as cstr) :: rem ->
if tag = Cstr_block num_nonconst
then cstr
else find_constr tag num_const (num_nonconst + 1) rem
(* The user-defined printers. Also used for some builtin types. *)
let printers = ref ([
Pident(Ident.create "print_int"), Predef.type_int,
(fun x -> print_int (Obj.magic x : int));
Pident(Ident.create "print_float"), Predef.type_float,
(fun x -> print_float(Obj.magic x : float));
Pident(Ident.create "print_char"), Predef.type_char,
(fun x -> print_string "'";
print_string (Char.escaped (Obj.magic x : char));
print_string "'");
Pident(Ident.create "print_string"), Predef.type_string,
(fun x -> print_string "\"";
print_string (String.escaped (Obj.magic x : string));
print_string "\"")
] : (Path.t * type_expr * (Obj.t -> unit)) list)
let find_printer env ty =
let rec find = function
[] -> raise Not_found
| (name, sch, printer) :: remainder ->
if Ctype.moregeneral env sch ty
then printer
else find remainder
in find !printers
(* Print a constructor or label, giving it the same prefix as the type
it comes from. Attempt to omit the prefix if the type comes from
a module that has been opened. *)
let print_qualified lookup_fun env ty_path name =
match ty_path with
Pident id ->
print_string name
| Pdot(p, s, pos) ->
if try
match (lookup_fun (Lident name) env).desc with
Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
| _ -> false
with Not_found -> false
then print_string name
else (Printtyp.path p; print_string "."; print_string name)
| Papply(p1, p2) ->
Printtyp.path ty_path
let print_constr =
print_qualified (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
and print_label =
print_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
(* The main printing function *)
let max_printer_depth = ref 100
let max_printer_steps = ref 300
exception Ellipsis
let cautious f arg = try f arg with Ellipsis -> print_string "..."
let print_value env obj ty =
let printer_steps = ref !max_printer_steps in
let rec print_val prio depth obj ty =
decr printer_steps;
if !printer_steps < 0 or depth < 0 then raise Ellipsis;
try
find_printer env ty obj; ()
with Not_found ->
match (Ctype.repr ty).desc with
Tvar ->
print_string "<poly>"
| Tarrow(ty1, ty2) ->
print_string "<fun>"
| Ttuple(ty_list) ->
if prio > 0
then begin open_hovbox 1; print_string "(" end
else open_hovbox 0;
print_val_list 1 depth obj ty_list;
if prio > 0 then print_string ")";
close_box()
| Tconstr(path, [], _) when Path.same path Predef.path_exn ->
if prio > 1
then begin open_hovbox 2; print_string "(" end
else open_hovbox 1;
print_exception obj;
if prio > 1 then print_string ")";
close_box()
| Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
let rec print_conses depth cons =
if Obj.is_block cons then begin
print_val 0 (depth - 1) (Obj.field cons 0) ty_arg;
let next_obj = Obj.field cons 1 in
if Obj.is_block next_obj then begin
print_string ";"; print_space();
print_conses (depth - 1) next_obj
end
end in
open_hovbox 1;
print_string "[";
cautious (print_conses depth) obj;
print_string "]";
close_box()
| Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
let rec print_items depth i =
if i < Obj.size obj then begin
if i > 0 then begin print_string ";"; print_space() end;
print_val 0 (depth - 1) (Obj.field obj i) ty_arg;
print_items (depth - 1) (i + 1)
end in
open_hovbox 2;
print_string "[|";
cautious (print_items depth) 0;
print_string "|]";
close_box()
| Tconstr(path, ty_list, _) ->
begin try
let decl = Env.find_type path env in
match decl with
{type_kind = Type_abstract; type_manifest = None} ->
print_string "<abstr>"
| {type_kind = Type_abstract; type_manifest = Some body} ->
print_val prio depth obj
(Ctype.substitute [] decl.type_params ty_list body)
| {type_kind = Type_variant constr_list} ->
let tag =
if Obj.is_block obj
then Cstr_block(Obj.tag obj)
else Cstr_constant(Obj.magic obj) in
let (constr_name, constr_args) =
find_constr tag 0 0 constr_list in
let ty_args =
List.map (Ctype.substitute [] decl.type_params ty_list)
constr_args in
begin match ty_args with
[] ->
print_constr env path constr_name
| [ty1] ->
if prio > 1
then begin open_hovbox 2; print_string "(" end
else open_hovbox 1;
print_constr env path constr_name;
print_space();
cautious (print_val 2 (depth - 1) (Obj.field obj 0)) ty1;
if prio > 1 then print_string ")";
close_box()
| tyl ->
if prio > 1
then begin open_hovbox 2; print_string "(" end
else open_hovbox 1;
print_constr env path constr_name;
print_space();
open_hovbox 1;
print_string "(";
print_val_list 1 depth obj tyl;
print_string ")";
close_box();
if prio > 1 then print_string ")";
close_box()
end
| {type_kind = Type_record lbl_list} ->
let rec print_fields depth pos = function
[] -> ()
| (lbl_name, _, lbl_arg) :: remainder ->
if pos > 0 then begin print_string ";"; print_space() end;
open_hovbox 1;
print_label env path lbl_name;
print_string "="; print_cut();
let ty_arg =
Ctype.substitute [] decl.type_params ty_list lbl_arg in
cautious (print_val 0 (depth - 1) (Obj.field obj pos))
ty_arg;
close_box();
print_fields (depth - 1) (pos + 1) remainder in
open_hovbox 1;
print_string "{";
cautious (print_fields depth 0) lbl_list;
print_string "}";
close_box()
with
Not_found -> (* raised by Env.find_type *)
print_string "<abstr>"
| Constr_not_found -> (* raised by find_constr *)
print_string "<unknown constructor>"
end
| Tobject (_, _) ->
print_string "<obj>"
| Tfield(_, _, _) | Tnil | Tlink _ ->
fatal_error "Printval.print_value"
and print_val_list prio depth obj ty_list =
let rec print_list depth i = function
[] -> ()
| ty :: ty_list ->
if i > 0 then begin print_string ","; print_space() end;
print_val prio (depth - 1) (Obj.field obj i) ty;
print_list (depth - 1) (i + 1) ty_list in
cautious (print_list depth 0) ty_list
in print_val 0 !max_printer_depth obj ty
|
