module PARSER

! LR Parser.  The grammar's PDA is generated by the LR processor.

  use, intrinsic :: ISO_Fortran_Env, only: Error_Unit

  implicit NONE
  private

  public :: Clean_Up_Parser, Configuration, LR_Parser, LR_Parser_TX

  interface Configuration
    module procedure LR_Parser_Int, LR_Parser_TX
  end interface Configuration

  interface LR_Parser
    procedure LR_Parser_Int, LR_Parser_TX
  end interface LR_Parser

  integer, parameter :: Max_FMA = 5   ! How deep into FMA+ can we go?

  ! Derived from lists in parser tables, to make the parser run faster:

  integer, save, allocatable :: LR_0(:) ! If LR_0(I) /= 0, state I is an LR(0)
                             ! state, i.e., one reduction and no productions.
                             ! LR_0(I) is the production number to reduce.
  integer, save, allocatable :: Work(:,:)

!---------------------------- RCS Module Info ------------------------------
  character (len=*), private, parameter :: ModuleName= &
       "$RCSfile: parser.f90,v $"
  private :: not_used_here 
!---------------------------------------------------------------------------

contains ! ====     Procedures     =====================================

  subroutine LR_Parser_TX ( Root, T )
    use Parser_Tables, only: Parser_Table_t
    use Tree, only: TX
    type(tx), intent(out) :: ROOT   ! Root of the abstract syntax tree
    type(parser_table_t), intent(in) :: T
    call lr_parser ( root%i, T )
  end subroutine LR_Parser_TX

  subroutine LR_Parser_Int ( Root, T )

    use Lexer_Core, only: Print_Source, Token
    use Lexer_M, only: Lexer
    use Output_M, only: Blanks, NewLine, Output
    use Parser_Tables, only: N_Glue, N_Null, Parser_Table_t
    use Parser_Table_m, only: Make_PD_Array, Print_State
    use Symbol_Table, only: Class_Texts, Dump_1_Symbol, Dump_Symbol_Class
    use Symbol_Types, only: T_End_Of_Input, T_Last_Terminal, T_Null
    use Toggles, only: Levels, Par, Toggle
    use Tree, only: Build_Tree, Dump_Top_Stack, N_Tree_Stack,&
                    Push_Pseudo_Terminal,  Stack_Subtree

    integer, intent(out) :: Root   ! Index in tree of root of the parsed tree
    type(parser_table_t), intent(in) :: T

    type :: Stack_Frame
      integer :: State         ! The parser state
      integer :: Tree_Index    ! Tree stack pointer of state's t%lhs
      integer :: Prev_FMA = 0  ! Previous forward move algorithm frame
    end type Stack_Frame

    logical, save :: Machine = .false. ! Dump the grammar and parsing machine
    integer :: Map(t_null:t_last_terminal) ! Map token classes to parser
                               ! vocabulary indices
    logical :: Need            ! Need to get a token from the lexer
    integer :: Newsta, Nowsta  ! Next state, Current state
    integer :: Prev_Error
    integer, save :: Show_Build = 0       ! show trees being built
    logical, save :: Show_Stack = .false. ! stack too
    logical, save :: Show_State = .false. ! automaton state too
    logical, save :: Show_Whole_Stack = .false.
    logical, save :: Show_Work = .false. ! dump Work table
    integer :: SP              ! stack pointer
    type(stack_frame), allocatable :: Stack(:)
    type(token) :: The_Token   ! from the lexer
    integer :: Top_FMA         ! Stack index of top FMA frame
    integer :: Voc             ! vocabulary index of token or t%lhs

    if ( .not. allocated(work) ) then

      ! Compute debug flags
      show_stack = mod(levels(par),2) /= 0
      show_state = mod(levels(par)/2,2) /= 0
      machine = mod(levels(par)/4,2) /= 0
      show_work = mod(levels(par)/8,2) /= 0
      show_whole_stack = mod(levels(par)/16,2) /= 0
      show_build = mod(levels(par)/32,2)

      ! Convert the lists to search for transitions and reductions to the
      ! array WORK(t%nstate,t%nvoc).
      ! If Work(i,j) > 0 the next state is Work(i,j)
      ! If Work(i,j) < 0 reduce production -Work(i,j)
      ! If Work(i,j) == 0 a syntax error has occurred
      allocate ( work(t%nstate,t%nvoc), LR_0(t%nstate) )
      call make_PD_array ( t, work, LR_0, t_null, map, show_work, machine )

    end if

    prev_error = 0              ! Line number of previous error
    sp = 0
    top_FMA = huge(0)           ! No FMA frames on the stack
    newsta = abs(t%tran(1))     ! The LR generator likes to put the <SOG>
                                ! symbol before the goal symbol.  The lexer
                                ! doesn't produce this symbol before the first
                                ! input.  Putting the parser in the state
                                ! adjacent to state 1 skips that symbol.

    call transition ( .false. ) ! push Newsta onto the parser stack and
                                ! make it Nowsta.

    need = .true.               ! Indicate a token is necessary

    do while ( nowsta /= t%ifinal )
      if ( lr_0(nowsta) > 0 ) then
        ! The current state is an LR(0) state, meaning it does one reduction
        ! and no transitions.  The production in lr_0(nowsta) can be
        ! reduced without needing to go to the lexer to get a token.
        if ( .not. reduce_production ( lr_0(nowsta) ) ) call syntax_error ( .true. )

      else
        if ( need ) then
          call lexer ( the_token )
          need = .false.
        end if
        ! Decide what to do
        if ( map(the_token%class) <= 0 .or. map(the_token%class) > t%nterms ) then
          ! Syntax error, token isn't even in terminal alphabet
          call no_transition
          call lexer( the_token )
        else
          voc = work(nowsta,map(the_token%class))
          if ( voc > 0 ) then ! a transition to state voc.
            newsta = voc
            if ( the_token%pseudo ) then
              call push_pseudo_terminal ( the_token%string_index, &
                                        & the_token%where, class=the_token%class )
              if ( show_stack ) then
                call output ( 'Push pseudo terminal ' )
                call dump_1_symbol ( the_token%string_index )
                call print_source ( the_token%where, before=' at ' )
                call output ( n_tree_stack, before=' leaving n_tree_stack = ', &
                  & advance='yes' )
              end if
            end if
            call transition ( .false., voc ) ! push Newsta onto the parser
                                 ! stack and make it Nowsta.
            need = .true.        ! Consume the token
          else if ( voc < 0 ) then ! a reduction by production -voc
            if ( .not. reduce_production ( -voc ) ) call syntax_error ( .true. )
          else ! Syntax error
            call no_transition
            call syntax_error ( .false. )
          end if
        end if
      end if
    end do

    call build_tree ( n_glue, n_tree_stack )  ! glue everything together

    if ( prev_error > 0 ) then
      call output ( prev_error, before='Last error at line ', advance='yes' )
      root = -1
    else
      if ( toggle(par) ) then
      call output ( 'Finished parsing and built ' )
      call dump_top_stack ( 0, advance='yes' )
      end if
      call build_tree ( n_null, 1 )          ! pop the glue, leave the n_null
      root = stack_subtree(1)
    end if

  contains

