module Parser_Table_m

  ! Type definition for parser tables

  use Parser_Tables, only: Parser_Table_t

  implicit NONE
  private

  public :: Display_Vocab, Get_Vocab, Make_PD_Array
  public :: Print_Action, Print_Grammar, Print_State, Vocab_Length 

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

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

! ------------------------------------------------  Make_PD_Array  -----
  subroutine Make_PD_Array ( T, Work, LR_0, T_Null, Map, Show_Work, Machine )

  ! Make the parser decision fuction, represented by Work, LR_0 and Map
  ! arrays, to avoid searching t%ftrn, t%tran, t%fred, t%nset, t%lset, and
  ! t%ls to determine whether to reduce a production or make a transition.

  ! Positive elements of WORK are new state numbers and indicate transitions.
  ! Negative elements of WORK are indices of productions to reduce.
  ! Zero elements of WORK indicate syntax errors.

  ! Columns 1:nterms are indexed by terminal symbol vocabulary indices. 
  ! Columns nterms+1:nvoc are indexed by nonterminal symbol vocabulary
  ! indices, never indicate reductions, and errors are not possible.

    use Output_m, only: NewLine, Output

    type(parser_table_t), intent(in) :: T
    integer, intent(out) :: WORK(:,:) ! ( t%nstate, t%nvoc )
    integer, intent(out) :: LR_0(:)   ! ( t%nstate ), "state is an LR(0) state"
    integer, intent(in) :: T_Null     ! Avoids using Symbol_Types
    integer, intent(out) :: Map(t_null:) ! Inverse of t%val
    logical, intent(in), optional :: Show_Work ! Show the Work array
    logical, intent(in), optional :: Machine   ! Print the parsing automaton

    ! t%ftrn(0:nstate): Indexed by state number.  First (actually last)
    ! transitions.  Transitions for state S are in t%tran(t%ftrn(S-1)+1:t%ftrn(S)).

    ! t%tran(1:ntrans): New state indices, indexed by t%ftrn, q.v.

    ! t%ent(1:nstate): Indexed by state number.  Index of vocabulary symbol
    ! used to enter a state.

    ! t%fred(0:nstate): Indexed by state number.  First (actually last)
    ! reductions.  Lookahead sets for state S are t%nset(t%fred(S-1)+1:t%fred(S)).

    ! t%nset(1:nlooks): Lookahead set indices, indexed by t%fred, q.v.

    ! t%lset(0:ncsets): Last elements of lookahead sets, indexed by t%nset, q.v.
    ! For lookahead set L, elements are t%ls(t%lset(L-1)+1:t%lset(L)).

    ! t%ls(1:lsets): Elements of lookahead sets.

    ! t%prod(1:nlooks): Production numbers to reduce if lookahead is in the
    ! set, indexed by t%fred, q.v.

    logical :: Error
    integer :: I, J, L
    logical :: My_Show_Work, My_Machine

    error = .false. ! Assume OK
    my_show_work = .false.
    if ( present(show_work) ) my_show_work = show_work
    my_machine = .false.
    if ( present(machine) ) my_machine = machine
    work = 0

    ! Fill in the transitions
    do i = 1, ubound(t%ftrn,1)
      ! Eliminated conflicting transitions in FMA states are zero
      where ( t%tran(t%ftrn(i-1)+1:t%ftrn(i)) /= 0 ) &
      work(i,t%ent(t%tran(t%ftrn(i-1)+1:t%ftrn(i)))) = t%tran(t%ftrn(i-1)+1:t%ftrn(i))
    end do

    ! Fill in the reductions
    do i = 1, ubound(t%fred,1)
      do j = t%fred(i-1)+1, t%fred(i)
        ! Eliminated conflicting reductions' lookaheads in FMA states are zero
        if ( t%nset(j) /= 0 ) then
          do l = t%lset(t%nset(j)-1)+1, t%lset(t%nset(j))
            if ( work(i,t%ls(l)) > 0 ) then
              write ( *, '(3(a,i0))' ) &
                & 'Grammar is not LR.  Intersection in state ', i, &
                & ' with transition to state ', work(i,t%ls(l)), &
                & ' on vocabulary symbol with internal index ', t%ls(l)
                error = .true.
            else if ( work(i,t%ls(l)) < 0 ) then
              write ( *, '(3(a,i0))' ) &
                & 'Grammar is not LR.  Intersection in state ', i, &
                & ' with reduction of production ', -work(i,t%ls(l)), &
                & ' on vocabulary symbol with internal index ', t%ls(l)
                error = .true.
            else
              work(i,t%ls(l)) = -t%prod(j)
            end if
          end do
        end if
      end do
    end do

    do i = 1, ubound(work,1)
      if ( t%ftrn(i) == t%ftrn(i-1) .and. &    ! No transitions
         & t%fred(i) == t%fred(i-1)+1 ) then   ! One reduction
        lr_0(i) = t%prod(t%fred(i))
      else
        lr_0(i) = 0
      end if
    end do

    map = 0
    do i = 1, ubound(t%val,1)
      if ( t%val(i) > 0 .and. t%val(i) < ubound(map,1) ) map(t%val(i)) = i
    end do

    if ( my_show_work ) then
      call output ( "Parser's WORK array:", advance='yes' )
      do i = 1, size(work,2), 20
        call output ( 'vocab:' )
        do l = i, min(i+19,size(work,2))
          call output ( l, places=6 )
        end do
        call newline
        do j = 1, size(work,1)
          call output ( j, format='(i5,":")' )
          do l = i, min(i+19,size(work,2))
            call output ( work(j,l), places=6 )
          end do
          call newline
        end do
      end do
    end if

    if ( error ) then
      write ( *, '(a)' ) 'Error: Make_PD_Array_m.Make_PD_Array%E%- Grammar is not LR(1)'
      stop 1
    end if

    if ( my_machine ) then
      call print_grammar ( t )
      call output ( 'The parsing automaton (sans context sets for reductions):', &
        & advance='yes' )
      do i = 1, t%nstate
        call newLine
        call print_state ( t, i, number=.true. )
      end do
      call output ( 'End of the parsing automaton', advance='yes' )
    end if

  end subroutine Make_PD_Array

