Source

spotlib / lib / xobj.ml

The for_4.02 branch has multiple heads

Full commit
open Base
open Obj

type tag = 
  | Abstract
  | Closure
  | Custom
  | Double
  | Double_array
  | Final
  | Forward
  | Infix
  | Int (* this is a virtual one *)
  | Lazy
  | No_scan
  | Object
  | Out_of_heap
  | String
  | Unaligned
  | Unknown of int 

let parse_tag t = 
  if t = int_tag              then Int
  else if t = double_tag      then Double
  else if t = double_array_tag then Double_array
  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 No_scan
  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"
  | Double ->      "double"
  | Double_array -> "double_array"
  | String ->      "string"
  | Lazy ->        "lazy"
  | Closure ->     "closure"
  | Object ->      "object"
  | Infix ->       "infix"
  | Forward ->     "forward"
  | No_scan ->     "no_scan"
  | 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
    | _ -> 
        (* CR jfuruse: I believe there are some cases not covered by this *)
        (* Double_array for example *)
        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