bundles/menhirLib/menhir-20120123/src/referenceInterpreter.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 Q Public License version 1.0, with the change  *)
  11 (*  described in file LICENSE.                                            *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 open Grammar
  16 open Cst
  17
  18 (* Set up all of the information required by the LR engine. Everything is
  19    read directly from [Grammar] and [Lr1]. *)
  20
  21 module T = struct
  22
  23   type state =
  24       Lr1.node
  25
  26   type token =
  27       Terminal.t
  28
  29   type terminal =
  30       Terminal.t
  31
  32   type semantic_value =
  33       cst
  34
  35   let token2terminal (token : token) : terminal =
  36     token
  37
  38   let token2value (token : token) : semantic_value =
  39     CstTerminal token
  40
  41   let error_terminal =
  42     Terminal.error
  43
  44   let error_value =
  45     CstError
  46
  47   type production =
  48       Production.index
  49
  50   let default_reduction (s : state) defred nodefred env =
  51     match Invariant.has_default_reduction s with
  52     | Some (prod, _) ->
  53         defred env prod
  54     | None ->
  55         nodefred env
  56
  57   let action (s : state) (tok : terminal) value shift reduce fail env =
  58
  59     (* Check whether [s] has an outgoing shift transition along [tok]. *)
  60
  61     try
  62
  63       let s' : state = SymbolMap.find (Symbol.T tok) (Lr1.transitions s) in
  64
  65       (* There is such a transition. Return either [ShiftDiscard] or
  66          [ShiftNoDiscard], depending on the existence of a default
  67          reduction on [#] at [s']. *)
  68
  69       match Invariant.has_default_reduction s' with
  70       | Some (_, toks) when TerminalSet.mem Terminal.sharp toks ->
  71           shift env false tok value s'
  72       | _ ->
  73           shift env true tok value s'
  74
  75     (* There is no such transition. Look for a reduction. *)
  76
  77     with Not_found ->
  78       try
  79
  80         let prod = Misc.single (TerminalMap.find tok (Lr1.reductions s)) in
  81         reduce env prod
  82
  83       (* There is no reduction either. Fail. *)
  84
  85       with Not_found ->
  86         fail env
  87
  88   let goto (s : state) (prod : production) : state =
  89     try
  90       SymbolMap.find (Symbol.N (Production.nt prod)) (Lr1.transitions s)
  91     with Not_found ->
  92       assert false
  93
  94   open MenhirLib.EngineTypes
  95
  96   exception Accept of semantic_value
  97   exception Error
  98
  99   type semantic_action =
 100       (state, semantic_value, token) env -> unit
 101
 102   let semantic_action (prod : production) : semantic_action =
 103     fun env ->
 104
 105       (* Check whether [prod] is a start production. *)
 106
 107       match Production.classify prod with
 108
 109       (* If it is one, accept. Start productions are of the form S' ->
 110          S, where S is a non-terminal symbol, so the desired semantic
 111          value is found within the top cell of the stack. *)
 112
 113       | Some _ ->
 114           raise (Accept env.stack.semv)
 115
 116       (* If it is not, reduce. Pop a suffix of the stack, and use it
 117          to construct a new concrete syntax tree node. *)
 118
 119       | None ->
 120
 121           let n = Production.length prod in
 122           let values : semantic_value array =
 123             Array.make n CstError (* dummy *)
 124           and startp : Lexing.position ref =
 125             ref Lexing.dummy_pos
 126           and endp : Lexing.position ref =
 127             ref Lexing.dummy_pos
 128           in
 129
 130           (* The auxiliary function [pop k stack] pops [k] stack cells
 131              and returns a truncated stack. It also updates the automaton's
 132              current state, and fills in [values], [startp], and [endp]. *)
 133
 134           let rec pop k stack =
 135
 136             if k = 0 then
 137
 138               (* There are no more stack cells to pop. *)
 139
 140               stack
 141
 142             else begin
 143
 144               (* Fetch a semantic value. *)
 145
 146               values.(k - 1) <- stack.semv;
 147
 148               (* Pop one cell. The stack must be non-empty. As we pop a cell,
 149                  change the automaton's current state to the one stored within
 150                  the cell. (It is sufficient to do this only when [k] is 1.)
 151                  If this is the first (last) cell that we pop, update [endp]
 152                  ([startp]). *)
 153
 154               let next = stack.next in
 155               assert (stack != next);
 156               if k = n then begin
 157                 endp := stack.endp
 158               end;
 159               if k = 1 then begin
 160                 env.current <- stack.state;
 161                 startp := stack.startp
 162               end;
 163               pop (k - 1) next
 164
 165             end
 166
 167           in
 168           let stack = pop n env.stack in
 169
 170           (* Construct and push a new stack cell. The associated semantic
 171              value is a new concrete syntax tree. *)
 172
 173           env.stack <- {
 174             state = env.current;
 175             semv = CstNonTerminal (prod, values);
 176             startp = !startp;
 177             endp = !endp;
 178             next = stack
 179           }
 180
 181   (* The reference interpreter performs error recovery if and only if this
 182      is requested via [--recovery]. *)
 183
 184   let recovery =
 185     Settings.recovery
 186
 187   module Log = struct
 188
 189     open Printf
 190
 191     (* I use a reference as a quick and dirty form of parameter passing. *)
 192
 193     let log =
 194       ref false
 195
 196     let maybe action =
 197       if !log then begin
 198         action();
 199         prerr_newline()
 200       end
 201
 202     let state s =
 203       maybe (fun () ->
 204         fprintf stderr "State %d:" (Lr1.number s)
 205       )
 206
 207     let shift tok s' =
 208       maybe (fun () ->
 209         fprintf stderr "Shifting (%s) to state %d" (Terminal.print tok) (Lr1.number s')
 210       )
 211
 212     let reduce_or_accept prod =
 213       maybe (fun () ->
 214         match Production.classify prod with
 215         | Some _ ->
 216             fprintf stderr "Accepting"
 217         | None ->
 218             fprintf stderr "Reducing production %s" (Production.print prod)
 219       )
 220
 221     let lookahead_token lexbuf tok =
 222       maybe (fun () ->
 223         fprintf stderr "Lookahead token is now %s (%d-%d)"
 224           (Terminal.print tok)
 225           lexbuf.Lexing.lex_start_p.Lexing.pos_cnum
 226           lexbuf.Lexing.lex_curr_p.Lexing.pos_cnum
 227       )
 228
 229     let initiating_error_handling () =
 230       maybe (fun () ->
 231         fprintf stderr "Initiating error handling"
 232       )
 233
 234     let resuming_error_handling () =
 235       maybe (fun () ->
 236         fprintf stderr "Resuming error handling"
 237       )
 238
 239     let handling_error s =
 240       maybe (fun () ->
 241         fprintf stderr "Handling error in state %d" (Lr1.number s)
 242       )
 243
 244     let discarding_last_token tok =
 245       maybe (fun () ->
 246         fprintf stderr "Discarding last token read (%s)" (Terminal.print tok)
 247       )
 248
 249   end
 250
 251 end
 252
 253 (* Instantiate the LR engine with this information. *)
 254
 255 module E =
 256   MenhirLib.Engine.Make (T)
 257
 258 (* Define a palatable user entry point. *)
 259
 260 let interpret log nt lexer lexbuf =
 261
 262   (* Find the start state that corresponds to [nt] in the automaton. *)
 263
 264   let s : Lr1.node =
 265     try
 266       ProductionMap.find (Production.startsymbol2startprod nt) Lr1.entry
 267     with Not_found ->
 268       assert false
 269   in
 270
 271   (* Run the engine. *)
 272
 273   try
 274     T.Log.log := log;
 275     Some (E.entry s lexer lexbuf)
 276   with T.Error ->
 277     None
 278