-
Notifications
You must be signed in to change notification settings - Fork 125
/
baseObj.ml
122 lines (113 loc) · 4.09 KB
/
baseObj.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
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
include Obj
(* just a hack to know if we are running in bytecode or in native *)
let native_runtime =
match Obj.size (Obj.repr (fun x -> x)) with
| 1 -> false
| 2 -> true
| _ -> assert false
let bytecode_runtime = not native_runtime
let buffer = Buffer.create 1000
let rec stringify ?(depth=max_int) t =
if depth < 0 then
Buffer.add_char buffer '.'
else
let depth = depth - 1 in
let tag = Obj.tag t in
if tag = Obj.int_tag then
Buffer.add_string buffer (string_of_int (Obj.obj t : int))
else if tag = 0 then (
Buffer.add_char buffer '(';
let size = Obj.size t in
if size <> 0 then (
stringify ~depth (Obj.field t 0);
for i = 1 to size - 1 do
Buffer.add_char buffer ',';
stringify ~depth (Obj.field t i);
done
);
Buffer.add_char buffer ')';
)
else if tag = Obj.lazy_tag then
Buffer.add_string buffer "<lazy>"
else if tag = Obj.closure_tag then
Buffer.add_string buffer "<closure>"
else if tag = Obj.object_tag then
Buffer.add_string buffer ("<object " ^ string_of_int (Oo.id (Obj.obj t)) ^ ">" )
else if tag = Obj.infix_tag then
Buffer.add_string buffer "<infix>"
else if tag = Obj.forward_tag then
Buffer.add_string buffer "<forward>"
else if tag < Obj.no_scan_tag then (
Buffer.add_string buffer "Tag";
Buffer.add_string buffer (string_of_int tag);
Buffer.add_char buffer '(';
let size = Obj.size t in
if size <> 0 then (
stringify ~depth (Obj.field t 0);
for i = 1 to size - 1 do
Buffer.add_char buffer ',';
stringify ~depth (Obj.field t i);
done
);
Buffer.add_char buffer ')';
) else if tag = Obj.no_scan_tag then
Buffer.add_string buffer "<no_scan_tag>"
else if tag = Obj.abstract_tag then
Buffer.add_string buffer "<abstract>"
else if tag = Obj.string_tag then (
Buffer.add_char buffer '"';
let s = Obj.obj t in
if String.length s <= 200 then
Buffer.add_string buffer (String.escaped s)
else (
Buffer.add_string buffer (String.escaped (String.sub s 0 100));
Buffer.add_string buffer "...";
Buffer.add_string buffer (String.escaped (String.sub s (String.length s - 100 - 1) 100));
);
Buffer.add_char buffer '"'
) else if tag = Obj.double_tag then (
Buffer.add_string buffer (string_of_float (Obj.obj t))
) else if tag = Obj.double_array_tag then (
Buffer.add_string buffer "[|";
let t : float array = Obj.obj t in
let size = Array.length t in
if size <> 0 then (
Buffer.add_string buffer (string_of_float t.(0));
for i = 1 to size - 1 do
Buffer.add_char buffer ';';
Buffer.add_string buffer (string_of_float t.(i));
done;
);
Buffer.add_string buffer "|]";
) else if tag = Obj.custom_tag then
Buffer.add_string buffer "<custom>"
else if tag = Obj.final_tag then
Buffer.add_string buffer "<final>"
else if tag = Obj.out_of_heap_tag then
Buffer.add_string buffer "<out_of_heap>"
else if tag = Obj.unaligned_tag then
Buffer.add_string buffer "<unaligned>"
else
Buffer.add_string buffer "<UNKNOWN>"
let dump ?depth x =
stringify ?depth (Obj.repr x);
let s = Buffer.contents buffer in
Buffer.reset buffer;
s
let print ?prefix x =
match prefix with
| None -> print_endline (dump x)
| Some s -> Printf.printf "%s: %s\n%!" s (dump x)