! -------------------------------------------  Catastrophic_Error  -----
    subroutine Catastrophic_Error ( text, The_Token, State, Nonterminal )
      use Machine, only: Crash_Burn, Nevercrash
      use String_Table, only: Display_String
      character(len=*), intent(in):: text
      type(token), intent(in), optional  :: The_Token
      integer, intent(in), optional :: State, Nonterminal
      if ( present(the_token) ) then
        call print_source ( the_token%where, &
          & before='***** Catastrophic Error ***** ', advance='yes' )
      else
        call output ( '***** Catastrophic Error *****', advance='yes' )
      end if
      if ( present(state) ) &
        & call output ( state, before='The current state is ', advance='yes' )
      if ( present(nonterminal) ) &
        & call output ( nonterminal, before='The nonterminal symbol is ', &
          & advance='yes' )
      if ( present(the_token) ) then
        call output ( 'Next token is ' )
        call dump_symbol_class ( the_token%class )
        if ( the_token%pseudo .and. the_token%string_index > 0 ) &
          & call display_string ( the_token%string_index, before=' ' )
        call newLine
      end if
      call output( 'About to crash and burn in parser', advance='yes' )
      Nevercrash = .false.
      call Crash_Burn
      ! call MLSMessage ( MLSMSG_Crash, moduleName, trim(text) )
      stop 666
    end subroutine Catastrophic_Error

