Skip to content
This repository
Newer
Older
100644 122 lines (113 sloc) 4.188 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 include Obj
19
20 (* just a hack to know if we are running in bytecode or in native *)
21 let native_runtime =
22 match Obj.size (Obj.repr (fun x -> x)) with
23 | 1 -> false
24 | 2 -> true
25 | _ -> assert false
26 let bytecode_runtime = not native_runtime
27
28 let buffer = Buffer.create 1000
29
30 let rec stringify ?(depth=max_int) t =
31 if depth < 0 then
32 Buffer.add_char buffer '.'
33 else
34 let depth = depth - 1 in
35 let tag = Obj.tag t in
36 if tag = Obj.int_tag then
37 Buffer.add_string buffer (string_of_int (Obj.obj t : int))
38 else if tag = 0 then (
39 Buffer.add_char buffer '(';
40 let size = Obj.size t in
41 if size <> 0 then (
42 stringify ~depth (Obj.field t 0);
43 for i = 1 to size - 1 do
44 Buffer.add_char buffer ',';
45 stringify ~depth (Obj.field t i);
46 done
47 );
48 Buffer.add_char buffer ')';
49 )
50 else if tag = Obj.lazy_tag then
51 Buffer.add_string buffer "<lazy>"
52 else if tag = Obj.closure_tag then
53 Buffer.add_string buffer "<closure>"
54 else if tag = Obj.object_tag then
55 Buffer.add_string buffer ("<object " ^ string_of_int (Oo.id (Obj.obj t)) ^ ">" )
56 else if tag = Obj.infix_tag then
57 Buffer.add_string buffer "<infix>"
58 else if tag = Obj.forward_tag then
59 Buffer.add_string buffer "<forward>"
60 else if tag < Obj.no_scan_tag then (
61 Buffer.add_string buffer "Tag";
62 Buffer.add_string buffer (string_of_int tag);
63 Buffer.add_char buffer '(';
64 let size = Obj.size t in
65 if size <> 0 then (
66 stringify ~depth (Obj.field t 0);
67 for i = 1 to size - 1 do
68 Buffer.add_char buffer ',';
69 stringify ~depth (Obj.field t i);
70 done
71 );
72 Buffer.add_char buffer ')';
73 ) else if tag = Obj.no_scan_tag then
74 Buffer.add_string buffer "<no_scan_tag>"
75 else if tag = Obj.abstract_tag then
76 Buffer.add_string buffer "<abstract>"
77 else if tag = Obj.string_tag then (
78 Buffer.add_char buffer '"';
79 let s = Obj.obj t in
80 if String.length s <= 200 then
81 Buffer.add_string buffer (String.escaped s)
82 else (
83 Buffer.add_string buffer (String.escaped (String.sub s 0 100));
84 Buffer.add_string buffer "...";
85 Buffer.add_string buffer (String.escaped (String.sub s (String.length s - 100 - 1) 100));
86 );
87 Buffer.add_char buffer '"'
88 ) else if tag = Obj.double_tag then (
89 Buffer.add_string buffer (string_of_float (Obj.obj t))
90 ) else if tag = Obj.double_array_tag then (
91 Buffer.add_string buffer "[|";
92 let t : float array = Obj.obj t in
93 let size = Array.length t in
94 if size <> 0 then (
95 Buffer.add_string buffer (string_of_float t.(0));
96 for i = 1 to size - 1 do
97 Buffer.add_char buffer ';';
98 Buffer.add_string buffer (string_of_float t.(i));
99 done;
100 );
101 Buffer.add_string buffer "|]";
102 ) else if tag = Obj.custom_tag then
103 Buffer.add_string buffer "<custom>"
104 else if tag = Obj.final_tag then
105 Buffer.add_string buffer "<final>"
106 else if tag = Obj.out_of_heap_tag then
107 Buffer.add_string buffer "<out_of_heap>"
108 else if tag = Obj.unaligned_tag then
109 Buffer.add_string buffer "<unaligned>"
110 else
111 Buffer.add_string buffer "<UNKNOWN>"
112
113 let dump ?depth x =
114 stringify ?depth (Obj.repr x);
115 let s = Buffer.contents buffer in
116 Buffer.reset buffer;
117 s
118
119 let print ?prefix x =
120 match prefix with
121 | None -> print_endline (dump x)
122 | Some s -> Printf.printf "%s: %s\n%!" s (dump x)
Something went wrong with that request. Please try again.