l4/pkg/ocaml/contrib/camlp4/Camlp4/ErrorHandler.ml

   1 (****************************************************************************)
   2 (*                                                                          *)
   3 (*                              Objective Caml                              *)
   4 (*                                                                          *)
   5 (*                            INRIA Rocquencourt                            *)
   6 (*                                                                          *)
   7 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
   9 (*  the terms of the GNU Library General Public License, with the special   *)
  10 (*  exception on linking described in LICENSE at the top of the Objective   *)
  11 (*  Caml source tree.                                                       *)
  12 (*                                                                          *)
  13 (****************************************************************************)
  14
  15 (* Authors:
  16  * - Daniel de Rauglaudre: initial version
  17  * - Nicolas Pouillard: refactoring
  18  *)
  19 (* camlp4r *)
  20
  21 open Format;
  22
  23 module ObjTools = struct
  24
  25   value desc obj =
  26     if Obj.is_block obj then
  27       "tag = " ^ string_of_int (Obj.tag obj)
  28     else "int_val = " ^ string_of_int (Obj.obj obj);
  29
  30   (*Imported from the extlib*)
  31   value rec to_string r =
  32     if Obj.is_int r then
  33       let i = (Obj.magic r : int)
  34       in string_of_int i ^ " | CstTag" ^ string_of_int (i + 1)
  35     else (* Block. *)
  36       let rec get_fields acc =
  37         fun
  38         [ 0 -> acc
  39         | n -> let n = n-1 in get_fields [Obj.field r n :: acc] n ]
  40       in
  41       let rec is_list r =
  42         if Obj.is_int r then
  43           r = Obj.repr 0 (* [] *)
  44         else
  45           let s = Obj.size r and t = Obj.tag r in
  46           t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)
  47       in
  48       let rec get_list r =
  49         if Obj.is_int r then []
  50         else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in [h :: t]
  51       in
  52       let opaque name =
  53         (* XXX In future, print the address of value 'r'.  Not possible in
  54         * pure OCaml at the moment.
  55         *)
  56         "<" ^ name ^ ">"
  57       in
  58       let s = Obj.size r and t = Obj.tag r in
  59       (* From the tag, determine the type of block. *)
  60       match t with
  61       [ _ when is_list r ->
  62               let fields = get_list r in
  63               "[" ^ String.concat "; " (List.map to_string fields) ^ "]"
  64       | 0 ->
  65               let fields = get_fields [] s in
  66               "(" ^ String.concat ", " (List.map to_string fields) ^ ")"
  67       | x when x = Obj.lazy_tag ->
  68               (* Note that [lazy_tag .. forward_tag] are < no_scan_tag.  Not
  69               * clear if very large constructed values could have the same
  70               * tag. XXX *)
  71               opaque "lazy"
  72       | x when x = Obj.closure_tag ->
  73               opaque "closure"
  74       | x when x = Obj.object_tag ->
  75               let fields = get_fields [] s in
  76               let (_class, id, slots) =
  77                       match fields with
  78                       [ [h; h'::t] -> (h, h', t)
  79                       | _ -> assert False ]
  80               in
  81               (* No information on decoding the class (first field).  So just print
  82               * out the ID and the slots. *)
  83               "Object #" ^ to_string id ^ " (" ^ String.concat ", " (List.map to_string slots) ^ ")"
  84       | x when x = Obj.infix_tag ->
  85               opaque "infix"
  86       | x when x = Obj.forward_tag ->
  87               opaque "forward"
  88       | x when x < Obj.no_scan_tag ->
  89               let fields = get_fields [] s in
  90               "Tag" ^ string_of_int t ^
  91               " (" ^ String.concat ", " (List.map to_string fields) ^ ")"
  92       | x when x = Obj.string_tag ->
  93               "\"" ^ String.escaped (Obj.magic r : string) ^ "\""
  94       | x when x = Obj.double_tag ->
  95               string_of_float (Obj.magic r : float)
  96       | x when x = Obj.abstract_tag ->
  97               opaque "abstract"
  98       | x when x = Obj.custom_tag ->
  99               opaque "custom"
 100       | x when x = Obj.final_tag ->
 101               opaque "final"
 102       | _ ->
 103               failwith ("ObjTools.to_string: unknown tag (" ^ string_of_int t ^ ")") ];
 104
 105   value print ppf x = fprintf ppf "%s" (to_string x);
 106   value print_desc ppf x = fprintf ppf "%s" (desc x);
 107
 108 end;
 109
 110 value default_handler ppf x = do {
 111   let x = Obj.repr x;
 112   fprintf ppf "Camlp4: Uncaught exception: %s"
 113     (Obj.obj (Obj.field (Obj.field x 0) 0) : string);
 114   if Obj.size x > 1 then do {
 115     pp_print_string ppf " (";
 116     for i = 1 to Obj.size x - 1 do
 117       if i > 1 then pp_print_string ppf ", " else ();
 118       ObjTools.print ppf (Obj.field x i);
 119     done;
 120     pp_print_char ppf ')'
 121   }
 122   else ();
 123   fprintf ppf "@."
 124 };
 125
 126 value handler = ref (fun ppf default_handler exn -> default_handler ppf exn);
 127
 128 value register f =
 129   let current_handler = handler.val in
 130   handler.val :=
 131     fun ppf default_handler exn ->
 132       try f ppf exn with exn -> current_handler ppf default_handler exn;
 133
 134 module Register (Error : Sig.Error) = struct
 135   let current_handler = handler.val in
 136   handler.val :=
 137     fun ppf default_handler ->
 138       fun [ Error.E x -> Error.print ppf x
 139           | x -> current_handler ppf default_handler x ];
 140 end;
 141
 142
 143 value gen_print ppf default_handler =
 144   fun
 145   [ Out_of_memory -> fprintf ppf "Out of memory"
 146   | Assert_failure (file, line, char) ->
 147       fprintf ppf "Assertion failed, file %S, line %d, char %d"
 148                   file line char
 149   | Match_failure (file, line, char) ->
 150       fprintf ppf "Pattern matching failed, file %S, line %d, char %d"
 151                   file line char
 152   | Failure str -> fprintf ppf "Failure: %S" str
 153   | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str
 154   | Sys_error str -> fprintf ppf "I/O error: %S" str
 155   | Stream.Failure -> fprintf ppf "Parse failure"
 156   | Stream.Error str -> fprintf ppf "Parse error: %s" str
 157   | x -> handler.val ppf default_handler x ];
 158
 159 value print ppf = gen_print ppf default_handler;
 160
 161 value try_print ppf = gen_print ppf (fun _ -> raise);
 162
 163 value to_string exn =
 164   let buf = Buffer.create 128 in
 165   let () = bprintf buf "%a" print exn in
 166   Buffer.contents buf;
 167
 168 value try_to_string exn =
 169   let buf = Buffer.create 128 in
 170   let () = bprintf buf "%a" try_print exn in
 171   Buffer.contents buf;