! ---------------------------------------------------  Do_Include  -----
    subroutine Do_Include
      ! We don't want "string" in the tree, so pop it off the stack.
      use String_Table, only: Display_String, Open_Include
      use Tree, only: Pop, Stack_File, Stack_Source_Ref, Stack_Sub_Rosa
      call open_include ( Stack_Sub_Rosa(), Stack_Source_Ref(), &
                        & Stack_File() )
      if ( toggle(par) ) &
        & call display_string ( Stack_Sub_Rosa(), &
          & before='Opened include file ', advance='yes' )
      call pop ( 1 )
   end subroutine Do_Include

! ---------------------------------------------------  Dump_Stack  -----
    subroutine Dump_Stack ! 1:sp, not just the top frame
      integer :: I
      call output ( 'stack:' )
      do i = 1, sp
        call output ( stack(i)%state, before=' (' )
        call output ( stack(i)%tree_index, before=',', after=')' )
      end do
      call newLine
    end subroutine Dump_Stack

! -----------------------------------------------  Error_Recovery  -----
    subroutine Error_Recovery
      ! This is a REALLY CRUDE error recovery routine.
      use Parser_Table_m, only: Display_Vocab, Vocab_Length
      integer :: I      ! Basis item number
      integer :: J      ! Position of production P in t%prod_inds
      integer :: L      ! Length of a symbol
      integer :: P      ! Production number
      integer :: SX     ! For examining the stack
      integer :: W      ! Current width of output line

      sx = 0
      ! The FMA algorithm rejects actions for items that conflict. The
      ! items are still represented, but the parser decision function in
      ! Work shows no action for the current input. Look down the stack for
      ! states that can consume the LHS of those items, and back up to the
      ! nearest of them.
      do i = t%indbas(nowsta), t%indbas(nowsta+1)-1
        p = t%basProds(i)   ! Production number
        j = t%prod_ind(p)   ! Location of production
        if ( t%dots(i) < t%prod_ind(p+1) - j ) cycle ! Ignore transition
        if ( any ( work(nowsta,1:t%nTerms) == -p ) ) cycle ! Ignore reducing
                                           ! items that still have lookahead
        sx = max ( sx, & ! Can the LHS be consumed?
           & findloc(work(stack(sp-1:1:-1)%state,t%productions(j)) > 0, &
           &         .true., dim=1 ) )
      end do
      ! Back up until we can read the current token.
      if ( sx == 0 ) &
        & sx = findloc(work(stack(sp-1:1:-1)%state,map(the_token%class)) /= 0, &
             &         .true., dim=1 )
      if ( sx /= 0 ) then
        ! There is information on the stack between SX and SP, including
        ! entry symbols of states that are entered by terminal symbols, that
        ! allow construction of a more meaningful error message.
        call output ( '        Removing:' )
        w = len('        Removing:')
        do i = sx+1, sp
          call output ( ' ' )
          if ( stack(i)%state == t%fma_start ) then
            call output ( '?' )
            w = w + 2
          else
            l = vocab_length ( t, t%ent(stack(i)%state) )
            if ( w + l > 120 ) then
              call newLine
              call blanks ( 7 )
              w = 7
            end if
            call display_vocab ( t, t%ent(stack(i)%state) )
            w = w + l + 1
          end if
        end do
        if ( w + len(' from the stack') > 120 ) then
          call newLine
          call blanks ( 7 )
        end if
        call output ( ' from the stack', advance='yes' )
        sp = sx
        nowsta = stack(sp)%state
        need = .false.
        if ( toggle(par) ) then
          call output ( nowsta, before='Backing up to state ', advance='yes' )
          call print_state ( t, nowsta, nBlanks=8 )
        end if
        return
      end if
      ! No state found that can read the LHS of an "interesting" production.
      ! Read tokens until one can be used in the current state.
      do
        if ( the_token%class /= t_end_of_input ) then
          call lexer( the_token )
          if ( work(stack(sp)%state,map(the_token%class)) /= 0 ) exit
        else
          call output ( 'Giving up on recovery; looking for end of input', &
                      & advance='yes' )
          do nowsta = 1, size(work,1)
            if ( work(nowsta,map(t_end_of_input)) > 0 ) exit
          end do
        end if
      end do
    end subroutine Error_Recovery

