diff options
Diffstat (limited to 'ocaml-binary-annot/camlp4/Camlp4/ErrorHandler.ml')
| -rw-r--r-- | ocaml-binary-annot/camlp4/Camlp4/ErrorHandler.ml | 171 |
1 files changed, 171 insertions, 0 deletions
diff --git a/ocaml-binary-annot/camlp4/Camlp4/ErrorHandler.ml b/ocaml-binary-annot/camlp4/Camlp4/ErrorHandler.ml new file mode 100644 index 0000000000..231efed904 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/ErrorHandler.ml @@ -0,0 +1,171 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +(* camlp4r *) + +open Format; + +module ObjTools = struct + + value desc obj = + if Obj.is_block obj then + "tag = " ^ string_of_int (Obj.tag obj) + else "int_val = " ^ string_of_int (Obj.obj obj); + + (*Imported from the extlib*) + value rec to_string r = + if Obj.is_int r then + let i = (Obj.magic r : int) + in string_of_int i ^ " | CstTag" ^ string_of_int (i + 1) + else (* Block. *) + let rec get_fields acc = + fun + [ 0 -> acc + | n -> let n = n-1 in get_fields [Obj.field r n :: acc] n ] + in + let rec is_list r = + if Obj.is_int r then + r = Obj.repr 0 (* [] *) + else + let s = Obj.size r and t = Obj.tag r in + t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) + in + let rec get_list r = + if Obj.is_int r then [] + else let h = Obj.field r 0 and t = get_list (Obj.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 = Obj.size r and t = Obj.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 to_string fields) ^ "]" + | 0 -> + let fields = get_fields [] s in + "(" ^ String.concat ", " (List.map to_string fields) ^ ")" + | x when x = Obj.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 = Obj.closure_tag -> + opaque "closure" + | x when x = Obj.object_tag -> + let fields = get_fields [] s in + let (_class, 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 #" ^ to_string id ^ " (" ^ String.concat ", " (List.map to_string slots) ^ ")" + | x when x = Obj.infix_tag -> + opaque "infix" + | x when x = Obj.forward_tag -> + opaque "forward" + | x when x < Obj.no_scan_tag -> + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ + " (" ^ String.concat ", " (List.map to_string fields) ^ ")" + | x when x = Obj.string_tag -> + "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" + | x when x = Obj.double_tag -> + string_of_float (Obj.magic r : float) + | x when x = Obj.abstract_tag -> + opaque "abstract" + | x when x = Obj.custom_tag -> + opaque "custom" + | x when x = Obj.final_tag -> + opaque "final" + | _ -> + failwith ("ObjTools.to_string: unknown tag (" ^ string_of_int t ^ ")") ]; + + value print ppf x = fprintf ppf "%s" (to_string x); + value print_desc ppf x = fprintf ppf "%s" (desc x); + +end; + +value default_handler ppf x = do { + let x = Obj.repr x; + fprintf ppf "Camlp4: Uncaught exception: %s" + (Obj.obj (Obj.field (Obj.field x 0) 0) : string); + if Obj.size x > 1 then do { + pp_print_string ppf " ("; + for i = 1 to Obj.size x - 1 do + if i > 1 then pp_print_string ppf ", " else (); + ObjTools.print ppf (Obj.field x i); + done; + pp_print_char ppf ')' + } + else (); + fprintf ppf "@." +}; + +value handler = ref (fun ppf default_handler exn -> default_handler ppf exn); + +value register f = + let current_handler = handler.val in + handler.val := + fun ppf default_handler exn -> + try f ppf exn with exn -> current_handler ppf default_handler exn; + +module Register (Error : Sig.Error) = struct + let current_handler = handler.val in + handler.val := + fun ppf default_handler -> + fun [ Error.E x -> Error.print ppf x + | x -> current_handler ppf default_handler x ]; +end; + + +value gen_print ppf default_handler = + fun + [ Out_of_memory -> fprintf ppf "Out of memory" + | Assert_failure (file, line, char) -> + fprintf ppf "Assertion failed, file %S, line %d, char %d" + file line char + | Match_failure (file, line, char) -> + fprintf ppf "Pattern matching failed, file %S, line %d, char %d" + file line char + | Failure str -> fprintf ppf "Failure: %S" str + | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str + | Sys_error str -> fprintf ppf "I/O error: %S" str + | Stream.Failure -> fprintf ppf "Parse failure" + | Stream.Error str -> fprintf ppf "Parse error: %s" str + | x -> handler.val ppf default_handler x ]; + +value print ppf = gen_print ppf default_handler; + +value try_print ppf = gen_print ppf (fun _ -> raise); + +value to_string exn = + let buf = Buffer.create 128 in + let () = bprintf buf "%a" print exn in + Buffer.contents buf; + +value try_to_string exn = + let buf = Buffer.create 128 in + let () = bprintf buf "%a" try_print exn in + Buffer.contents buf; |