Commit | Line | Data |
---|---|---|
f537ebc4 C |
1 | (* |
2 | * Copyright 2010, INRIA, University of Copenhagen | |
3 | * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix | |
4 | * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen | |
5 | * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix | |
6 | * This file is part of Coccinelle. | |
7 | * | |
8 | * Coccinelle is free software: you can redistribute it and/or modify | |
9 | * it under the terms of the GNU General Public License as published by | |
10 | * the Free Software Foundation, according to version 2 of the License. | |
11 | * | |
12 | * Coccinelle is distributed in the hope that it will be useful, | |
13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | * GNU General Public License for more details. | |
16 | * | |
17 | * You should have received a copy of the GNU General Public License | |
18 | * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>. | |
19 | * | |
20 | * The authors reserve the right to distribute this or future versions of | |
21 | * Coccinelle under other licenses. | |
22 | *) | |
23 | ||
24 | ||
413ffc02 C |
25 | (* Dump an OCaml value into a printable string. |
26 | * By Richard W.M. Jones (rich@annexia.org). | |
27 | * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp | |
28 | *) | |
29 | ||
30 | open Printf | |
31 | open Obj | |
32 | ||
33 | let rec dump r = | |
34 | if is_int r then | |
35 | string_of_int (magic r : int) | |
36 | else ( (* Block. *) | |
37 | let rec get_fields acc = function | |
38 | | 0 -> acc | |
39 | | n -> let n = n-1 in get_fields (field r n :: acc) n | |
40 | in | |
41 | let rec is_list r = | |
42 | if is_int r then ( | |
43 | if (magic r : int) = 0 then true (* [] *) | |
44 | else false | |
45 | ) else ( | |
46 | let s = size r and t = tag r in | |
47 | if t = 0 && s = 2 then is_list (field r 1) (* h :: t *) | |
48 | else false | |
49 | ) | |
50 | in | |
51 | let rec get_list r = | |
52 | if is_int r then [] | |
53 | else let h = field r 0 and t = get_list (field r 1) in h :: t | |
54 | in | |
55 | let opaque name = | |
56 | (* XXX In future, print the address of value 'r'. Not possible in | |
57 | * pure OCaml at the moment. | |
58 | *) | |
59 | "<" ^ name ^ ">" | |
60 | in | |
61 | ||
62 | let s = size r and t = tag r in | |
63 | ||
64 | (* From the tag, determine the type of block. *) | |
65 | if is_list r then ( (* List. *) | |
66 | let fields = get_list r in | |
67 | "[" ^ String.concat "; " (List.map dump fields) ^ "]" | |
68 | ) | |
69 | else if t = 0 then ( (* Tuple, array, record. *) | |
70 | let fields = get_fields [] s in | |
71 | "(" ^ String.concat ", " (List.map dump fields) ^ ")" | |
72 | ) | |
73 | ||
74 | (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not | |
75 | * clear if very large constructed values could have the same | |
76 | * tag. XXX *) | |
77 | else if t = lazy_tag then opaque "lazy" | |
78 | else if t = closure_tag then opaque "closure" | |
79 | else if t = object_tag then ( (* Object. *) | |
80 | let fields = get_fields [] s in | |
81 | let clasz, id, slots = | |
82 | match fields with h::h'::t -> h, h', t | _ -> assert false in | |
83 | (* No information on decoding the class (first field). So just print | |
84 | * out the ID and the slots. | |
85 | *) | |
86 | "Object #" ^ dump id ^ | |
87 | " (" ^ String.concat ", " (List.map dump slots) ^ ")" | |
88 | ) | |
89 | else if t = infix_tag then opaque "infix" | |
90 | else if t = forward_tag then opaque "forward" | |
91 | ||
92 | else if t < no_scan_tag then ( (* Constructed value. *) | |
93 | let fields = get_fields [] s in | |
94 | "Tag" ^ string_of_int t ^ | |
95 | " (" ^ String.concat ", " (List.map dump fields) ^ ")" | |
96 | ) | |
97 | else if t = string_tag then ( | |
98 | "\"" ^ String.escaped (magic r : string) ^ "\"" | |
99 | ) | |
100 | else if t = double_tag then ( | |
101 | string_of_float (magic r : float) | |
102 | ) | |
103 | else if t = abstract_tag then opaque "abstract" | |
104 | else if t = custom_tag then opaque "custom" | |
105 | else if t = final_tag then opaque "final" | |
106 | else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")") | |
107 | ) | |
108 | ||
109 | let dump v = dump (repr v) |