menhirlib/tableInterpreter.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 (* This module instantiates the generic [Engine] with a thin decoding layer
  16    for the generated tables. Like [Engine], it is part of [MenhirLib]. *)
  17
  18 (* The exception [Accept] is pre-declared here: this obviates the need
  19    for generating its definition. The exception [Error] is declared
  20    within the generated parser. This is preferable to pre-declaring it
  21    here, as it ensures that each parser gets its own, distinct [Error]
  22    exception. This is consistent with the code-based back-end. *)
  23
  24 exception Accept of Obj.t
  25
  26 (* This functor is invoked by the generated parser. *)
  27
  28 module Make (T : TableFormat.TABLES)
  29
  30 = Engine.Make (struct
  31
  32   type state =
  33       int
  34
  35   type token =
  36       T.token
  37
  38   type terminal =
  39       int
  40
  41   type semantic_value =
  42       Obj.t
  43
  44   let token2terminal =
  45     T.token2terminal
  46
  47   let token2value =
  48     T.token2value
  49
  50   let error_terminal =
  51     T.error_terminal
  52
  53   let error_value =
  54     Obj.repr ()
  55
  56   type production =
  57       int
  58
  59   let default_reduction state defred nodefred env =
  60     let code = PackedIntArray.get T.default_reduction state in
  61     if code = 0 then
  62       nodefred env
  63     else
  64       defred env (code - 1)
  65
  66   (* This auxiliary function helps access a compressed, two-dimensional
  67      matrix, like the action and goto tables. *)
  68
  69   let unmarshal2 table i j =
  70     RowDisplacement.getget
  71       PackedIntArray.get
  72       PackedIntArray.get
  73       table
  74       i j
  75
  76   (* This auxiliary function helps access a flattened, two-dimensional
  77      matrix, like the error bitmap. *)
  78
  79   let unflatten (n, data) i j =
  80     PackedIntArray.get1 data (n * i + j)
  81
  82   let action state terminal value shift reduce fail env =
  83     match unflatten T.error state terminal with
  84     | 1 ->
  85         let action = unmarshal2 T.action state terminal in
  86         let opcode = action land 0b11
  87         and param = action lsr 2 in
  88         if opcode >= 0b10 then
  89           (* 0b10 : shift/discard *)
  90           (* 0b11 : shift/nodiscard *)
  91           let please_discard = (opcode = 0b10) in
  92           shift env please_discard terminal value param
  93         else
  94           (* 0b01 : reduce *)
  95           (* 0b00 : cannot happen *)
  96           reduce env param
  97     | c ->
  98         assert (c = 0);
  99         fail env
 100
 101   let goto state prod =
 102     let code = unmarshal2 T.goto state (PackedIntArray.get T.lhs prod) in
 103     (* code = 1 + state *)
 104     code - 1
 105
 106   exception Accept =
 107         Accept
 108
 109   exception Error =
 110         T.Error
 111
 112   type semantic_action =
 113       (state, semantic_value, token) EngineTypes.env -> unit
 114
 115   let semantic_action prod =
 116     T.semantic_action.(prod)
 117
 118   let recovery =
 119     T.recovery
 120
 121   module Log = struct
 122
 123     open Printf
 124
 125     let state state =
 126       match T.trace with
 127       | Some _ ->
 128           fprintf stderr "State %d:\n%!" state
 129       | None ->
 130           ()
 131
 132     let shift terminal state =
 133       match T.trace with
 134       | Some (terminals, _) ->
 135           fprintf stderr "Shifting (%s) to state %d\n%!" terminals.(terminal) state
 136       | None ->
 137           ()
 138
 139     let reduce_or_accept prod =
 140       match T.trace with
 141       | Some (_, productions) ->
 142           fprintf stderr "%s\n%!" productions.(prod)
 143       | None ->
 144           ()
 145
 146     let lookahead_token lexbuf token =
 147       match T.trace with
 148       | Some (terminals, _) ->
 149           fprintf stderr "Lookahead token is now %s (%d-%d)\n%!"
 150             terminals.(token)
 151             lexbuf.Lexing.lex_start_p.Lexing.pos_cnum
 152             lexbuf.Lexing.lex_curr_p.Lexing.pos_cnum
 153       | None ->
 154           ()
 155
 156     let initiating_error_handling () =
 157       match T.trace with
 158       | Some _ ->
 159           fprintf stderr "Initiating error handling\n%!"
 160       | None ->
 161           ()
 162
 163     let resuming_error_handling () =
 164       match T.trace with
 165       | Some _ ->
 166           fprintf stderr "Resuming error handling\n%!"
 167       | None ->
 168           ()
 169
 170     let handling_error state =
 171       match T.trace with
 172       | Some _ ->
 173           fprintf stderr "Handling error in state %d\n%!" state
 174       | None ->
 175           ()
 176
 177     let discarding_last_token token =
 178       match T.trace with
 179       | Some (terminals, _) ->
 180           fprintf stderr "Discarding last token read (%s)\n%!" terminals.(token)
 181       | None ->
 182           ()
 183
 184   end
 185
 186 end)