arch/mir/util/mir_pos.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 open Location
  32
  33 open Fir_print
  34 open Fir_state
  35
  36 open Mir
  37 open Mir_ds
  38 open Mir_exn
  39 open Mir_print
  40
  41 (*
  42  * Location of exception.
  43  *)
  44 type item =
  45    Exp of exp
  46  | Atom of atom
  47  | AtomClass of atom_class
  48  | Symbol of var
  49  | String of string
  50
  51 type pos = item Position.pos
  52
  53 (*
  54  * FIR exception.
  55  *)
  56 exception MirException of pos * mir_error
  57
  58 (************************************************************************
  59  * UTILITIES
  60  ************************************************************************)
  61
  62 (*
  63  * Get the source location for an exception.
  64  *)
  65 let string_loc = bogus_loc "<Mir_pos>"
  66
  67 let rec loc_of_value x =
  68    match x with
  69       Exp e ->
  70          loc_of_exp e
  71     | Atom _
  72     | AtomClass _
  73     | Symbol _
  74     | String _ ->
  75          string_loc
  76
  77 (*
  78  * Print debugging info.
  79  *)
  80 let rec pp_print_value buf x =
  81    match x with
  82       Exp e ->
  83          pp_print_expr_size (exn_expr_size ()) buf e
  84
  85     | Atom a ->
  86          pp_print_atom buf a
  87
  88     | AtomClass ac ->
  89          pp_print_atom_class buf ac
  90
  91     | Symbol v ->
  92          pp_print_symbol buf v
  93
  94     | String s ->
  95          pp_print_string buf s
  96
  97 (************************************************************************
  98  * CONSTRUCTION
  99  ************************************************************************)
 100
 101 module type PosSig =
 102 sig
 103    val loc_pos : loc -> pos
 104
 105    val exp_pos : exp -> pos
 106    val var_exp_pos : var -> pos
 107    val string_exp_pos : string -> pos
 108    val string_pos : string -> pos -> pos
 109    val pos_pos : pos -> pos -> pos
 110    val int_pos : int -> pos -> pos
 111    val var_pos : var -> pos -> pos
 112    val atom_pos : atom -> pos -> pos
 113    val atom_class_pos : atom_class -> pos -> pos
 114
 115    val del_pos : (formatter -> unit) -> loc -> pos
 116    val del_exp_pos : (formatter -> unit) -> pos -> pos
 117
 118    (* Utilities *)
 119    val loc_of_pos : pos -> loc
 120    val pp_print_pos : formatter -> pos -> unit
 121 end
 122
 123 module type NameSig =
 124 sig
 125    val name : string
 126 end
 127
 128 module MakePos (Name : NameSig) : PosSig =
 129 struct
 130    module Name' =
 131    struct
 132       type t = item
 133
 134       let name = Name.name
 135
 136       let loc_of_value = loc_of_value
 137       let pp_print_value = pp_print_value
 138    end
 139
 140    module Pos = Position.MakePos (Name')
 141
 142    include Pos
 143
 144    let exp_pos e = base_pos (Exp e)
 145    let atom_pos a pos = cons_pos (Atom a) pos
 146    let atom_class_pos ac pos = cons_pos (AtomClass ac) pos
 147    let var_exp_pos v = base_pos (Symbol v)
 148    let string_exp_pos s = base_pos (String s)
 149    let var_pos = symbol_pos
 150 end
 151
 152 (*!
 153  * @docoff
 154  *
 155  * -*-
 156  * Local Variables:
 157  * Caml-master: "compile"
 158  * End:
 159  * -*-
 160  *)