commons/ocamlextra/dumper.ml

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