program ALDgen

  ! Make IBM 1401 (and maybe other) Automated Logic Diagrams.

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

  use Declaration_Table, only: Dump_Decl
  use Declaration_Types, only: Value_Names
  use Generate_Text_m, only: Generate_Text
  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: N_Spec, N_Field, Parser_Table
  use String_Table, only: AddInUnit, Do_Listing, Open_Input
  use Symbol_Table, only: Dump_Symbol_Table
  use Tables_m, only: Dump_Tables, Entable, Last_Page
  use Toggles, only: Con, Gen, Levels, Lex, Par, Switches, Tab, Toggle
  use Tree, only: Allocate_tree, Decoration, Node_Id, Print_Subtree
  use Type_Checker_m, only: Type_Checker

  implicit NONE

  integer :: B = 0         ! Unit number for "Before" file
  character(127) :: Before = 'Before.ps' ! Default "Before" PostScript starter
  integer :: Depth = 0     ! For dumping the abstract syntax tree
  character(127) :: Drawing
  integer :: Drawing_Unit = Output_Unit
  integer :: Dump_Decls = -1
  logical :: Dump_Decorated = .false.
  logical :: Dump_Symbols = .false.
  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
  logical :: L_Option = .false.   ! List file name came from -l option.
  character(1023) :: Line  ! From command line
  integer :: List_Unit = Output_Unit ! Defaults to standard output
