Added functions: Obj.{dump, print, unique_int} from extlib

stdlib/obj.ml

@@ -9,6 +9,9 @@
 (*  under the terms of the GNU Library General Public License, with    *)
 (*  the special exception on linking described in file ../LICENSE.     *)
 (*                                                                     *)
+(* portions lifted from Extlib                                         *)
+(* Copyright (C) 2003 Brian Hurt                                       *)
+(* Copyright (C) 2003 Nicolas Cannasse                                 *)
 (***********************************************************************)
 
 (* $Id$ *)
@@ -54,3 +57,88 @@ let final_tag = custom_tag
 
 let int_tag = 1000
 let out_of_heap_tag = 1001
+
+let rec dump r =
+  if is_int r then
+    string_of_int (magic r : int)
+  else (* Block. *)
+    let rec get_fields acc = function
+      | 0 -> acc
+      | n -> let n = n-1 in get_fields (field r n :: acc) n
+    in
+    let rec is_list r =
+      if is_int r then
+	r = repr 0 (* [] *)
+      else
+	let s = size r and t = tag r in
+	t = 0 && s = 2 && is_list (field r 1) (* h :: t *)
+	in
+    let rec get_list r =
+      if is_int r then
+	[]
+      else 
+	let h = field r 0 and t = get_list (field r 1) in
+	h :: t
+    in
+    let opaque name =
+      (* XXX In future, print the address of value 'r'.  Not possible in
+       * pure OCaml at the moment.
+       *)
+      "<" ^ name ^ ">"
+    in
+    let s = size r and t = tag r in
+    (* From the tag, determine the type of block. *)
+    match t with 
+      | _ when is_list r ->
+	  let fields = get_list r in
+	  "[" ^ String.concat "; " (List.map dump fields) ^ "]"
+      | 0 ->
+	  let fields = get_fields [] s in
+	  "(" ^ String.concat ", " (List.map dump fields) ^ ")"
+      | x when x = lazy_tag ->
+	  (* Note that [lazy_tag .. forward_tag] are < no_scan_tag.  Not
+	   * clear if very large constructed values could have the same
+	   * tag. XXX *)
+	  opaque "lazy"
+      | x when x = closure_tag ->
+	  opaque "closure"
+      | x when x = object_tag ->
+	  let fields = get_fields [] s in
+	  let clasz, id, slots =
+	    match fields with
+	      | h::h'::t -> h, h', t 
+	      | _ -> assert false
+	  in
+	  (* No information on decoding the class (first field).  So just print
+	   * out the ID and the slots. *)
+	  "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"
+      | x when x = infix_tag ->
+	  opaque "infix"
+      | x when x = forward_tag ->
+	  opaque "forward"
+      | x when x < no_scan_tag ->
+	  let fields = get_fields [] s in
+	  "Tag" ^ string_of_int t ^
+	    " (" ^ String.concat ", " (List.map dump fields) ^ ")"
+      | x when x = string_tag ->
+	  "\"" ^ String.escaped (magic r : string) ^ "\""
+      | x when x = double_tag ->
+	  string_of_float (magic r : float)
+      | x when x = abstract_tag ->
+	  opaque "abstract"
+      | x when x = custom_tag ->
+	  opaque "custom"
+      | x when x = final_tag ->
+	  opaque "final"
+      | _ ->
+	  failwith ("Std.dump: impossible tag (" ^ string_of_int t ^ ")")
+
+let dump v = dump (repr v)
+
+let print v = print_endline (dump v)
+
+let __unique_counter = ref 0
+
+let unique_int () =
+  incr __unique_counter;
+  !__unique_counter

stdlib/obj.mli

@@ -55,3 +55,15 @@ val out_of_heap_tag : int
 
 val marshal : t -> string
 val unmarshal : string -> int -> t * int
+
+
+val dump : 'a -> string
+(** represent a runtime value as a string. Since types are lost at compile
+        time, the representation might not match your type. For example, None
+        will be printed 0 since they share the same runtime representation. *)
+
+val print : 'a -> unit
+(** [print v = print_endline (dump v)] *)
+
+val unique_int : unit -> int
+(** Returns a unique integer (counts from 0) *)