-
Notifications
You must be signed in to change notification settings - Fork 4
/
sexpr.ml
265 lines (232 loc) · 6.79 KB
/
sexpr.ml
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
(* Kaspar Rohrer, Wed Apr 14 13:46:21 CEST 2010 *)
module HT = Hashtbl.Make(Value)
open Format
open Aux
(*----------------------------------------------------------------------------*)
class type context =
object
method is_not_too_deep : depth:int -> Value.t -> bool
method should_expand : Value.t -> bool
end
let make_context ?(nesting=20) () =
object
method is_not_too_deep ~depth r =
depth < nesting
method should_expand r =
match Value.tag r with
| _ -> true
end
let default_context = make_context ()
(*----------------------------------------------------------------------------*)
let dump_with_formatter ?(context=default_context) fmt o =
let queue = Queue.create () in
let indentation_for_string id = 3 (* String.length id + 2 *) in
let rec value2id = HT.create 31337
and id_of_value r =
try
id_find r
with Not_found -> (
let tid = Value.mnemonic r in
let n = HT.length value2id in
let id = sprintf "%s/%d" tid n in
HT.add value2id r id;
id
)
and id_find r =
HT.find value2id r
in
let sexpr_open fmt id =
fprintf fmt "@[<hv %d>(%s" (indentation_for_string id) id
and sexpr_close fmt () =
fprintf fmt ")@]"
and sexpr_sep fmt () =
fprintf fmt "@ "
(* and sexpr_mnemo fmt r = *)
(* pp_print_string fmt (Value.mnemonic r) *)
and sexpr_ref fmt id =
fprintf fmt "@@%s" id
in
let rec sexpr_one body ~depth fmt r =
if depth = 0 then (
(* At depth 0 we are never too deep, no mather what the (maybe
too whiny) context might say. We HAVE TO consume the queue
somehow. *)
sexpr_open fmt (id_of_value r);
body ();
sexpr_close fmt ()
)
else (
if context#is_not_too_deep ~depth r then (
(* It still is reasonable to dump this *)
try sexpr_ref fmt (id_find r) with Not_found ->
(* Print reference to already printed sexpr, or print now *)
sexpr_open fmt (id_of_value r);
body ();
sexpr_close fmt ()
)
else (
try sexpr_ref fmt (id_find r) with Not_found ->
(* Print reference to already printed sexpr, or queue for later *)
Queue.add r queue
)
)
and sexpr_string ~depth fmt r =
let body () =
assert (Obj.tag r = Obj.string_tag);
let s : string = Obj.magic r in
sexpr_sep fmt ();
fprintf fmt ":LEN %d" (String.length s);
if context#should_expand r then (
sexpr_sep fmt ();
fprintf fmt "%S" s
)
in
sexpr_one body ~depth fmt r
and sexpr_abstract ~depth fmt r=
let body () =
assert (Obj.tag r = Obj.abstract_tag);
sexpr_sep fmt ();
fprintf fmt ":SIZE %d" (Value.heap_words r);
in
sexpr_one body ~depth fmt r
and sexpr_custom ~depth fmt r =
let body () =
assert (Obj.tag r = Obj.custom_tag);
sexpr_sep fmt ();
fprintf fmt ":ID %S" (Value.custom_identifier r);
if context#should_expand r then (
sexpr_sep fmt ();
fprintf fmt ":SIZE %d" (Value.heap_words r);
sexpr_sep fmt ();
fprintf fmt ":OPS %s" (Value.custom_ops_info r)
)
in
sexpr_one body ~depth fmt r
and sexpr_block ~depth fmt r =
let body () =
assert (Obj.tag r < Obj.no_scan_tag);
let n = Obj.size r and depth = depth + 1 in
sexpr_sep fmt ();
fprintf fmt ":TAG %d" (Obj.tag r);
if context#should_expand r then (
sexpr_sep fmt ();
fprintf fmt ":VALUES";
for i = 0 to n - 1 do
let f = Obj.field r i in
sexpr_sep fmt ();
sexpr_value ~depth fmt f
done
)
else (
sexpr_sep fmt ();
fprintf fmt ":SIZE %d" n
)
in
sexpr_one body ~depth fmt r
and sexpr_double_array ~depth fmt r =
let body () =
assert (Obj.tag r = Obj.double_array_tag);
let a : float array = Obj.magic r in
let n = Array.length a in
if context#should_expand r then (
for i = 0 to n - 1 do
sexpr_sep fmt ();
fprintf fmt "%g" a.(i)
done
)
else (
sexpr_sep fmt ();
fprintf fmt ":SIZE %d" n
)
in
sexpr_one body ~depth fmt r
and sexpr_float fmt r =
assert (Obj.tag r = Obj.double_tag);
fprintf fmt "%f" (Obj.magic r : float)
and sexpr_int fmt r =
assert (Obj.tag r = Obj.int_tag);
fprintf fmt "%d" (Obj.magic r : int)
and sexpr_nativeint fmt ni =
fprintf fmt "%ndn" ni
and sexpr_int32 fmt i32 =
fprintf fmt "%ldl" i32
and sexpr_int64 fmt i64 =
fprintf fmt "%LdL" i64
and sexpr_addr fmt r =
fprintf fmt "0x%nX" (Value.bits r)
and sexpr_value ~depth fmt r =
(* The great dispatch! I wonder how this would look in Java *)
let t = Value.tag r in
match t with
| Value.Lazy
| Value.Closure
| Value.Object
| Value.Infix
| Value.Forward
| Value.Block -> sexpr_block ~depth fmt r
| Value.Abstract -> sexpr_abstract ~depth fmt r
| Value.Custom -> (
match Value.custom_value r with
| Value.Custom_nativeint ni -> sexpr_nativeint fmt ni
| Value.Custom_int32 i32 -> sexpr_int32 fmt i32
| Value.Custom_int64 i64 -> sexpr_int64 fmt i64
| _ -> sexpr_custom ~depth fmt r )
| Value.Double_array -> sexpr_double_array ~depth fmt r
| Value.Unaligned
| Value.Out_of_heap -> sexpr_addr fmt r
| Value.Double -> sexpr_float fmt r
| Value.Int -> sexpr_int fmt r
| Value.String -> sexpr_string ~depth fmt r
in
let values = "DUMP" in
let r = Obj.repr o in
pp_open_vbox fmt 0;
sexpr_open fmt values;
Queue.push r queue;
while not (Queue.is_empty queue) do
let r = Queue.pop queue in
sexpr_sep fmt ();
sexpr_value ~depth:0 fmt r
done;
sexpr_close fmt ();
pp_close_box fmt ()
(*----------------------------------------------------------------------------*)
let dump ?context o =
let fmt = Format.std_formatter in
dump_with_formatter ?context fmt o
let dump_to_out_channel ?context outc o =
let fmt = Format.formatter_of_out_channel outc in
dump_with_formatter ?context fmt o
let dump_to_file ?context filename o =
with_file_out_channel filename (fun outc -> dump_to_out_channel ?context outc o)
(*----------------------------------------------------------------------------*)
exception TestException of string * int
let rec test_data () =
let rec l = 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: l in
let rec drop l i =
if i = 0 then
l
else
drop (List.tl l) (i - 1)
in
let rec f x =
l
and g y =
f (y :: l)
in
let o = object
val brog = 4
val brag = 51251
method blah = 3
method foo () a = a
end in
let data =
([|1|], l, (1,2), [|3; 4|], flush, 1.0, [|2.0; 3.0|],
TestException ("TestException", -1),
test_data,
("Hello world", lazy (3 + 5)), g, f, let s = "STRING" in (s, "STRING", s),
Array.init 20 (drop l),
stdout, Format.printf, (o, default_context))
in
Obj.repr data
(*----------------------------------------------------------------------------*)