! -----------------------------------------------  Error_Walkback  -----
    subroutine Error_Walkback ( Line )
      integer, intent(in) :: Line      ! Line number of error
      if ( prev_error > 0 ) call output ( prev_error, &
        & before='Previous error at line ', advance='yes' )
      prev_error = line
    end subroutine Error_Walkback

! ------------------------------------------------  No_Transition  -----
    subroutine No_Transition
      use String_Table, only: String_Length
      integer :: I
      integer :: L ! Length of a symbol
      integer :: W ! Current line width
      call output ( the_token%where%source / 256, 6 )
      call output ( ': *** Error ***  Unexpected Input ')
      call dump_1_symbol ( the_token%string_index, showNumber=.false. )
      if ( the_token%class /= t_end_of_input ) &
         & call print_source ( the_token%where, before=' at ' )
      if ( toggle(par) ) call output ( nowsta, before=' in parser state ' )
      call newLine
      if ( all(work(nowsta,:) == 0) ) then
        call output ( '        Dead-end forward-move state; nothing expected.', &
                      & advance='yes' )
        if ( toggle(par) ) call print_state ( t, nowsta, nBlanks=8 )
        call output ( '        Might be confusion due to', advance='yes' )
      else
        if ( toggle(par) ) call print_state ( t, nowsta, nBlanks=8 )
        call output ( '        Expected one of:' )
        w = len('        Expected one of:' )
        do i = 1, t%nterms
          if ( work(nowsta,i) /= 0 .and. map(i) > 0 ) then
            if ( t%val(i) < 0 ) then ! Symbol with no vocabulary definition
              l = 8
            else
              l = string_length(class_texts(t%val(i)))
            end if
            if ( l + w > 120 ) then
              call newLine
              call blanks ( 7 )
              w = 7
            end if
            call blanks ( 1 )
            if ( t%val(i) < 0 ) then ! Symbol with no vocabulary definition
              call output ( t%val(i), before=' ??? ' )
            else
              call dump_symbol_class ( t%val(i) )
            end if
            w = w + l + 1
          end if
        end do
        call newLine
      end if
      call error_walkback ( the_token%where%source / 256 )
    end subroutine No_Transition

