tools/dumper.ml

   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
  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)