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