TableInterpreter.ml 7.11 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
(******************************************************************************)
(*                                                                            *)
(*                                   Menhir                                   *)
(*                                                                            *)
(*                       François Pottier, Inria Paris                        *)
(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
(*                                                                            *)
(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
(*  terms of the GNU Library General Public License version 2, with a         *)
(*  special exception on linking, as described in the file LICENSE.           *)
(*                                                                            *)
(******************************************************************************)

14
module MakeEngineTable (T : TableFormat.TABLES) = struct
15 16 17 18

  type state =
      int

19 20
  let number s = s

21 22 23 24 25 26
  type token =
      T.token

  type terminal =
      int

27 28 29
  type nonterminal =
      int

30 31
  type semantic_value =
      Obj.t
32

33 34
  let token2terminal =
    T.token2terminal
35

36 37
  let token2value =
    T.token2value
38

39 40 41 42 43
  let error_terminal =
    T.error_terminal

  let error_value =
    Obj.repr ()
44

45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
  (* The function [foreach_terminal] exploits the fact that the
     first component of [T.error] is [Terminal.n - 1], i.e., the
     number of terminal symbols, including [error] but not [#]. *)

  (* There is similar code in [InspectionTableInterpreter]. The
     code there contains an additional conversion of the type
     [terminal] to the type [xsymbol]. *)

  let rec foldij i j f accu =
    if i = j then
      accu
    else
      foldij (i + 1) j f (f i accu)

  let foreach_terminal f accu =
    let n, _ = T.error in
    foldij 0 n (fun i accu ->
      f i accu
    ) accu

65 66
  type production =
      int
67

68 69 70 71 72 73 74 75 76 77 78 79 80
  (* In principle, only non-start productions are exposed to the user,
     at type [production] or at type [int]. This is checked dynamically. *)
  let non_start_production i =
    assert (T.start <= i && i - T.start < Array.length T.semantic_action)

  let production_index i =
    non_start_production i;
    i

  let find_production i =
    non_start_production i;
    i

81 82 83 84 85 86
  let default_reduction state defred nodefred env =
    let code = PackedIntArray.get T.default_reduction state in
    if code = 0 then
      nodefred env
    else
      defred env (code - 1)
87 88 89

  let is_start prod =
    prod < T.start
90

91 92 93 94 95 96 97 98 99 100 101
  (* This auxiliary function helps access a compressed, two-dimensional
     matrix, like the action and goto tables. *)

  let unmarshal2 table i j =
    RowDisplacement.getget
      PackedIntArray.get
      PackedIntArray.get
      table
      i j

  let action state terminal value shift reduce fail env =
102
    match PackedIntArray.unflatten1 T.error state terminal with
103
    | 1 ->
104 105 106 107 108 109 110 111 112 113 114 115
        let action = unmarshal2 T.action state terminal in
        let opcode = action land 0b11
        and param = action lsr 2 in
        if opcode >= 0b10 then
          (* 0b10 : shift/discard *)
          (* 0b11 : shift/nodiscard *)
          let please_discard = (opcode = 0b10) in
          shift env please_discard terminal value param
        else
          (* 0b01 : reduce *)
          (* 0b00 : cannot happen *)
          reduce env param
116
    | c ->
117 118
        assert (c = 0);
        fail env
119

120 121
  let goto_nt state nt =
    let code = unmarshal2 T.goto state nt in
122 123 124
    (* code = 1 + state *)
    code - 1

125 126 127
  let goto_prod state prod =
    goto_nt state (PackedIntArray.get T.lhs prod)

128 129 130 131 132 133 134
  let maybe_goto_nt state nt =
    let code = unmarshal2 T.goto state nt in
    (* If [code] is 0, there is no outgoing transition.
       If [code] is [1 + state], there is a transition towards [state]. *)
    assert (0 <= code);
    if code = 0 then None else Some (code - 1)

135
  exception Error =
136
        T.Error
137 138

  type semantic_action =
139 140
      (state, semantic_value, token) EngineTypes.env ->
      (state, semantic_value)        EngineTypes.stack
141

142
  let semantic_action prod =
143 144 145
    (* Indexing into the array [T.semantic_action] is off by [T.start],
       because the start productions do not have entries in this array. *)
    T.semantic_action.(prod - T.start)
146

147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
  (* [may_reduce state prod] tests whether the state [state] is capable of
     reducing the production [prod]. This information could be determined
     in constant time if we were willing to create a bitmap for it, but
     that would take up a lot of space. Instead, we obtain this information
     by iterating over a line in the action table. This is costly, but this
     function is not normally used by the LR engine anyway; it is supposed
     to be used only by programmers who wish to develop error recovery
     strategies. *)

  (* In the future, if desired, we could memoize this function, so as
     to pay the cost in (memory) space only if and where this function
     is actually used. We could also replace [foreach_terminal] with a
     function [exists_terminal] which stops as soon as the accumulator
     is [true]. *)

  let may_reduce state prod =
    (* Test if there is a default reduction of [prod]. *)
    default_reduction state
      (fun () prod' -> prod = prod')
      (fun () ->
        (* If not, then for each terminal [t], ... *)
        foreach_terminal (fun t accu ->
          accu ||
          (* ... test if there is a reduction of [prod] on [t]. *)
          action state t ()
            (* shift:  *) (fun () _ _ () _ -> false)
            (* reduce: *) (fun () prod' -> prod = prod')
            (* fail:   *) (fun () -> false)
            ()
        ) false
      )
      ()

180 181 182 183 184
  (* If [T.trace] is [None], then the logging functions do nothing. *)

  let log =
    match T.trace with Some _ -> true | None -> false

185
  module Log = struct
186

187
    open Printf
188

189 190 191 192 193
    let state state =
      match T.trace with
      | Some _ ->
          fprintf stderr "State %d:\n%!" state
      | None ->
194
          ()
195

196 197 198 199 200
    let shift terminal state =
      match T.trace with
      | Some (terminals, _) ->
          fprintf stderr "Shifting (%s) to state %d\n%!" terminals.(terminal) state
      | None ->
201
          ()
202

203 204 205 206 207
    let reduce_or_accept prod =
      match T.trace with
      | Some (_, productions) ->
          fprintf stderr "%s\n%!" productions.(prod)
      | None ->
208
          ()
209

210
    let lookahead_token token startp endp =
211 212 213 214
      match T.trace with
      | Some (terminals, _) ->
          fprintf stderr "Lookahead token is now %s (%d-%d)\n%!"
            terminals.(token)
215 216
            startp.Lexing.pos_cnum
            endp.Lexing.pos_cnum
217
      | None ->
218
          ()
219

220 221 222 223 224
    let initiating_error_handling () =
      match T.trace with
      | Some _ ->
          fprintf stderr "Initiating error handling\n%!"
      | None ->
225
          ()
226

227 228 229 230 231
    let resuming_error_handling () =
      match T.trace with
      | Some _ ->
          fprintf stderr "Resuming error handling\n%!"
      | None ->
232
          ()
233

234 235 236 237 238
    let handling_error state =
      match T.trace with
      | Some _ ->
          fprintf stderr "Handling error in state %d\n%!" state
      | None ->
239
          ()
240

241
  end
242

243
end