menhirlib/engine.ml

   1 (**************************************************************************)
   2 (*                                                                        *)
   3 (*  Menhir                                                                *)
   4 (*                                                                        *)
   5 (*  François Pottier, INRIA Rocquencourt                                  *)
   6 (*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
   7 (*                                                                        *)
   8 (*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
   9 (*  et en Automatique. All rights reserved. This file is distributed      *)
  10 (*  under the terms of the GNU Library General Public License, with the   *)
  11 (*  special exception on linking described in file LICENSE.               *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 open EngineTypes
  16
  17 (* The LR parsing engine. *)
  18
  19 (* This module is used:
  20
  21    - at compile time, if so requested by the user, via the --interpret options;
  22    - at run time, in the table-based back-end. *)
  23
  24 module Make (T : TABLE) = struct
  25
  26   (* This propagates type and exception definitions. *)
  27
  28   include T
  29
  30   let _eRR : exn =
  31     Error
  32
  33   (* --------------------------------------------------------------------------- *)
  34
  35   (* [discard] takes a token off the input stream, queries the lexer
  36      for a new one, and stores it into [env.token], overwriting the
  37      previous token. If [env.shifted] has not yet reached its limit,
  38      it is incremented. *)
  39
  40   let discard env =
  41     let lexbuf = env.lexbuf in
  42     let token = env.lexer lexbuf in
  43     env.token <- token;
  44     Log.lookahead_token lexbuf (T.token2terminal token);
  45     let shifted = env.shifted + 1 in
  46     if shifted >= 0 then
  47       env.shifted <- shifted
  48
  49   (* --------------------------------------------------------------------------- *)
  50
  51   (* The type [void] is empty. Many of the functions below have return type
  52      [void]. This guarantees that they never return a value. Instead, they
  53      must stop by raising an exception: either [Accept] or [Error]. *)
  54
  55   type void
  56
  57   (* --------------------------------------------------------------------------- *)
  58
  59   (* In the code-based back-end, the [run] function is sometimes responsible
  60      for pushing a new cell on the stack. This is motivated by code sharing
  61      concerns. In this interpreter, there is no such concern; [run]'s caller
  62      is always responsible for updating the stack. *)
  63
  64   (* In the code-based back-end, there is a [run] function for each state
  65      [s]. This function can behave in two slightly different ways, depending
  66      on when it is invoked, or (equivalently) depending on [s].
  67
  68      If [run] is invoked after shifting a terminal symbol (or, equivalently,
  69      if [s] has a terminal incoming symbol), then [run] discards a token,
  70      unless [s] has a default reduction on [#]. (Indeed, in that case,
  71      requesting the next token might drive the lexer off the end of the input
  72      stream.)
  73
  74      If, on the other hand, [run] is invoked after performing a goto transition,
  75      or invoked directly by an entry point, then there is nothing to discard.
  76
  77      These two cases are reflected in [CodeBackend.gettoken].
  78
  79      Here, the code is structured in a slightly different way. It is up to
  80      the caller of [run] to indicate whether to discard a token. *)
  81
  82   let rec run env please_discard : void =
  83
  84     (* Log the fact that we just entered this state. *)
  85
  86     let s = env.current in
  87     Log.state s;
  88
  89     (* If [please_discard] is set, discard a token and fetch the next one. *)
  90
  91     (* This flag is set when [s] is being entered by shifting a terminal
  92        symbol and [s] does not have a default reduction on [#]. *)
  93
  94     if please_discard then
  95       discard env;
  96
  97     (* Examine what situation we are in. This case analysis is analogous to
  98        that performed in [CodeBackend.gettoken], in the sub-case where we do
  99        not have a terminal incoming symbol. *)
 100
 101     T.default_reduction
 102       s
 103       reduce   (* there is a default reduction; perform it *)
 104       continue (* there is none; continue below *)
 105       env
 106
 107   and continue env : void =
 108
 109     (* There is no default reduction. Consult the current lookahead token
 110        so as to determine which action should be taken. *)
 111
 112     (* Peeking at the first input token, without taking it off the input
 113        stream, is normally done by reading [env.token]. However, we check
 114        [env.shifted] first: if it is -1, then the lookahead token is the
 115        [error] token. *)
 116
 117     (* Note that, if we just called [discard] above, then the lookahead
 118        token cannot be [error]. *)
 119
 120     if env.shifted = (-1) then begin
 121       Log.resuming_error_handling();
 122       error env
 123     end
 124     else
 125       action env
 126
 127   (* --------------------------------------------------------------------------- *)
 128
 129   (* When [action] is invoked, we know that the current state does not have
 130      a default reduction. We also know that the current lookahead token is
 131      not [error]: it is a real token, stored in [env.token]. *)
 132
 133   and action env : void =
 134
 135     (* We consult the two-dimensional action table, indexed by the
 136        current state and the current lookahead token, in order to
 137        determine which action should be taken. *)
 138
 139     let token = env.token in
 140     T.action
 141       env.current                    (* determines a row *)
 142       (T.token2terminal token)       (* determines a column *)
 143       (T.token2value token)
 144       shift                          (* shift continuation *)
 145       reduce                         (* reduce continuation *)
 146       initiate                       (* failure continuation *)
 147       env
 148
 149   (* --------------------------------------------------------------------------- *)
 150
 151   (* This function takes care of shift transitions along a terminal symbol.
 152      (Goto transitions are taken care of within [reduce] below.) The symbol
 153      can be either an actual token or the [error] pseudo-token. *)
 154
 155   and shift env
 156       (please_discard : bool)
 157       (terminal : terminal)
 158       (value : semantic_value)
 159       (s' : state)
 160       : void =
 161
 162     (* Log the transition. *)
 163
 164     Log.shift terminal s';
 165
 166     (* Push a new cell onto the stack, containing the identity of the
 167        state that we are leaving. *)
 168
 169     let lexbuf = env.lexbuf in
 170     env.stack <- {
 171       state = env.current;
 172       semv = value;
 173       startp = lexbuf.Lexing.lex_start_p;
 174       endp = lexbuf.Lexing.lex_curr_p;
 175       next = env.stack;
 176     };
 177
 178     (* Switch to state [s']. *)
 179
 180     env.current <- s';
 181     run env please_discard
 182
 183   (* --------------------------------------------------------------------------- *)
 184
 185   (* This function takes care of reductions. *)
 186
 187   and reduce env (prod : production) : void =
 188
 189     (* Log a reduction event. *)
 190
 191     Log.reduce_or_accept prod;
 192
 193     (* Invoke the semantic action. The semantic action is responsible for
 194        truncating the stack, updating the current state, producing a cell that
 195        contains a new semantic value, and raising [Accept] or [Error] if
 196        appropriate. *)
 197
 198     (* If the semantic action raises [Error], we catch it immediately and
 199        initiate error handling. *)
 200
 201     (* The apparently weird idiom used here is an encoding for a
 202        [let/unless] construct, which does not exist in ocaml. *)
 203
 204     if (
 205       try
 206         T.semantic_action prod env;
 207         true
 208       with Error ->
 209         false
 210     ) then begin
 211
 212       (* By our convention, the semantic action is responsible for updating
 213          the stack. The state now found in the top stack cell is the return
 214          state. *)
 215
 216       (* Perform a goto transition. The target state is determined
 217          by consulting the goto table at the return state and at
 218          production [prod]. *)
 219
 220       env.current <- T.goto env.stack.state prod;
 221       run env false
 222
 223     end
 224     else
 225       errorbookkeeping env
 226
 227
 228   (* --------------------------------------------------------------------------- *)
 229
 230   (* The following functions deal with errors. *)
 231
 232   (* [initiate] and [errorbookkeeping] initiate error handling. See the functions
 233      by the same names in [CodeBackend]. *)
 234
 235   and initiate env : void =
 236     assert (env.shifted >= 0);
 237     if T.recovery && env.shifted = 0 then begin
 238       Log.discarding_last_token (T.token2terminal env.token);
 239       discard env;
 240       env.shifted <- 0;
 241       action env
 242     end
 243     else
 244       errorbookkeeping env
 245
 246   and errorbookkeeping env =
 247     Log.initiating_error_handling();
 248     env.previouserror <- env.shifted;
 249     env.shifted <- (-1);
 250     error env
 251
 252   (* [error] handles errors. *)
 253
 254   and error env : void =
 255
 256     (* Consult the column associated with the [error] pseudo-token in the
 257        action table. *)
 258
 259     T.action
 260       env.current                    (* determines a row *)
 261       T.error_terminal               (* determines a column *)
 262       T.error_value
 263       error_shift                    (* shift continuation *)
 264       error_reduce                   (* reduce continuation *)
 265       error_fail                     (* failure continuation *)
 266       env
 267
 268   and error_shift env please_discard terminal value s' =
 269
 270     (* Here, [terminal] is [T.error_terminal], and [value] is [T.error_value]. *)
 271
 272     assert (terminal = T.error_terminal && value = T.error_value);
 273
 274     (* This state is capable of shifting the [error] token. *)
 275
 276     Log.handling_error env.current;
 277     shift env please_discard terminal value s'
 278
 279   and error_reduce env prod =
 280
 281     (* This state is capable of performing a reduction on [error]. *)
 282
 283     Log.handling_error env.current;
 284     reduce env prod
 285
 286   and error_fail env =
 287
 288     (* This state is unable to handle errors. Attempt to pop a stack
 289        cell. *)
 290
 291     let cell = env.stack in
 292     let next = cell.next in
 293     if next == cell then
 294
 295       (* The stack is empty. Die. *)
 296
 297       raise _eRR
 298
 299     else begin
 300
 301       (* The stack is nonempty. Pop a cell, updating the current state
 302          with that found in the popped cell, and try again. *)
 303
 304       env.stack <- next;
 305       env.current <- cell.state;
 306       error env
 307
 308     end
 309
 310   (* --------------------------------------------------------------------------- *)
 311
 312   let entry
 313       (s : state)
 314       (lexer : Lexing.lexbuf -> token)
 315       (lexbuf : Lexing.lexbuf)
 316       : semantic_value =
 317
 318     (* Build an empty stack. This is a dummy cell, which is its own
 319        successor. Its fields other than [next] contain dummy values. *)
 320
 321     let rec empty = {
 322       state = s;                          (* dummy *)
 323       semv = T.error_value;               (* dummy *)
 324       startp = lexbuf.Lexing.lex_start_p; (* dummy *)
 325       endp = lexbuf.Lexing.lex_curr_p;    (* dummy *)
 326       next = empty;
 327     } in
 328
 329     (* Perform an initial call to the lexer. *)
 330
 331     let token : token =
 332       lexer lexbuf
 333     in
 334
 335     (* Log our first lookahead token. *)
 336
 337     Log.lookahead_token lexbuf (T.token2terminal token);
 338
 339     (* Build an initial environment. *)
 340
 341     let env = {
 342       lexer = lexer;
 343       lexbuf = lexbuf;
 344       token = token;
 345       shifted = max_int;
 346       previouserror = max_int;
 347       stack = empty;
 348       current = s;
 349     } in
 350
 351     (* Run. Catch [Accept], which represents normal termination. Let [Error]
 352        escape. *)
 353
 354     try
 355
 356       (* If ocaml offered a [match/with] construct with zero branches, this is
 357          what we would use here, since the type [void] has zero cases. *)
 358
 359       let (_ : void) = run env false in
 360       assert false (* cannot fail *)
 361
 362     with
 363     | Accept v ->
 364         v
 365
 366 end
 367