Commit | Line | Data |
---|---|---|
34e49164 C |
1 | (* Dump an OCaml value into a printable string. |
2 | * By Richard W.M. Jones (rich@annexia.org). | |
ae4735db | 3 | * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp |
34e49164 C |
4 | *) |
5 | ||
6 | open Printf | |
7 | open Obj | |
8 | ||
9 | let rec dump r = | |
10 | if is_int r then | |
11 | string_of_int (magic r : int) | |
12 | else ( (* Block. *) | |
13 | let rec get_fields acc = function | |
14 | | 0 -> acc | |
15 | | n -> let n = n-1 in get_fields (field r n :: acc) n | |
16 | in | |
17 | let rec is_list r = | |
18 | if is_int r then ( | |
19 | if (magic r : int) = 0 then true (* [] *) | |
20 | else false | |
21 | ) else ( | |
22 | let s = size r and t = tag r in | |
23 | if t = 0 && s = 2 then is_list (field r 1) (* h :: t *) | |
24 | else false | |
25 | ) | |
26 | in | |
27 | let rec get_list r = | |
28 | if is_int r then [] | |
29 | else let h = field r 0 and t = get_list (field r 1) in h :: t | |
30 | in | |
31 | let opaque name = | |
32 | (* XXX In future, print the address of value 'r'. Not possible in | |
33 | * pure OCaml at the moment. | |
34 | *) | |
35 | "<" ^ name ^ ">" | |
36 | in | |
37 | ||
38 | let s = size r and t = tag r in | |
39 | ||
40 | (* From the tag, determine the type of block. *) | |
41 | if is_list r then ( (* List. *) | |
42 | let fields = get_list r in | |
43 | "[" ^ String.concat "; " (List.map dump fields) ^ "]" | |
44 | ) | |
45 | else if t = 0 then ( (* Tuple, array, record. *) | |
46 | let fields = get_fields [] s in | |
47 | "(" ^ String.concat ", " (List.map dump fields) ^ ")" | |
48 | ) | |
49 | ||
50 | (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not | |
51 | * clear if very large constructed values could have the same | |
52 | * tag. XXX *) | |
53 | else if t = lazy_tag then opaque "lazy" | |
54 | else if t = closure_tag then opaque "closure" | |
55 | else if t = object_tag then ( (* Object. *) | |
56 | let fields = get_fields [] s in | |
57 | let clasz, id, slots = | |
58 | match fields with h::h'::t -> h, h', t | _ -> assert false in | |
59 | (* No information on decoding the class (first field). So just print | |
60 | * out the ID and the slots. | |
61 | *) | |
62 | "Object #" ^ dump id ^ | |
63 | " (" ^ String.concat ", " (List.map dump slots) ^ ")" | |
64 | ) | |
65 | else if t = infix_tag then opaque "infix" | |
66 | else if t = forward_tag then opaque "forward" | |
67 | ||
68 | else if t < no_scan_tag then ( (* Constructed value. *) | |
69 | let fields = get_fields [] s in | |
70 | "Tag" ^ string_of_int t ^ | |
71 | " (" ^ String.concat ", " (List.map dump fields) ^ ")" | |
72 | ) | |
73 | else if t = string_tag then ( | |
74 | "\"" ^ String.escaped (magic r : string) ^ "\"" | |
75 | ) | |
76 | else if t = double_tag then ( | |
77 | string_of_float (magic r : float) | |
78 | ) | |
79 | else if t = abstract_tag then opaque "abstract" | |
80 | else if t = custom_tag then opaque "custom" | |
81 | else if t = final_tag then opaque "final" | |
82 | else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")") | |
83 | ) | |
84 | ||
85 | let dump v = dump (repr v) |