! --------------------------------------------  Reduce_Production  -----
    logical function Reduce_Production ( Prod )
      ! Reduce a production. If working in FMA, and the RHS is long
      ! enough to cross the FMA_Start state, it might not be possible
      ! to reduce because there is no state on the stack where the
      ! LHS can be used.
      integer, intent(in) :: Prod ! Index of production to reduce
      integer :: Action       ! action when reducing a production:
                              !      1 = produce a node
                              !      2 = produce a node iff > 1 sons
      integer :: I            ! temporary variable
      integer :: LHS_TREE     ! tree stack index for t%lhs
      integer :: NEW_NODE     ! tree node to make
      integer :: NSONS        ! number of tree parts associated with rhs
      integer :: SX           ! To examine the stack if FMA_Reduce

      if ( toggle(par) ) then
        call output ( prod, before='Reduce production ' )
        call output ( t%lens(prod), before=' consuming ' )
        call output ( trim(merge(' symbol ', ' symbols', t%lens(prod)==1)) )
      end if

      reduce_production = .true. ! Assume it will succeed
      sx = sp - t%lens(prod)     ! Pop RHS-length frames from the stack

      if ( sp > top_fma ) then   ! Forward Move Algorithm is running
        ! Back up to a state that can use the LHS
        do
          if ( sx <= 1 ) then
            reduce_production = .false.
            if ( toggle(par) ) then
              call newLine
              i = t%lhs(prod)
              call output ( 'No state can use LHS ' )
              call output ( t%text(t%ltext(i-1)+1:t%ltext(i)) )
              call output ( prod, before=' of production ' )
              call output ( ' in FMA reduction.', advance='yes' )
            end if
            return
          end if
          if ( work(stack(sx)%state,t%lhs(prod)) /= 0 ) exit
          sx = sx - 1
        end do
        do while ( sp > sx )
          if ( stack(sp)%prev_fma /= 0 ) top_fma = stack(sp)%prev_fma
          sp = sp - 1
        end do
      else
        sp = sx
      end if

      nowsta = stack(sp)%state
      lhs_tree = stack(sp)%tree_index
      nsons = n_tree_stack - lhs_tree
      i = t%act(prod)           ! use i for temp while getting action
      new_node = i / 10
      action = mod(i, 10)
      if ( i /= 0 ) then
        if ( action==1 .or. ( action==2 .and. nsons>1 ) ) then
          if ( show_build > 0 ) call newLine
          call build_tree ( new_node, nsons, trace=show_build )
          if ( toggle(par) ) then
            if ( show_build == 0 ) call output ( ', ' )
            call output ( new_node, before='building ', after=': ' )
            call dump_top_stack ( 0 )
          end if
        else if ( action == 9 ) then
          call do_include
        end if
      else if ( toggle(par) .and. nsons>0 ) then
        call output ( nsons, before=', subsuming ' )
        call output ( trim(merge(' tree node ', ' tree nodes', nsons==1)) )
      end if
      if ( toggle(par) ) then
        call output ( nowsta, before=', returning to state ' )
        if ( show_stack ) call show_the_stack
        call output ( '.', advance='yes' )
        if ( show_whole_stack ) call dump_stack
      end if

      newsta = work(nowsta,t%lhs(prod))
      if ( newsta == 0 ) &
        & call catastrophic_error ( 'There is no state transition', &
          & state=nowsta, nonterminal=t%lhs(prod) )
      call transition ( .true., t%lhs(prod) )  ! push Newsta onto the parser
                                ! stack and make it Nowsta.

    end function Reduce_Production

! -----------------------------------------------  Show_The_Stack  -----
    subroutine Show_The_Stack
      call output ( sp, before=', stack(' )
      call output ( stack(sp)%state, before=') = (' )
      call output ( stack(sp)%tree_index, before=',' )
      call output ( ')' )
    end subroutine Show_The_Stack

