home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / lib / printexc.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  2.0 KB  |  68 lines  |  [TEXT/MPS ]

  1. (* A catch-all exception handler *)
  2.  
  3. #open "exc";;
  4. #open "eq";;
  5. #open "int";;
  6. #open "fvect";;
  7. #open "io";;
  8. #open "obj";;
  9. #open "sys";;
  10.  
  11. type qualid = {qual:string; id:string}
  12. ;;
  13.  
  14. let f fct arg =
  15.   try
  16.     fct arg
  17.   with x ->
  18.     flush std_out;
  19.     begin match x with
  20.       Out_of_memory ->
  21.         prerr_string "Out of memory"
  22.     | Match_failure(file, first_char, last_char) ->
  23.         prerr_string "Pattern matching failed, file ";
  24.         prerr_string file;
  25.         prerr_string ", chars "; prerr_int first_char;
  26.         prerr_string "-"; prerr_int last_char
  27.     | Failure s ->
  28.         prerr_string "Evaluation failed : "; prerr_string s
  29.     | Invalid_argument s ->
  30.         prerr_string "Invalid argument : "; prerr_string s
  31.     | Sys_error msg ->
  32.         prerr_string "System call failed : ";
  33.         prerr_string msg
  34.     | x ->
  35.         let tag = obj_tag (repr x) in
  36.           prerr_string "Uncaught exception ";
  37.           prerr_string (string_of_int tag);
  38.           begin try
  39.             let ic = open_in_bin command_line.(0) in
  40.             let pos_hdr = in_channel_length ic - 20 in
  41.             seek_in ic pos_hdr;
  42.             let size_code = input_binary_int ic in
  43.             let size_data = input_binary_int ic in
  44.             let size_symb = input_binary_int ic in
  45.             let size_debug = input_binary_int ic in
  46.               seek_in ic (pos_hdr - size_debug - size_symb);
  47.               input_value ic;
  48.               input_value ic;
  49.               let tag_exn_table = (input_value ic : (qualid * int) vect) in
  50.                 if tag >= vect_length tag_exn_table then
  51.                   prerr_string " (never compiled)"
  52.                 else begin
  53.                   let (q,s) = tag_exn_table.(tag) in
  54.                   prerr_string " (";
  55.                   prerr_string q.qual;
  56.                   prerr_string "__";
  57.                   prerr_string q.id;
  58.                   prerr_string ")"
  59.                 end;
  60.             close_in ic
  61.           with _ ->
  62.             ()
  63.           end
  64.     end;
  65.     prerr_char `\n`;
  66.     io__exit 2
  67. ;;
  68.