(**************************************************************************)
(*                                                                        *)
(*  Menhir                                                                *)
(*                                                                        *)
(*  François Pottier, INRIA Rocquencourt                                  *)
(*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
(*                                                                        *)
(*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
(*  et en Automatique. All rights reserved. This file is distributed      *)
(*  under the terms of the GNU Library General Public License, with the   *)
(*  special exception on linking described in file LICENSE.               *)
(*                                                                        *)
(**************************************************************************)

(* This module instantiates the generic [Engine] with a thin decoding layer
   for the generated tables. Like [Engine], it is part of [MenhirLib]. *)

(* The exception [Accept] is pre-declared here: this obviates the need
   for generating its definition. The exception [Error] is declared
   within the generated parser. This is preferable to pre-declaring it
   here, as it ensures that each parser gets its own, distinct [Error]
   exception. This is consistent with the code-based back-end. *)

exception Accept of Obj.t

(* This functor is invoked by the generated parser. *)

module Make (T : TableFormat.TABLES)

= Engine.Make (struct

  type state =
      int

  type token =
      T.token

  type terminal =
      int

  type semantic_value =
      Obj.t
	  
  let token2terminal =
    T.token2terminal
	
  let token2value =
    T.token2value
	
  let error_terminal =
    T.error_terminal

  let error_value =
    Obj.repr ()
  
  type production =
      int
  
  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)
  
  (* 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

  (* This auxiliary function helps access a flattened, two-dimensional
     matrix, like the error bitmap. *)

  let unflatten (n, data) i j =
    PackedIntArray.get1 data (n * i + j)

  let action state terminal value shift reduce fail env =
    match unflatten T.error state terminal with
    | 1 ->
	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
    | c ->
	assert (c = 0);
	fail env
  
  let goto state prod =
    let code = unmarshal2 T.goto state (PackedIntArray.get T.lhs prod) in
    (* code = 1 + state *)
    code - 1

  exception Accept =
	Accept

  exception Error =
	T.Error

  type semantic_action =
      (state, semantic_value, token) EngineTypes.env -> unit
	
  let semantic_action prod =
    T.semantic_action.(prod)
  
  let recovery =
    T.recovery
  
  module Log = struct
    
    open Printf
    
    let state state =
      match T.trace with
      | Some _ ->
          fprintf stderr "State %d:\n%!" state
      | None ->
	  ()
    
    let shift terminal state =
      match T.trace with
      | Some (terminals, _) ->
          fprintf stderr "Shifting (%s) to state %d\n%!" terminals.(terminal) state
      | None ->
	  ()
    
    let reduce_or_accept prod =
      match T.trace with
      | Some (_, productions) ->
          fprintf stderr "%s\n%!" productions.(prod)
      | None ->
	  ()
    
    let lookahead_token lexbuf token =
      match T.trace with
      | Some (terminals, _) ->
          fprintf stderr "Lookahead token is now %s (%d-%d)\n%!"
            terminals.(token)
            lexbuf.Lexing.lex_start_p.Lexing.pos_cnum
            lexbuf.Lexing.lex_curr_p.Lexing.pos_cnum
      | None ->
	  ()
    
    let initiating_error_handling () =
      match T.trace with
      | Some _ ->
          fprintf stderr "Initiating error handling\n%!"
      | None ->
	  ()
    
    let resuming_error_handling () =
      match T.trace with
      | Some _ ->
          fprintf stderr "Resuming error handling\n%!"
      | None ->
	  ()
    
    let handling_error state =
      match T.trace with
      | Some _ ->
          fprintf stderr "Handling error in state %d\n%!" state
      | None ->
	  ()
    
    let discarding_last_token token =
      match T.trace with
      | Some (terminals, _) ->
          fprintf stderr "Discarding last token read (%s)\n%!" terminals.(token)
      | None ->
	  ()

  end
  
end)