referenceInterpreter.ml 5.69 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
open Grammar
open Cst

(* Set up all of the information required by the LR engine. Everything is
   read directly from [Grammar] and [Lr1]. *)

module T = struct

  type state =
      Lr1.node
   
  type token =
      Terminal.t

  type terminal =
      Terminal.t

  type semantic_value =
      cst

  let token2terminal (token : token) : terminal =
    token

  let token2value (token : token) : semantic_value =
    CstTerminal token

  let error_terminal =
    Terminal.error

  let error_value =
    CstError

  type production =
      Production.index

  let default_reduction (s : state) defred nodefred env =
    match Invariant.has_default_reduction s with
    | Some (prod, _) ->
	defred env prod
    | None ->
	nodefred env

  let action (s : state) (tok : terminal) value shift reduce fail env =

    (* Check whether [s] has an outgoing shift transition along [tok]. *)

    try

      let s' : state = SymbolMap.find (Symbol.T tok) (Lr1.transitions s) in

      (* There is such a transition. Return either [ShiftDiscard] or
	 [ShiftNoDiscard], depending on the existence of a default
	 reduction on [#] at [s']. *)

      match Invariant.has_default_reduction s' with
      | Some (_, toks) when TerminalSet.mem Terminal.sharp toks ->
	  shift env false tok value s'
      | _ ->
	  shift env true tok value s'
	  
    (* There is no such transition. Look for a reduction. *)

    with Not_found ->
      try

	let prod = Misc.single (TerminalMap.find tok (Lr1.reductions s)) in
	reduce env prod

      (* There is no reduction either. Fail. *)

      with Not_found ->
	fail env

  let goto (s : state) (prod : production) : state =
    try
      SymbolMap.find (Symbol.N (Production.nt prod)) (Lr1.transitions s)
    with Not_found ->
      assert false

  open MenhirLib.EngineTypes

  exception Error

84 85 86
  (* By convention, a semantic action returns a new stack. It does not
     affect [env]. *)

87 88 89
  let is_start =
    Production.is_start

90
  type semantic_action =
91
      (state, semantic_value, token) env -> (state, semantic_value) stack
92 93 94

  let semantic_action (prod : production) : semantic_action =
    fun env ->
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
      assert (not (Production.is_start prod));

      (* Reduce. Pop a suffix of the stack, and use it to construct a
	 new concrete syntax tree node. *)

      let n = Production.length prod in

      let values : semantic_value array =
        Array.make n CstError (* dummy *)
      and startp =
        ref Lexing.dummy_pos
      and endp=
        ref Lexing.dummy_pos
      and current =
        ref env.current
      and stack =
        ref env.stack
      in

      (* We now enter a loop to pop [k] stack cells and (after that) push
         a new cell onto the stack. *)

      (* This loop does not update [env.current]. Instead, the state in
         the newly pushed stack cell will be used (by our caller) as a
         basis for a goto transition, and [env.current] will be updated
         (if necessary) then. *)

      for k = n downto 1 do

        (* Fetch a semantic value. *)

        values.(k - 1) <- !stack.semv;

        (* Pop one cell. The stack must be non-empty. As we pop a cell,
           change the automaton's current state to the one stored within
           the cell. (It is sufficient to do this only when [k] is 1,
           since the last write overwrites any and all previous writes.)
           If this is the first (last) cell that we pop, update [endp]
           ([startp]). *)

        let next = !stack.next in
        assert (!stack != next);
        if k = n then begin
          endp := !stack.endp
        end;
        if k = 1 then begin
          current := !stack.state;
          startp := !stack.startp
        end;
        stack := next

      done;

      (* Done popping. *)

      (* Construct and push a new stack cell. The associated semantic
         value is a new concrete syntax tree. *)

      {
        state = !current;
        semv = CstNonTerminal (prod, values);
        startp = !startp;
        endp = !endp;
        next = !stack
      }
160

161 162
  let log = true

163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196
  module Log = struct

    open Printf

    (* I use a reference as a quick and dirty form of parameter passing. *)

    let log =
      ref false

    let maybe action =
      if !log then begin
	action();
	prerr_newline()
      end

    let state s =
      maybe (fun () ->
	fprintf stderr "State %d:" (Lr1.number s)
      )

    let shift tok s' =
      maybe (fun () ->
	fprintf stderr "Shifting (%s) to state %d" (Terminal.print tok) (Lr1.number s')
      )

    let reduce_or_accept prod =
      maybe (fun () ->
	match Production.classify prod with
	| Some _ ->
	    fprintf stderr "Accepting"
	| None ->
	    fprintf stderr "Reducing production %s" (Production.print prod)
      )

197
    let lookahead_token tok startp endp =
198 199 200
      maybe (fun () ->
	fprintf stderr "Lookahead token is now %s (%d-%d)"
	  (Terminal.print tok)
201 202
	  startp.Lexing.pos_cnum
	  endp.Lexing.pos_cnum
203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
      )

    let initiating_error_handling () =
      maybe (fun () ->
	fprintf stderr "Initiating error handling"
      )

    let resuming_error_handling () =
      maybe (fun () ->
	fprintf stderr "Resuming error handling"
      )

    let handling_error s =
      maybe (fun () ->
	fprintf stderr "Handling error in state %d" (Lr1.number s)
      )

  end

end

(* Instantiate the LR engine with this information. *)

module E =
  MenhirLib.Engine.Make (T)

(* Define a palatable user entry point. *)

let interpret log nt lexer lexbuf =

  (* Find the start state that corresponds to [nt] in the automaton. *)

  let s : Lr1.node =
    try
      ProductionMap.find (Production.startsymbol2startprod nt) Lr1.entry
    with Not_found ->
      assert false
  in

  (* Run the engine. *)
  
  try
    T.Log.log := log;
    Some (E.entry s lexer lexbuf)
  with T.Error ->
    None