libmojave/util/lm_position.ml

   1 (*
   2  * Lm_position information for debugging.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (C) 2002-2005 Mojave Group, Caltech
   8  *
   9  * This library is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU Lesser General Public
  11  * License as published by the Free Software Foundation,
  12  * version 2.1 of the License.
  13  *
  14  * This library 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 GNU
  17  * Lesser General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU Lesser General Public
  20  * License along with this library; if not, write to the Free Software
  21  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  22  *
  23  * Additional permission is given to link this library with the
  24  * OpenSSL project's "OpenSSL" library, and with the OCaml runtime,
  25  * and you may distribute the linked executables.  See the file
  26  * LICENSE.libmojave for more details.
  27  *
  28  * Author: Jason Hickey
  29  * @email{jyh@cs.caltech.edu}
  30  * @end[license]
  31  *)
  32 open Lm_debug
  33 open Lm_symbol
  34 open Lm_location
  35 open Lm_printf
  36
  37 let debug_pos =
  38    create_debug (**)
  39       { debug_name = "pos";
  40         debug_description = "print verbose position information for debugging";
  41         debug_value = false
  42       }
  43
  44 let trace_pos =
  45    create_debug (**)
  46       { debug_name = "trace_pos";
  47         debug_description = "print position trace for debugging";
  48         debug_value = false
  49       }
  50
  51 (************************************************************************
  52  * TYPES
  53  ************************************************************************)
  54
  55 (*
  56  * We include the name of the module where
  57  * the position is created.  The value is a location,
  58  * a raw value, or a value with another position.
  59  *)
  60 (* %%MAGICBEGIN%% *)
  61 type 'a pos = string * 'a exn_loc
  62
  63 and 'a exn_loc =
  64    DebugLoc     of loc
  65  | DebugBase    of 'a
  66  | DebugCons    of 'a * 'a pos
  67  | DebugConsLoc of loc * 'a pos
  68  | DebugPos     of 'a pos * 'a pos
  69  | DebugInt     of int * 'a pos
  70  | DebugString  of string * 'a pos
  71  | DebugSymbol  of symbol * 'a pos
  72  | DebugDel     of (out_channel -> unit) * loc
  73  | DebugDelExp  of (out_channel -> unit) * 'a pos
  74 (* %%MAGICEND%% *)
  75
  76 (*
  77  * Module for creating positions.
  78  * You have to specify the name of the module
  79  * where the exception are being created: use
  80  * MakePos in each file where Name.name is set
  81  * to the name of the module.
  82  *)
  83 module type PosSig =
  84 sig
  85    type t
  86
  87    (* Creating positions *)
  88    val loc_exp_pos : loc -> t pos
  89    val loc_pos     : loc -> t pos -> t pos
  90    val base_pos    : t -> t pos
  91    val cons_pos    : t -> t pos -> t pos
  92    val pos_pos     : t pos -> t pos -> t pos
  93    val int_pos     : int -> t pos -> t pos
  94    val string_pos  : string -> t pos -> t pos
  95    val symbol_pos  : symbol -> t pos -> t pos
  96    val del_pos     : (out_channel -> unit) -> loc -> t pos
  97    val del_exp_pos : (out_channel -> unit) -> t pos -> t pos
  98
  99    (* Utilities *)
 100    val loc_of_pos : t pos -> loc
 101    val pp_print_pos : formatter -> t pos -> unit
 102 end
 103
 104 module type NameSig =
 105 sig
 106    type t
 107
 108    (* This is the name of the module where the position info is created *)
 109    val name : string
 110
 111    (* Utilities for managing values *)
 112    val loc_of_value : t -> loc
 113    val pp_print_value  : formatter -> t -> unit
 114 end
 115
 116 (************************************************************************
 117  * IMPLEMENTATION
 118  ************************************************************************)
 119
 120 module MakePos (Name : NameSig) =
 121 struct
 122    open Name
 123
 124    type t = Name.t
 125
 126    (*
 127     * Get the source location for an exception.
 128     *)
 129    let rec loc_of_pos (_, pos) =
 130       match pos with
 131          DebugLoc loc
 132        | DebugDel (_, loc)
 133        | DebugConsLoc (loc, _) ->
 134             loc
 135        | DebugBase x ->
 136             loc_of_value x
 137        | DebugCons (_, pos)
 138        | DebugPos (_, pos)
 139        | DebugInt (_, pos)
 140        | DebugString (_, pos)
 141        | DebugSymbol (_, pos)
 142        | DebugDelExp (_, pos) ->
 143             loc_of_pos pos
 144
 145    (*
 146     * Print debugging info.
 147     *)
 148    let rec pp_print_pos buf (name, e) =
 149       match e with
 150          DebugLoc _ ->
 151             ()
 152
 153        | DebugBase x ->
 154             fprintf buf "@ %s.%a" name pp_print_value x
 155
 156        | DebugCons (x, pos) ->
 157             pp_print_pos buf pos;
 158             fprintf buf "@ /%s.%a" name pp_print_value x
 159
 160        | DebugConsLoc (_, pos) ->
 161             pp_print_pos buf pos
 162
 163        | DebugPos (pos1, pos2) ->
 164             fprintf buf "@ @[<v 3>Called from: %s%a@]%a" (**)
 165                name
 166                pp_print_pos pos1
 167                pp_print_pos pos2
 168
 169        | DebugString (s, pos) ->
 170             pp_print_pos buf pos;
 171             fprintf buf "@ /%s.%s" name s
 172
 173        | DebugInt (i, pos) ->
 174             pp_print_pos buf pos;
 175             fprintf buf "@ %s.%d" name i
 176
 177        | DebugSymbol (v, pos) ->
 178             pp_print_pos buf pos;
 179             fprintf buf "@ %s.%a" name output_symbol v
 180
 181        | DebugDel (f, _) ->
 182             fprintf buf "@ %t" f
 183
 184        | DebugDelExp (f, pos) ->
 185             pp_print_pos buf pos;
 186             fprintf buf "@ %t" f
 187
 188    (*
 189     * Real error printer.
 190     *)
 191    let pp_print_pos buf pos =
 192       fprintf buf "@[<v 3>%a" pp_print_location (loc_of_pos pos);
 193       if !debug_pos then
 194          pp_print_pos buf pos;
 195       fprintf buf "@]"
 196
 197    (*
 198     * Base values.
 199     *)
 200    let loc_exp_pos loc =
 201       if !trace_pos then
 202          eprintf "Lm_trace: %s.%a@." name pp_print_location loc;
 203       name, DebugLoc loc
 204
 205    let loc_pos loc pos =
 206       if !trace_pos then
 207          eprintf "Lm_trace: %s.loc@." name;
 208       name, DebugConsLoc (loc, pos)
 209
 210    let base_pos x =
 211       if !trace_pos then
 212          eprintf "Lm_trace: %s.base@." name;
 213       name, DebugBase x
 214
 215    let pos_pos pos1 pos2 =
 216       if !trace_pos then
 217          eprintf "Lm_trace: %s.pos@." name;
 218       if !debug_pos then
 219          name, DebugPos (pos1, pos2)
 220       else
 221          pos2
 222
 223    let cons_pos x pos =
 224       if !trace_pos then
 225          eprintf "Lm_trace: %s.cons@." name;
 226       if !debug_pos then
 227          name, DebugCons (x, pos)
 228       else
 229          pos
 230
 231    let int_pos i pos =
 232       if !trace_pos then
 233          eprintf "Lm_trace: %s.int: %d@." name i;
 234       if !debug_pos then
 235          name, DebugInt (i, pos)
 236       else
 237          pos
 238
 239    let string_pos s pos =
 240       if !trace_pos then
 241          eprintf "Lm_trace: %s.string: %s@." name s;
 242       if !debug_pos then
 243          name, DebugString (s, pos)
 244       else
 245          pos
 246
 247    let symbol_pos v pos =
 248       if !trace_pos then
 249          eprintf "Lm_trace: %s.symbol: %a@." name output_symbol v;
 250       if !debug_pos then
 251          name, DebugSymbol (v, pos)
 252       else
 253          pos
 254
 255    let del_pos f loc =
 256       if !trace_pos then
 257          eprintf "Lm_trace: %s.delayed@." name;
 258       name, DebugDel (f, loc)
 259
 260    let del_exp_pos f pos =
 261       if !trace_pos then
 262          eprintf "Lm_trace: %s.delayed@." name;
 263       if !debug_pos then
 264          name, DebugDelExp (f, pos)
 265       else
 266          pos
 267 end
 268
 269 (*!
 270  * @docoff
 271  *
 272  * -*-
 273  * Local Variables:
 274  * Caml-master: "compile"
 275  * End:
 276  * -*-
 277  *)