referenceInterpreter.ml 6.12 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 84
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 Accept of semantic_value
  exception Error

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

88
  type semantic_action =
89
      (state, semantic_value, token) env -> (state, semantic_value) stack
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110

  let semantic_action (prod : production) : semantic_action =
    fun env ->
      
      (* Check whether [prod] is a start production. *)

      match Production.classify prod with

      (* If it is one, accept. Start productions are of the form S' ->
	 S, where S is a non-terminal symbol, so the desired semantic
	 value is found within the top cell of the stack. *)

      | Some _ ->
	  raise (Accept env.stack.semv)

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

      | None ->

	  let n = Production.length prod in
111

112 113
	  let values : semantic_value array =
	    Array.make n CstError (* dummy *)
114
	  and startp =
115
	    ref Lexing.dummy_pos
116
	  and endp=
117
	    ref Lexing.dummy_pos
118 119 120 121
          and current =
            ref env.current
          and stack =
            ref env.stack
122 123
	  in

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

127 128 129 130
          (* 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. *)
131

132
          for k = n downto 1 do
133

134
            (* Fetch a semantic value. *)
135

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

138 139 140 141 142 143
            (* 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]). *)
144

145 146 147 148 149 150 151 152 153 154
            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
155

156
          done;
157

158
          (* Done popping. *)
159

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

163 164 165 166 167 168 169
          {
            state = !current;
            semv = CstNonTerminal (prod, values);
            startp = !startp;
            endp = !endp;
            next = !stack
          }
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 197 198 199 200 201 202 203 204

  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)
      )

205
    let lookahead_token tok startp endp =
206 207 208
      maybe (fun () ->
	fprintf stderr "Lookahead token is now %s (%d-%d)"
	  (Terminal.print tok)
209 210
	  startp.Lexing.pos_cnum
	  endp.Lexing.pos_cnum
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 250 251 252 253 254 255 256 257
      )

    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