!  integer :: List_Unit = Error_Unit ! Defaults to standard error
  character(1023) :: Listing = '' ! List file name
  integer :: Modular = 1   ! Form of logic boxes
  character(3), parameter :: Months(12) = ['Jan', 'Feb', 'Mar', 'Apr', 'May', &
                           & 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' ]
  logical :: PostScript = .true. ! "Write PostScript output"
  integer :: Root          ! Of the abstract syntax tree
  integer :: Son1 = 1      ! Son of root to start processing after type checking
  logical :: Warn          ! "A warning occurred"
  integer :: When(8)       ! Values argument from Date_And_Time

  character(*), parameter :: Sep = '/\\' ! Two \ in case one is an escape

!---------------------------- RCS Ident Info ------------------------------
  character (len=*), parameter :: ModuleName= &
       "$RCSfile: lr.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 ( ' ' )
        exit
      case ( 'A' ) ! Dump abstract syntax tree before type checking
        dump_tree = .true.
      case ( 'a' ) ! Dump decorated abstract syntax tree after type checking
        dump_decorated = .true.
      case ( 'B' ) ! "Before" file
        if ( line(j+1:) == '' ) then
          i = i + 1
          call get_command_argument ( i, line(j+1:) )
        end if
        before = line(j+1:)
        exit
      case ( 'D' ) ! Trace declaration table actions
        toggle(tab) = .true.
        call digit_after_option ( j, tab )
      case ( 'd' ) ! Dump declaration table
        dump_decls = 0
        call digit_after_option ( j, level=dump_decls )
      case ( 'g' ) ! Trace code generation
        toggle(gen) = .true.
        call digit_after_option ( j, gen )
      case ( 'i' )
        do_listing = .true.
      case ( 'l' ) ! Specify listing file
        l_option = .true.
        if ( line(j+1:) == ' ' ) then
          i = i + 1
          call get_command_argument ( i, line(j+1:) )
        end if
        listing = line(j+1:)
        j = len(line)+1
      case ( 'L' ) ! Trace lexer
        toggle(lex) = .true.
        call digit_after_option ( j, lex )
      case ( 'P' ) ! PostScript output
        postScript = .true.
      case ( 'p' ) ! Trace parser
        toggle(par) = .true.
        call digit_after_option ( j, par )
      case ( 's' ) ! Dump symbol table after the parser finishes
        dump_symbols = .true.
      case ( 'S' ) ! Set switches for debugging
        if ( line(j+1:) == ' ' ) then
          i = i + 1
          call get_command_argument ( i, line(j+1:) )
        end if
        if ( line(j+1:j+1) == '?' ) call Switch_Usage
        switches(len_trim(switches)+1:) = ',' // trim(line(j+1:))
        j = len(line) + 1
      case ( 'T' ) ! Plain text output using DECtech encoding
        postScript = .false.
      case ( 't' ) ! Trace type checking
        toggle(con) = .true.
        call digit_after_option ( j, con )
      case ( 'V' ) ! Print version and stop
        call get_version ( line )
        write ( *, '(a)' ) trim(line)
        stop
      case ( '1' )
        modular = 1
      case ( '2' )
        modular = 2
      case default
        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
  call get_command_argument ( i+1, line )
  if ( line /= '' ) listing = line
  if ( listing /= '' ) then
    ! Use status NEW so as not to destroy the input file if the listing
    ! file came from the -l option, which might mistakenly have been selected
    ! instead of -L or -i.
    open ( newunit=list_unit, file=listing, form='formatted', iostat=iostat, &
      & iomsg=iomsg, status=trim(merge('new    ','unknown',l_option)) )
    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
    drawing_unit = list_unit
    outputOptions%prUnit = list_unit
    outputOptions%prUnitLiteral = .true. ! Do output even if list_unit < 0
  end if

  ! Get drawing file name
  call get_command_argument ( i+2, line )
  if ( line /= '' ) drawing = line
  if ( drawing /= '' ) then
    open ( newunit=drawing_unit, file=drawing, form='formatted', iostat=iostat, &
      & iomsg=iomsg )
    if ( iostat /= 0 ) then
      write ( error_unit, '(3a,i0)' ) 'Error: Unable to open drawing file "', &
        & trim(drawing), '", 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 ( 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.'
    if ( dump_symbols ) call dump_symbol_table
    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

  warn = .false.
  call type_checker ( root, modular, error, warn )

  if ( dump_symbols ) call dump_symbol_table
  if ( dump_decls >= 0 ) call dump_decl

  if ( error ) then
    if ( dump_decorated ) then
      call output ( 'Decorated abstract syntax tree:', advance='yes' )
      depth = 0
      call print_subtree ( root, depth, .true. )
      call output ( 'End of decorated abstract syntax tree', advance='yes' )
    end if
    call output ( 'Type checking errors occurred. No further analysis.', advance='yes' )
    stop 'Type checking error'
  end if

  do while ( son1 /= 0 )
    call entable ( root, son1, error, warn )
    if ( toggle(gen) ) call dump_tables ( last_page )
  end do

  if ( dump_decorated ) then
    call output ( 'Decorated abstract syntax tree:', advance='yes' )
    depth = 0
    call print_subtree ( root, depth, print_decor=print_decor )
    call output ( 'End of decorated abstract syntax tree', advance='yes' )
  end if

  if ( error ) then
    if ( warn ) then
      call output ( 'Warnings occurred.', advance='yes' )
      write ( error_unit, '(a)' ) 'Warnings occurred.'
    end if
    stop 'Table generation error'
  end if

  if ( postScript ) then ! Copy the "Before" file to the drawing file
    do
      open ( newunit=b, file=before, form='formatted', iostat=iostat, &
        & iomsg=iomsg, status='old' )
      if ( scan(before,sep) /= 0 ) then
        if ( iostat /= 0 ) then
          write ( error_unit, '(3a,i0)' ) 'Error: Unable to open "Before" file "', &
            & trim(before), '", IOSTAT = ', iostat
          write ( error_unit,  '(a)') trim(iomsg)
          stop 1
        end if
        exit
      end if
      j = scan(input_file,sep,back=.true.) ! Look for a directory name
      if ( j == 0 ) then
        before = './' // before
      else
        before = input_file(1:j) // before
      end if
    end do
    do
      read ( b, '(a)', end=9 ) line
      write ( drawing_unit, '(a)' ) trim(line)
    end do
  9 continue
  end if

  do i = 1, last_page
    call generate_text ( root, modular, i, drawing_unit, postScript, warn )
  end do

  if ( warn ) then
    call output ( 'Warnings occurred.', advance='yes' )
    write ( error_unit, '(a)' ) 'Warnings occurred.'
  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: Lex.f90,v 1.5 2022/02/07 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 Print_Decor ( Where )
  ! Print the decoration of the tree node at Where
    integer, intent(in) :: Where
    integer :: D
    if ( node_id(where) == n_spec .or. node_id(where) == n_field ) then
      d = decoration(where)
      if ( d /= 0 ) then
        call output ( '=' )
        call output ( trim(value_names(d)) )
      end if
    end if
  end subroutine Print_Decor

  subroutine Switch_Usage
    print '(a)', 'Switch_Usage:'
    print '(a)', ' No switches in use yet'
    stop
  end subroutine Switch_Usage

  subroutine Usage
    call get_command_argument ( 0, line )
    print '(3a)', 'Usage: ', trim(line), ' [options] table [ listing [ drawing ] ] '
    print '(a)', ' If "listing" does not appear, use stdout.'
    print '(a)', ' If "drawing" does not appear, use the same file as for "listing".'
    print '(a)', ' Options:'
    print '(a)', '  -A => Print abstract syntax tree before type checking'
    print '(a)', '  -a => Print decorated abstract syntax tree after type checking'
    print '(a)', '  -B[ ]file => Specify Before "PostScript" starter file'
    print '(a)', '  -D => Trace declaration table actions'
    print '(a)', '  -d => Dump declaration table'
    print '(a)', '  -g[#] => Trace code generation'
    print '(a)', '  -i => List input as it is read'
    print '(a)', '  -l[ ]file => Specify listing file, must be a new file;'
    print '(a)', '               default standard output, overridden by listing'
    print '(a)', '               field if both are specified'
    print '(a)', '  -L[#] => Trace lexer at level #'
    print '(a)', '  -P => Generate PostScript output (default)'
    print '(a)', '  -p[#] => Trace parser at level #; bits of # mean'
    print '(a)', '           1 -> Show also top of stack'
    print '(a)', '           2 -> Show state at every transition'
    print '(a)', '           4 -> Show grammar and automaton when starting'
    print '(a)', '           8 -> Show work table when starting'
    print '(a)', '          16 -> Show the whole stack'
    print '(a)', '          32 -> Show tree nodes being built'
    print '(a)', '  -s => Dump symbol table'
    print '(a)', '  -S[ ]string => Add string to debugging switches, see -S? for more'
    print '(a)', '  -T => Plain text output using DECtech encoding'
    print '(a)', '  -t[#] => Trace type checking'
    print '(a)', '  -V => Print version and stop'
    print '(a)', '  -{12} => Select modular type, default 1'
    print '(a)', '  -anything else => this output'
    call get_version ( line )
    print '(a)', trim(line)
    stop
  end subroutine Usage

end program ALDgen

! $Log: $
