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 | ||
feec80c3 | 27 | # 0 "./dumper.ml" |
413ffc02 C |
28 | (* Dump an OCaml value into a printable string. |
29 | * By Richard W.M. Jones (rich@annexia.org). | |
30 | * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp | |
31 | *) | |
32 | ||
33 | open Printf | |
34 | open Obj | |
35 | ||
36 | let rec dump r = | |
37 | if is_int r then | |
38 | string_of_int (magic r : int) | |
39 | else ( (* Block. *) | |
40 | let rec get_fields acc = function | |
41 | | 0 -> acc | |
42 | | n -> let n = n-1 in get_fields (field r n :: acc) n | |
43 | in | |
44 | let rec is_list r = | |
45 | if is_int r then ( | |
46 | if (magic r : int) = 0 then true (* [] *) | |
47 | else false | |
48 | ) else ( | |
49 | let s = size r and t = tag r in | |
50 | if t = 0 && s = 2 then is_list (field r 1) (* h :: t *) | |
51 | else false | |
52 | ) | |
53 | in | |
54 | let rec get_list r = | |
55 | if is_int r then [] | |
56 | else let h = field r 0 and t = get_list (field r 1) in h :: t | |
57 | in | |
58 | let opaque name = | |
59 | (* XXX In future, print the address of value 'r'. Not possible in | |
60 | * pure OCaml at the moment. | |
61 | *) | |
62 | "<" ^ name ^ ">" | |
63 | in | |
64 | ||
65 | let s = size r and t = tag r in | |
66 | ||
67 | (* From the tag, determine the type of block. *) | |
68 | if is_list r then ( (* List. *) | |
69 | let fields = get_list r in | |
70 | "[" ^ String.concat "; " (List.map dump fields) ^ "]" | |
71 | ) | |
72 | else if t = 0 then ( (* Tuple, array, record. *) | |
73 | let fields = get_fields [] s in | |
74 | "(" ^ String.concat ", " (List.map dump fields) ^ ")" | |
75 | ) | |
76 | ||
77 | (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not | |
78 | * clear if very large constructed values could have the same | |
79 | * tag. XXX *) | |
80 | else if t = lazy_tag then opaque "lazy" | |
81 | else if t = closure_tag then opaque "closure" | |
82 | else if t = object_tag then ( (* Object. *) | |
83 | let fields = get_fields [] s in | |
84 | let clasz, id, slots = | |
85 | match fields with h::h'::t -> h, h', t | _ -> assert false in | |
86 | (* No information on decoding the class (first field). So just print | |
87 | * out the ID and the slots. | |
88 | *) | |
89 | "Object #" ^ dump id ^ | |
90 | " (" ^ String.concat ", " (List.map dump slots) ^ ")" | |
91 | ) | |
92 | else if t = infix_tag then opaque "infix" | |
93 | else if t = forward_tag then opaque "forward" | |
94 | ||
95 | else if t < no_scan_tag then ( (* Constructed value. *) | |
96 | let fields = get_fields [] s in | |
97 | "Tag" ^ string_of_int t ^ | |
98 | " (" ^ String.concat ", " (List.map dump fields) ^ ")" | |
99 | ) | |
100 | else if t = string_tag then ( | |
101 | "\"" ^ String.escaped (magic r : string) ^ "\"" | |
102 | ) | |
103 | else if t = double_tag then ( | |
104 | string_of_float (magic r : float) | |
105 | ) | |
106 | else if t = abstract_tag then opaque "abstract" | |
107 | else if t = custom_tag then opaque "custom" | |
108 | else if t = final_tag then opaque "final" | |
109 | else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")") | |
110 | ) | |
111 | ||
112 | let dump v = dump (repr v) |