Commits

Anonymous committed bc99a3b

added Xobj

Comments (0)

Files changed (4)

    xformat
    xfilename
    xunix
+   xobj
    xprintf
    xsys
    xset
   include Xprintexc
 end
 
+module Obj = struct
+  include Obj
+  include Xobj
+end
+
 module URL = URL
 
 module Gc = struct
+open Base
+open Obj
+
+type tag = [ `abstract
+           | `closure
+           | `custom
+           | `final
+           | `forward
+           | `infix
+           | `int
+           | `lazy_
+           | `noscan
+           | `object_
+           | `out_of_heap
+           | `string
+           | `unaligned
+           | `unknown of int 
+           ]
+
+let parse_tag t = 
+  if t = int_tag              then `int
+  else if t = string_tag      then `string
+  else if t = lazy_tag        then `lazy_
+  else if t = closure_tag     then `closure
+  else if t = object_tag      then `object_
+  else if t = infix_tag       then `infix
+  else if t = forward_tag     then `forward
+  else if t = no_scan_tag     then `noscan
+  else if t = abstract_tag    then `abstract
+  else if t = custom_tag      then `custom
+  else if t = final_tag       then `final
+  else if t = out_of_heap_tag then `out_of_heap
+  else if t = unaligned_tag   then `unaligned
+  else `unknown t
+
+let tag_name = function
+  | `int ->         "int"
+  | `string ->      "string"
+  | `lazy_ ->       "lazy"
+  | `closure ->     "closure"
+  | `object_ ->     "object"
+  | `infix ->       "infix"
+  | `forward ->     "forward"
+  | `noscan ->      "noscan"
+  | `abstract ->    "abstract"
+  | `custom ->      "custom"
+  | `final ->       "final"
+  | `out_of_heap -> "out_of_heap"
+  | `unaligned ->   "unaligned"
+  | `unknown x ->   string_of_int x 
+
+let dump o = 
+  let open Format in
+  let rec dump ppf o =
+    let t = parse_tag & tag o in
+    match t with
+    | `int -> fprintf ppf "%d" & obj o
+    | `double -> fprintf ppf "%.4f" & obj o
+    | `string -> fprintf ppf "%S" & obj o
+    | _ -> 
+       fprintf ppf "[%s @[" & tag_name t;
+       let s = size o in
+       for i = 0 to s - 1 do
+         dump ppf (field o i);
+         fprintf ppf "@ "
+       done;
+       fprintf ppf "@]]"
+  in
+  eprintf "%a@." dump o
+type tag = [ `abstract
+           | `closure
+           | `custom
+           | `final
+           | `forward
+           | `infix
+           | `int
+           | `lazy_
+           | `noscan
+           | `object_
+           | `out_of_heap
+           | `string
+           | `unaligned
+           | `unknown of int 
+           ]
+
+val parse_tag : int -> tag
+
+val tag_name : tag -> string
+
+val dump : Obj.t -> unit