home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Printexc.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  1.9 KB  |  61 lines  |  [TEXT/R*ch]
  1. (* A catch-all exception handler *)
  2.  
  3. open Obj BasicIO Nonstdio;
  4.  
  5. type qualid = {qual:string, id:string};
  6.  
  7. val exnTag = obj_tag (repr (let exception DUMMY in DUMMY end));
  8.  
  9. fun errString s = output(std_err, s);
  10.  
  11. fun f fct arg =
  12. (
  13.   (fct arg)
  14.   handle x =>
  15.     (
  16.     flush_out std_out;
  17.     (case x of
  18.          Out_of_memory =>
  19.            errString "Out of memory"
  20.        | Fail s =>
  21.            (errString "Evaluation failed: "; errString s)
  22.        | Invalid_argument s =>
  23.            (errString "Invalid argument: "; errString s)
  24.        | SysErr(msg, _) =>
  25.            (errString "I/O failure: "; errString msg)
  26.        | x =>
  27.            let val tag = obj_tag (repr x) in
  28.              errString "Uncaught exception ";
  29.              errString (makestring tag); flush_out std_err;
  30.              let val is = open_in_bin (Vector.sub(Miscsys.command_line, 0))
  31.                  val pos_hdr = in_stream_length is - 20
  32.                  val () = seek_in is pos_hdr
  33.                  val size_code = input_binary_int is
  34.                  val size_data = input_binary_int is
  35.                  val size_symb = input_binary_int is
  36.                  val size_debug = input_binary_int is
  37.                  val () = seek_in is (pos_hdr - size_debug - size_symb)
  38.                  val _ = input_value is
  39.                  val _ = input_value is
  40.                  val tag_exn_table =
  41.                        (input_value is : (qualid * int) Vector.vector)
  42.              in
  43.                if tag >= Vector.length tag_exn_table then
  44.                  errString " (never compiled)"
  45.                else
  46.                  let val (q,s) = Vector.sub(tag_exn_table, tag)
  47.                      val {qual, id} = q
  48.                  in
  49.                    errString " ("; errString qual; errString ".";
  50.                    errString id; errString ")"
  51.                  end;
  52.                close_in is
  53.              end
  54.                handle _ => ()
  55.            end
  56.     );
  57.     errString "\n"; flush_out std_err;
  58.     BasicIO.exit 2
  59.     )
  60. );
  61.