arch/mir/util/mir_exn_print.ml

   1 (*
   2  * Normal MIR exceptions.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (C) 2001 Jason Hickey, Caltech
   8  *
   9  * This program is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU General Public License
  11  * as published by the Free Software Foundation; either version 2
  12  * of the License, or (at your option) any later version.
  13  *
  14  * This program is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17  * GNU General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU General Public License
  20  * along with this program; if not, write to the Free Software
  21  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22  *
  23  * Author: Jason Hickey
  24  * @email{jyh@cs.caltech.edu}
  25  * @end[license]
  26  *)
  27 open Format
  28
  29 open Debug
  30 open Symbol
  31
  32 open Fir_print
  33
  34 open Mir
  35 open Mir_exn
  36 open Mir_pos
  37 open Mir_print
  38
  39 module Pos = MakePos (struct let name = "Mir_exn_print" end)
  40 open Pos
  41
  42 (*
  43  * Semant exception printer.
  44  *)
  45 let pp_print_error buf exn =
  46    match exn with
  47       UnboundVar v ->
  48          Format.fprintf buf "unbound variable: %a" pp_print_symbol v
  49     | UnboundType v ->
  50          Format.fprintf buf "unbound type: %a" pp_print_symbol v
  51     | ArityMismatch (i, j) ->
  52          Format.fprintf buf "arity mismatch: wanted %d, got %d" i j
  53     | StringError s ->
  54          Format.pp_print_string buf s
  55     | StringIntError (s, i) ->
  56          Format.fprintf buf "%s: %d" s i
  57     | StringVarError (s, v) ->
  58          Format.fprintf buf "%s: %a" s pp_print_symbol v
  59     | StringAtomError (s, a) ->
  60          Format.fprintf buf "@[<hv 3>%s:@ %a@]" s pp_print_atom a
  61     | StringTypeError (s, ty) ->
  62          Format.fprintf buf "@[<hv 3>%s:@ %a@]" s pp_print_type ty
  63     | StringIntTypeError (s, i, ty) ->
  64          Format.fprintf buf "@[<hv 3>%s.%d:@ %a@]" s i pp_print_type ty
  65     | StringAtomClassError (s, ac) ->
  66          Format.fprintf buf "@[<hv 3>%s:@ %a@]" s pp_print_atom_class ac
  67     | StringFormatError (s, f) ->
  68          Format.fprintf buf "@[<hv 3>%s:@ %t@]" s f
  69     | ImplicitCoercion a ->
  70          Format.fprintf buf "Implicit coercion not allowed: %a" pp_print_atom a
  71     | ImplicitCoercion2 (d, s) ->
  72          Format.fprintf buf "Implicit coercion from@ %a@ to@ %a@ not allowed" (**)
  73             pp_print_atom_class s
  74             pp_print_atom_class d
  75     | NotImplemented s ->
  76          Format.fprintf buf "Not implemented: %s" s
  77     | InternalError s ->
  78          Format.fprintf buf "Internal error: %s" s
  79
  80 (*
  81  * Exception printer.
  82  *)
  83 let pp_print_exn buf e =
  84    match e with
  85       MirException (loc, exn) ->
  86          Format.fprintf buf "@[<v 0>%a@ @[<hv 3>*** MIR Error: %a@]@]" (**)
  87             pp_print_pos loc
  88             pp_print_error exn
  89     | exn ->
  90          Fir_exn_print.pp_print_exn buf exn
  91
  92 (*
  93  * Exception handler.
  94  *)
  95 let catch f x =
  96    try f x with
  97       MirException _
  98     | Fir_pos.FirException _ as exn ->
  99          Format.eprintf "%a@." pp_print_exn exn;
 100          exit 2
 101
 102 (*!
 103  * @docoff
 104  *
 105  * -*-
 106  * Local Variables:
 107  * Caml-master: "compile"
 108  * End:
 109  * -*-
 110  *)