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