! -------------------------------------------------  Syntax_Error  -----
    subroutine Syntax_Error ( Reducing )
      ! Try to start the forward-move algorithm, if there are not
      ! already too many running, and the current state is not a
      ! dead-end FMA state, else do crude error recovery

      logical, intent(in) :: Reducing ! No state could consume LHS

      if ( count(stack(1:sp)%state == t%fma_start) < max_FMA .and. &
         & any(work(nowsta,:) /= 0)) then
        ! Try the forward-move algorithm
        newsta = t%fma_start
        call transition ( .false. )  ! Push Newsta onto the parser stack
                                     ! and make it Nowsta.
        need = reducing              ! Don't consume the token if the error
                                     ! resulted from a failure to have any
                                     ! actions. Consuming it causes confusion
                                     ! later. Consume it if the error resulted
                                     ! from failure to consume the LHS during a
                                     ! reduction. Failing to consume it puts the
                                     ! parser into a loop.
        stack(sp)%prev_FMA = top_fma ! Link to previous FMA frame, if any
        top_fma = sp
      else
        call error_recovery
      end if
    end subroutine Syntax_Error

! ---------------------------------------------------  Transition  -----
    subroutine Transition ( LHS, Voc )
      ! Set the current state (Nowsta) to the new state (Newsta)
      ! and push it on the stack with N_Tree_Stack.
      use Parser_Table_m, only: Display_Vocab
      logical, intent(in) :: LHS ! VOC is index of LHS symbol of production
      integer, intent(in), optional :: Voc ! Vocabulary symbol index
      integer :: N, S
      integer :: Stat
      character(127) :: ERmsg
      type(stack_frame), allocatable :: TempStack(:)

      ! Make sure we have a stack, and it's big enough to push the new state
      n = 0
      if ( allocated(stack) ) n = ubound(stack,1)
      if ( sp >= n ) then
        s = max(100,2*n)
        allocate ( tempStack(s), stat=stat, errmsg=ermsg )
        if ( stat /= 0 ) then
          write ( error_unit, '(2a)' ) 'Parser%Transition-%E- ', &
            & 'Unable to allocate TempStack'
          write ( error_unit, '(a,i0)' ) 'Stat = ', stat
          write ( error_unit, '(a)' ) trim(ermsg)
          stop
        end if
        if ( allocated(stack) ) tempStack(1:sp) = stack(1:sp)
        call move_alloc ( tempStack, stack )
      end if

      nowsta = newsta
      sp = sp + 1
      stack(sp) = stack_frame(nowsta,n_tree_stack)

      if ( toggle(par) ) then
        call output ( newsta, before='Enter state ' )
        if ( present(voc) ) then
          call output ( ' with ' )
          if ( voc < 0 ) then
            call output ( t%ent(nowsta), before='symbol number ' )
          else if ( lhs ) then
            call display_vocab ( t, voc, before='nonterminal symbol ' )
          else
            call dump_1_symbol ( the_token%string_index )
          end if
        end if
        if ( show_stack ) call show_the_stack
        call output ( n_tree_stack, before=', n_tree_stack = ' )
        call newLine
        if ( show_state ) call print_state ( t, nowsta )
        if ( show_whole_stack ) call dump_stack
      end if

    end subroutine Transition

  end subroutine LR_Parser_Int

! ----------------------------------------------  Clean_Up_Parser  -----
  subroutine Clean_Up_Parser
    deallocate ( work, LR_0 )
  end subroutine Clean_Up_Parser

!--------------------------- end bloc --------------------------------------
  logical function not_used_here()
  character (len=*), parameter :: IdParm = &
       "$Id: parser.f90,v 1.4 2022/02/10 18:57:13 vsnyder Exp $"
  character (len=len(idParm)) :: Id = idParm
    not_used_here = (id(1:1) == ModuleName(1:1))
    print *, Id ! .mod files sometimes change if PRINT is added
  end function not_used_here
!---------------------------------------------------------------------------

end module PARSER

! $Log: parser.f90,v $
! Revision 1.4  2022/02/10 18:57:13  vsnyder
! Remove unused USE for display_string. Remove unused LHS
!
! Revision 1.3  2022/02/10 18:55:07  vsnyder
! Prevent looping in FMA
!
! Revision 1.2  2022/01/28 01:55:16  vsnyder
! Changed parser table format
!
! Revision 1.1  2022/01/24 22:14:41  vsnyder
! Initial commit
!
