program Capture

  ! Capture boxes, circles, and lines from tgif files.
  ! Boxes are called "box". Circles are called "oval". Lines are called "poly."


  use, intrinsic :: ISO_Fortran_Env, only: Error_Unit, Output_Unit

  use Lexer_Actions_m, only: Make_DFA_2D
  use Lexer_Core, only: Init_Lexer
  use Output_m, only: Blanks, Output, OutputOptions
  use Parser, only: Clean_Up_Parser, LR_Parser
  use Parser_Tables, only: Parser_Table
  use String_Table, only: AddInUnit, Open_Input
  use Toggles, only: Con, Gen, Levels, Lex, Par, Toggle
  use Tree, only: Allocate_tree, Print_Subtree
  use Tree_Walker_m, only: Tree_Walker

  implicit NONE

  character(8) :: Block_Rows  ! Rows where there are blocks A-HJ
  integer :: Depth = 0     ! For dumping the abstract syntax tree
  logical :: Dump_Tree = .false.
  logical :: Error = .false. ! Somebody detected an error
  integer :: I, J          ! Loop indices
  character(127) :: Input_File
  integer :: Input_Unit = 0
  character(1023) :: IOMSG ! From Open
  integer :: IOSTAT        ! From Open
  character(1023) :: Line  ! From command line
  integer :: List_Unit = Output_Unit ! Defaults to standard output
  character(1023) :: Listing = '' ! List file name
  character(3), parameter :: Months(12) = ['Jan', 'Feb', 'Mar', 'Apr', 'May', &
                           & 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' ]
  character(127) :: Output_File = '' ! Output file
  integer :: Root          ! Of the abstract syntax tree
  integer :: U = 0         ! Output unit
  integer :: When(8)       ! Values argument from Date_And_Time

!---------------------------- RCS Ident Info ------------------------------
  character (len=*), parameter :: ModuleName= &
       "$RCSfile: Capture.f90,v $"
!---------------------------------------------------------------------------

  call init_lexer ( n_chars=80000, n_symbols=4000, hash_table_size=611957, &
    & Debug=0 )
  call make_DFA_2D
  call allocate_tree ( n_tree=2000000 )


  ! Process command line
  i = 0
  do
    i = i + 1
    call get_command_argument ( i, line )
    if ( line(1:1) /= '-' ) exit
    j = 1
    do
      j = j + 1
      if ( j > len_trim(line) ) exit
      select case ( line(j:j) )
      case ( 'A' ) ! Dump abstract syntax tree
        dump_tree = .true.
      case ( 'C' ) ! Trace table collection
        toggle(con) = .true.
        call digit_after_option ( j, con )
      case ( 'B' ) ! Rows where there are blocks
        if ( line(j+1:) == ' ' ) then
          i = i + 1
          call get_command_argument ( i, line )
          block_rows = upper_case(line(1:8))
          j = len(line)
        else
          block_rows = upper_case(line(j+1:j+8))
          j = j + 9
        end if
        iostat = verify ( block_rows, ' ABCDEFGHJ' )
        if ( iostat /= 0 ) then
          write ( error_unit, '(*(a))' ) 'Invalid block row "', &
            & block_rows(iostat:iostat), '".'
          error = .true.
        end if
      case ( 'G' ) ! Trace generation
        toggle(gen) = .true.
        call digit_after_option ( j, gen )
      case ( 'L' ) ! Trace lexer
        toggle(lex) = .true.
        call digit_after_option ( j, lex )
      case ( 'P' ) ! Trace parser
        toggle(par) = .true.
        call digit_after_option ( j, par )
      case ( 'V' ) ! Print version and stop
        call get_version ( line )
        write ( *, '(a)' ) trim(line)
        stop
      case default
        write ( error_unit, '(*(a))' ) 'Invalid option "', line(j:j), '".'
        call usage
      end select
    end do
  end do

  if ( line(1:1) == ' ' ) call usage

  ! Open input file
  input_unit = 0 ! Tell open_input to get a unit number
  input_file = line
  call open_input ( input_file, unit=input_unit )
  call AddInUnit( input_unit )

  ! Get output file name
  outputOptions%prUnitLiteral = .true. ! Do output even if list_unit < 0
  call get_command_argument ( i+1, line )
  if ( line /= '' ) listing = line
  if ( listing /= '' ) then
    open ( newunit=list_unit, file=listing, form='formatted', iostat=iostat, &
      & iomsg=iomsg )
    if ( iostat /= 0 ) then
      write ( error_unit, '(3a,i0)' ) 'Error: Unable to open list file "', &
        & trim(listing), '", IOSTAT = ', iostat
      write ( error_unit,  '(a)') trim(iomsg)
      stop 1
    end if
    outputOptions%prUnit = list_unit
  end if

  call get_command_argument ( i+2, output_file )
  if ( output_file /= '' ) then
    open ( newunit=u, file=output_file, form='formatted', iostat=iostat, &
      & iomsg=iomsg )
    if ( iostat /= 0 ) then
      write ( error_unit, '(3a,i0)' ) 'Error: Unable to open output file "', &
        & trim(output_file), '", IOSTAT = ', iostat
      write ( error_unit,  '(a)') trim(iomsg)
      stop 1
    end if
  end if

  call date_and_time ( values=when )
  write ( line, 1 ) '; ', when(3), months(when(2)), when(1), when(5:7)
1 format ( a, i0, 1x, a, 1x, i0, 1x, i0, 2(":",i2.2) )
  call output ( trim(line) )
  call blanks ( 1 )
  call get_command ( line )
  call output ( trim(line), advance='yes' )
  call get_version ( line )
  write ( *, '(a)' ) trim(line)

  ! Parse the input, producing an abstract syntax tree
  call lr_parser ( root, parser_table )
  call clean_up_parser

  error = root < 0
  if ( error ) then
    call output ( 'A syntax error occurred; there is no abstract syntax tree.', &
      & advance='yes' )
    write ( error_unit, '(a)' ) &
      & 'A syntax error occurred; there is no abstract syntax tree.'
    stop 'Syntax error'
  end if

  if ( dump_tree ) then
    call output ( 'Abstract syntax tree before type checking:', advance='yes' )
    call print_subtree ( root, depth )
    call output ( 'End of abstract syntax tree', advance='yes' )
  end if

  call init_symbols

  call tree_walker ( root, u, block_rows, error )
  if ( error ) then
    write ( error_unit, '(a)' ) 'Coordinates out of range'
  end if

contains

  subroutine Digit_After_Option ( J, Tog, Level )
    character(len=*), parameter :: Digits = '0123456789'
    integer, intent(inout) :: J  ! Position in LINE
    integer, intent(in), optional :: Tog   ! Subscript of Toggles and Levels array
    integer, intent(out), optional :: Level ! Instead of Tog
    integer :: I, K              ! Loop inductor, subscript
    k = j + 1
    do i = k, len(line)
      if ( verify(line(i:i),digits) /= 0 ) exit
    end do
    if ( i > k ) then
      j = i - 1
      if ( present(tog) ) read ( line(k:j), * ) levels(tog)
      if ( present(level) ) read ( line(k:j), * ) level
    end if
  end subroutine Digit_After_Option

  subroutine Get_Version ( Ver )
    character(*), intent(out) :: Ver
    character (len=*), parameter :: IdParm = &
      "$Id: Capture.f90,v 1.0 2022/03/31 01:53:14 vsnyder Exp $"
    integer :: I, J
    i = index(idParm,",v")
    if ( i == 0 ) i = -1
    i = i + 2
    j = index(idParm,":",back=.true.)
    j = min(j+2,len(idParm))
    ver = 'Version ' // trim(adjustl(idParm(i:j)))
  end subroutine Get_Version

  subroutine Init_Symbols
    use Declaration_Types, only: Func, F_Block, F_Dot, F_Line
    call init_one_symbol ( 'box',  func, f_block )
    call init_one_symbol ( 'oval', func, f_dot   )
    call init_one_symbol ( 'poly', func, f_line  )
  end subroutine Init_Symbols

  subroutine Init_One_Symbol ( String, What, Value )
    use Declaration_Table, only: Declare
    use Symbol_Table, only: Enter_Terminal
    ! Initialize one symbol.
    character(*), intent(in) :: String   ! Symbol text
    integer, intent(in) :: What          ! Declaration type
    integer, intent(in) :: Value         ! Value field in declarationt table
    call declare ( enter_terminal ( string, 0 ), what, 0, value )
  end subroutine Init_One_Symbol

  function Upper_Case ( C ) result ( U )
    character(*), intent(in) :: C
    character(len(c)) :: U
    integer :: I
    do i = 1, len(c)
      u(i:i) = c(i:i)
      if ( c(i:i) >= 'a' .and. c(i:i) <= 'z' ) &
        u(i:i) = achar(iachar(c(i:i)) + iachar('A') - iachar('a'))
    end do
  end function Upper_Case

  subroutine Usage
    call get_command_argument ( 0, line )
    print '(3a)', 'Usage: ', trim(line), ' [options] input [ output ]'
    print '(a)', ' Options:'
    print '(a)', '  -A => Print abstract syntax tree'
    print '(a)', '  -C => Trace table collection'
    print '(a)', '  -G => Trace generation'
    print '(a)', '  -L[ ]# => Trace lexing'
    print '(a)', '  -P[ ]# => Trace parsing'
    print '(a)', '  -V => Print version and stop'
    stop
  end subroutine Usage

end program Capture

! $Log: Capture.f90,v $
