src/utils/cdk/printexc2.ml

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Printf2
  21 open Printf
  22
  23 let locfmt =
  24   Obj.magic (match Sys.os_type with
  25   | "MacOS" -> "File \"%s\"; line %d; characters %d to %d ### %s"
  26   | _ -> "File \"%s\", line %d, characters %d-%d: %s")
  27 ;;
  28
  29 let field x i =
  30   let f = Obj.field x i in
  31   if not (Obj.is_block f) then
  32     sprintf "%d" (Obj.magic f : int)           (* can also be a char *)
  33   else if Obj.tag f = Obj.string_tag then
  34     sprintf "\"%s\"" (String.escaped (Obj.magic f : string))
  35   else if Obj.tag f = Obj.double_tag then
  36     string_of_float (Obj.magic f : float)
  37   else
  38     "_"
  39 ;;
  40 let rec other_fields x i =
  41   if i >= Obj.size x then ""
  42   else sprintf ", %s%s" (field x i) (other_fields x (i+1))
  43 ;;
  44 let fields x =
  45   match Obj.size x with
  46   | 0 -> ""
  47   | 1 -> ""
  48   | 2 -> sprintf "(%s)" (field x 1)
  49   | n -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
  50 ;;
  51
  52 let printers = ref []
  53
  54 let rec check exn printers =
  55   match printers with
  56     [] -> raise Not_found
  57   | printer :: printers ->
  58       try printer exn with _ ->
  59           check exn printers
  60
  61 let to_string = function
  62   | Out_of_memory -> "Out of memory";
  63   | Stack_overflow -> "Stack overflow";
  64   | Match_failure(file, first_char, last_char) ->
  65       sprintf locfmt file 0 first_char last_char "Pattern matching failed";
  66   | Assert_failure(file, first_char, last_char) ->
  67       sprintf locfmt file 0 first_char last_char "Assertion failed";
  68   | x ->
  69       try
  70         check x !printers
  71       with _ ->
  72       let x = Obj.repr x in
  73       let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
  74       constructor ^ (fields x)
  75 ;;
  76
  77 let print fct arg =
  78   try
  79     fct arg
  80   with x ->
  81     eprintf "Uncaught exception: %s\n" (to_string x);
  82     flush stderr;
  83     raise x
  84
  85 let register_exn f = printers := f :: !printers
  86
  87 let catch s f x =
  88   try f x with
  89     e ->
  90       lprintf_nl "Uncaught exception in %s: %s" s (to_string e)
  91
  92 let catch2 s f x y =
  93   try f x y with
  94     e ->
  95       lprintf_nl "Uncaught exception in %s: %s" s (to_string e)
  96
  97 let vcatchexn s f =
  98   try Some (f ()) with
  99     e ->
 100       lprintf_nl "Uncaught exception in %s: %s" s (to_string e);
 101       None
 102
 103 let _ =
 104   register_exn (fun e ->
 105       match e with
 106         Unix.Unix_error (e, f, arg) ->
 107           Printf.sprintf "%s failed%s: %s" f (if arg = "" then "" else
 108               " on " ^ arg) (Unix.error_message e)
 109           | _ -> raise e
 110   )