! -------------------------------------------------  Print_Action  -----
  subroutine Print_Action ( T, P )
  ! Print the action for production P
    use Output_m, only: Output
    use String_Table, only: Display_String
    use Tree, only: Tree_Text
    type(parser_table_t), intent(in) :: T
    integer, intent(in) :: P ! The pr1oduction number
    integer :: A
    a = t%act(p)
    if ( a /= 0 ) then
      select case ( mod(a,10) )
      case ( 1 )
        call display_string ( tree_text(a / 10), before=' => ' )
      case ( 2 )
        call display_string ( tree_text(a / 10), before=' => ' )
        call output ( ' ?' )
      case default
        call output ( a, before=' => ' )
      end select
    end if
  end subroutine Print_Action

! ------------------------------------------------  Print_Grammar  -----
  subroutine Print_Grammar ( T )
  ! Print the entire grammar, with actions.
    use Output_m, only: Blanks, NewLine, Output
    type(parser_table_t), intent(in) :: T
    integer :: J, K, LHS, P, PrevLHS
    character(120) :: Work ! To strip underscore off nonterminal names
    call output ( 'The grammar:', advance='yes' )
    prevLHS = -1
    do p = 1, t%numprd
      j = t%prod_ind(p)
      lhs = t%productions(j)
      if ( lhs /= prevLHS .and. p /= 1 ) call newLine
      call output ( p, 3 )
      call get_vocab ( t, lhs, work )
      k = merge(2,1,work(1:1)=='_')
      if ( lhs /= prevLHS ) then
        call output ( ' ' // trim(work(k:)) )
      else
        call blanks ( vocab_length(t, lhs) + 2 - k )
      end if
      prevLHS = lhs
      call output ( ' ->' )
      do j = t%prod_ind(p)+1, t%prod_ind(p+1)-1
        call get_vocab ( t, t%productions(j), work )
        k = merge(2,1,work(1:1)=='_')
        call output ( ' ' // trim(work(k:)) )
      end do
      call print_action ( t, p )
      call newLine
    end do
    call output ( 'End of the grammar', advance='yes' )
  end subroutine Print_Grammar

! --------------------------------------------------  Print_State  -----
  subroutine Print_State ( T, State, Number, NBlanks )
  ! Print the parser configuration in state STATE, i.e., the list of
  ! t%productions, with t%dots in them.
    use Output_m, only: Blanks, NewLine, Output
    type(parser_table_t), intent(in) :: T
    integer, intent(in) :: State
    logical, intent(in), optional :: Number  ! Print state number
    integer, intent(in), optional :: NBlanks ! Number of blanks to emit first
    integer :: I, J, K, JDOT, P
    logical :: Num
    character(120) :: Work ! To strip underscore off nonterminal names
    if ( present(nBlanks) ) call blanks ( nBlanks )
    num = .false.
    if ( present(number) ) num = number
    do i = t%indbas(state), t%indbas(state+1)-1
      p = t%basProds(i)
      if ( num ) then
        if ( i == t%indbas(state) ) then
          call output ( state, 5 )
        else
          call blanks ( 5 )
        end if
      end if
      call output ( p, 5 )
      j = t%prod_ind(p) ! p = production number
      call get_vocab ( t, t%productions(j), work )
      k = merge(2,1,work(1:1)=='_')
      call output ( ' ' // trim(work(k:)) )
      call output ( ' ->' )
      jdot = 1
      do j = t%prod_ind(p)+1, t%prod_ind(p+1)-1
        if ( t%dots(i) == jdot ) call output ( ' .' )
        jdot = jdot + 1
        call get_vocab ( t, t%productions(j), work )
        k = merge(2,1,work(1:1)=='_')
        call output ( ' ' // trim(work(k:)) )
      end do
      if ( t%dots(i) == jdot ) call output ( ' .' )
      call print_action ( t, p )
      call newLine
    end do
    if ( num ) then ! Print transitions if any
      if ( t%ftrn(state) > t%ftrn(state-1) ) then
        call blanks ( 11 )
        call output ( 'Transitions: ' )
        do i = t%ftrn(state-1)+1, t%ftrn(state)
          call output ( t%tran(i), 5 )
        end do
        call newLine
      end if
    end if
  end subroutine Print_State

  subroutine Dump_Parser_Table_t ( T )
    use Output_m, only: Output
    type(parser_table_t), intent(in) :: T
    integer :: I
    call output ( t%ifinal, before='Ifinal ', advance='yes' )
    call output ( t%FMA_Start, before='FMA_Start ', advance='yes' )
    call output ( t%LSets, before='LSets ', advance='yes' )
    call output ( t%NCsets, before='NCsets, ', advance='yes' )
    call output ( t%NLooks, before='NLooks ', advance='yes' )
    call output ( t%NState, before='NState ', advance='yes' )
    call output ( t%NTerms, before='NTerms ', advance='yes' )
    call output ( t%NumPrd, before='NumPrd ', advance='yes' )
    call output ( t%NVoc, before='NVoc ', advance='yes' )
    call output ( t%Total, before='Total ', advance='yes' )
    call output ( t%NBasProd, before='NBasProd ', advance='yes' )
    call output ( 'Ent', advance='yes' )
    call output ( t%ent, 'no', 10, 5 )
    call output ( 'Fred', advance='yes' )
    call output ( t%fred, 'no', 10, 5, offset=-1 )
    call output ( 'Ftrn', advance='yes' )
    call output ( t%Ftrn, 'no', 10, 5, offset=-1 )
    call output ( 'Tran', advance='yes' )
    call output ( t%Tran, 'no', 10, 5 )
    call output ( 'Nset', advance='yes' )
    call output ( t%Nset, 'no', 10, 5 )
    call output ( 'Prod', advance='yes' )
    call output ( t%Prod, 'no', 10, 5 )
    call output ( 'Lset', advance='yes' )
    call output ( t%Lset, 'no', 10, 5, offset=-1 )
    call output ( 'Ls', advance='yes' )
    call output ( t%Ls, 'no', 10, 5 )
    call output ( 'Lens', advance='yes' )
    call output ( t%Lens, 'no', 10, 5 )
    call output ( 'Lhs', advance='yes' )
    call output ( t%Lhs, 'no', 10, 5 )
    call output ( 'Act', advance='yes' )
    call output ( t%Act, 'no', 10, 5 )
    call output ( 'Val', advance='yes' )
    call output ( t%Val, 'no', 10, 5 )
    call output ( 'Prod_Ind', advance='yes' )
    call output ( t%Prod_Ind, 'yes', 10, 5 )
    call output ( 'Productions', advance='yes' )
    call output ( t%Productions, 'yes', 10, 5 )
    call output ( 'IndBas', advance='yes' )
    call output ( t%IndBas, 'yes', 10, 5 )
    call output ( 'Dots', advance='yes' )
    call output ( t%Dots, 'no', 10, 5 )
!     call output ( 'LFirst', advance='yes' )
!     call output ( t%LFirst, 'no', 10, 5, offset=-1 )
!     call output ( 'First', advance='yes' )
!     call output ( t%First, 'no', 10, 5, offset=-1 )
!     call output ( 'Nullable', advance='yes' )
!     call output ( t%Nullable, 'no', 10, 5, offset=-1 )
    call output ( 'Text', advance='yes' )
    do i = 1, len(t%text), 50
      call output ( t%text(i:min(len(t%text),i+49)), advance='yes' )
    end do
    call output ( 'Ltext', advance='yes' )
    call output ( t%Ltext, 'yes', 10, 5 )
  end subroutine Dump_Parser_Table_t

  subroutine Display_Vocab ( T, V, Before, Advance )
  ! Display vocabulary symbol V from parser table T.
    use Output_m, only: Output
    type(parser_table_t), intent(in) :: T ! The parser table
    integer, intent(in) :: V              ! Index of symbol in T%LText
    character(*), intent(in), optional :: Before
    character(*), intent(in), optional :: Advance
    if ( present(before) ) call output ( before )
    call output ( t%text(t%ltext(v-1)+1:t%ltext(v)), advance=advance )
  end subroutine Display_Vocab

  subroutine Get_Vocab ( T, V, Text )
  ! Get vocabulary symbol V from parser table T.
    type(parser_table_t), intent(in) :: T ! The parser table
    integer, intent(in) :: V              ! Index of symbol in T%LText
    character(*), intent(out) :: Text
    integer :: I, J
    j = 1
    do i = t%ltext(v-1)+1, t%ltext(v)
      text(j:j) = t%text(i:i)
      j = j + 1
    end do
    text(j:) = ''
  end subroutine Get_Vocab

  integer function Vocab_Length ( T, V )
  ! Get the length of vocabulary symbol V from parser table T.
    type(parser_table_t), intent(in) :: T ! The parser table
    integer, intent(in) :: V              ! Index of symbol in T%LText
    vocab_length = t%ltext(v) - t%ltext(v-1)
  end function Vocab_Length

!--------------------------- end bloc --------------------------------------
  logical function not_used_here()
  character (len=*), parameter :: IdParm = &
       "$Id: Parser_Table_m.f90,v 1.3 2022/02/10 01:05:29 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_Table_m

! $Log: Parser_Table_m.f90,v $
! Revision 1.3  2022/02/10 01:05:29  vsnyder
! Reomve Caltech copyright because work was done at home to produce materials
! for teaching classes at West Coast University, and then used at Caltech.
!
! Revision 1.2  2022/01/28 01:55:16  vsnyder
! Changed parser table format
!
! Revision 1.1  2022/01/24 22:15:54  vsnyder
! Initial commit
!
