module PASS_1_M

  ! Take a pass at the input

  use BCD_TO_ASCII_M, only: Ascii_To_Bcd, Bcd_To_Ascii, B_RECMRK
  use ERROR_M, only: BadStatement, DO_ERROR, ErrCode, ERROR, LabelErr, &
    & NoBXLErr, NoErr, N_ERRORS, OpErr
  use INPUT_M, only: INUNIT, LINE_NO
  use IO_UNITS, only: FMT_S, FMT_S2, INFO, U_SCRATCH, U_SCR2
  use LEXER, only: LEX, T_COMMA, T_DONE, T_MINUS, T_NAME, T_NUMBER, &
    & T_OTHER, T_PLUS, T_STAR
  use LITERALS_M, only: CREATE_LIT, INIT_LIT_TABLE, L_CHAR_LIT, NUM_LITS, &
    & PROCESS_LTORG
  use MACHINE, only: IO_ERROR
  use OPERAND_M, only: K_ACTUAL, K_ADCON_LIT, K_ADDR_CON, &
    & K_ASTERISK, K_BLANK_CON, K_CHAR_LIT, K_DA_OPT, K_DEVICE, K_NONE, &
    & K_NUM_LIT, K_OTHER, K_SYMBOLIC, NUM_OPERANDS, OPERAND, OPERANDS, X00
  use OP_CODES_M, only: OP_CODES, OPT, PRO, REQ, SENTNL
  use PARSER, only: ADJUST, PARSE, SFX
  use SYMTAB_M, only: ENTER, INIT_SYM_TABLE, LC_MAX, LC_MAX_T, LC_TAB, REF, &
    & SYMBOLS

  implicit NONE
  private

  public :: PASS_1

contains

  subroutine PASS_1 ( IOSTAT, NeedPass2, Rel )
    integer, intent(out) :: IOSTAT ! Used to decide whether return was
                                   ! because of END or I/O problem
    logical, intent(out) :: NeedPass2   ! There are undefined EQU's or ORG's
    logical, intent(out) :: Rel    ! Relocatable stuff appeared

    logical :: ADD_WIDTH      ! Add WIDTH to P -- except after END, EX, LTORG
    integer :: ADDR           ! From symbol table
    logical :: CLEAR          ! C appeared in a DA
    logical :: CoreMsg        ! Need "Core Storage Exceeded" message
    character :: D            ! D-modifier
    logical :: Direct         ! Machine op and D in CC 19:20
    logical :: DUP            ! "Label is a duplicate"
    integer :: END            ! End position of a token
    integer :: FIELD          ! Field numbers after DA
    character(len=1023) :: FILE ! File name for error messages
    logical :: GOT_D          ! "Got a d-field"
    logical :: GroupMark      ! in a DA
    integer :: I
    integer :: INDEX          ! in a DA, 0..3, or from symbol table
    integer :: IXLAB          ! Symbol table index for a label, or negative
                              ! of address in label field of DC or DCW
    character(6) :: Label
    integer :: LabelToken
    integer :: LC             ! Current location counter
    character(len=80) :: LINE
    character :: MachineOp    ! Machine op code, or ' ' for pseudo-op
    integer :: NRECS          ! Number of records in a DA
    character(len=5) :: Op_Field  ! CC 16-20
    integer :: OP_IX = 0      ! Index in op code table
    integer :: P              ! Program counter
    integer :: P_Tab(0:LC_max) ! P in each location counter
    integer :: POS            ! Position in OPERAND field (1-origin)
    integer :: PrevOp         ! Index in op_codes of previous machine op
    character(5) :: PrevOpText     ! line(16:20) of previous line, for CHAIN
    integer :: P_DA           ! P, for the last DA
    integer :: P_Max          ! Largest P used, for ORG with no operand
    integer :: P_Scratch      ! to write on U_Scratch
    logical :: RecMark        ! in a DA
    integer :: RECSIZ         ! in a DA
    character :: RMARK
    integer :: SaveToken
    integer :: Status         ! From Parse
    integer :: TOKEN
    integer :: WIDTH          ! Width of operand, typically 3 but may be
                              ! length of character literal for DC or DCW
    character(5) :: WHY       ! Why is the record on the scratch file, or
                              ! why is the line in the listing (pass 3)?
                              ! ADCON - an address-constant literal
                              ! AREA  - an error-defining literal
                              ! ERROR - error message
                              ! FIELD - field after DA
                              ! GMARK - group mark after a DA
                              ! GEN   - generated by a macro, or a LTORG
                              !         generated by EX or END
                              ! LIT   - a literal
                              ! RMARK - record mark after each DA record
                              ! SBFLD - subfield after a DA
                              ! WARN  - a warning message

    call init_lit_table
    call init_sym_table

    coreMsg = .false.
    lc = 0
    line_no = 0
    needPass2 = .false.
    n_errors = 0
    p = 333                   ! Default, changed by ORG
    p_tab = 0
    prevOp = 0
    prevOpText = ''
    p_max = 0
    rel = .false.             ! Assume no relocatable stuff
    rmark = bcd_to_ascii(B_RECMRK)

! Write a temporary field header on the scratch file
! This causes pass 3 to fail, so don't keep it!
!    write ( u_scratch, '(a)' ) info

    do
      add_width = .true.
      errCode = ' '
      error = .false.
      direct = .false.
      got_d = .false.
      ixlab = 0
      line_no = line_no + 1
      why = ' '
      width = 0

      read ( u_scr2, fmt_s2, iostat=iostat ) why, errCode, line
      if ( iostat < 0 ) then  ! End of file
        if ( line_no == 1 ) then
          iostat = 1 ! Fake an error, to make main line stop
          exit
        end if
        call process_ltorg ( p, lc, .true., 'Pass 1' )
        exit
      else if ( iostat > 0 ) then  ! Error
        inquire ( unit=inunit, name=file )
        call io_error ( "While reading input", inunit, file )
        stop
      end if

      ! Check for junk in 73-75, which would confuse "Real Autocoder"
      if ( line(6:6) /= "*" .and. line(73:75) /= "" ) &
        & call do_error ( 'Non-blank in 73-75 would confuse "Real Autocoder"', &
          & warning=.true. )
      ! Make sure first line is JOB
!     if ( line_no == 1 .and. line(16:20) /= 'JOB' ) &
!       & call do_error ( 'First card is not a JOB card' )

      if ( line(6:6) == '*' &    ! Comment line
        & .or. why == 'MACRO' ) then
        !                        ! Why, Line, ixLab, P, LC, Width, ErrCode, Num_Operands
        write ( u_scratch, fmt_s ) why, line, 0,     0, 0,  0,     errCode,   0
        cycle
      end if

      if ( why == 'LITS ' ) then
          !                               ixlab  P  LC, Width ErrCode Num_Operands
        write ( u_scratch, fmt_s ) why, line, 0, 0, 0,  0,       ' ',  0
        call process_ltorg ( p, lc, .true., 'Pass 1' )
        cycle
      end if

      ! Process the label
      pos = 6
      ! This is what 1401-AU-037 does:
      if ( scan(line(7:11),')') /= 0 ) line(6:11) = ')LABEL'
      call lex ( line(:11), pos, end, labelToken )
      if ( labelToken /= t_name .and. labelToken /= t_number .and. &
        &  labelToken /= t_done ) then
        call do_error ( 'Invalid label' )
        errCode = labelErr
      end if
      if ( line(end+1:15) /= ' ' ) then
        if ( line(12:12) /= '*' ) then
          call do_error ( 'Junk after the label, or in CC 12-15', warning=.true. )
          errCode = labelErr
        end if
      end if

      p_scratch = p

      ! Process the op code
      machineOp = ' '
      if ( line(16:18) == '' ) then
        if (line(19:20) /= ' ' ) op_ix = 0
      else
        do op_ix = 1, ubound(op_codes,1)-1
          if ( op_codes(op_ix)%op == sentnl ) then ! end of table
            call do_error ( 'Unrecognized op code' )
            errCode = opErr
            why = 'ERR'
            go to 999
          end if
          if ( line(16:20) == op_codes(op_ix)%op ) then
            machineOp = op_codes(op_ix)%machineOp
            exit
          end if
        end do
      end if

      num_operands = 0
      pos = 21                     ! Position in analysis of operand
      op_field = line(16:20)
      if ( (machineOp == ' ' .or. machineOp == 'p') .and. op_ix /= 0 ) then ! A pseudo-op
        if ( op_field == '' ) then
          if ( prevOp <= 0 .and. prevOp >= ubound(op_codes,1) ) then
            call do_error ( 'Previous OP code not pseudo op' )
            errCode = opErr
          else if ( op_codes(prevOp)%machineOp == 'p' ) then
            op_field = op_codes(prevOp)%op
          else if ( op_codes(prevOp)%op /= 'DA' ) then
            call do_error ( 'Previous OP code not pseudo op' )
            errCode = opErr
          end if
        end if
        select case ( op_field )
        case ( '' )
          if ( op_codes(prevOp)%op /= 'DA' ) then
            call do_error ( 'Previous OP code not DA' )
            errCode = opErr
          else
            call parse ( line, pos, status, .true., lc )
            error = status < 0 .or. status > 1
            if ( .not. error ) then
              error = operands(1)%kind /= k_actual
              if ( .not. error ) then
                field = operands(1)%addr + p_da - 1
                why = 'SBFLD'
                if ( status == 0 ) then
                  call parse ( line, pos, status, .true., lc )
                  error = status /= 1
                  if ( .not. error ) then
                    error = operands(1)%kind /= k_actual
                    if ( .not. error ) then
                      field = operands(2)%addr + p_da - 1
                      why = 'FIELD'
                    end if
                  end if
                end if
                if ( labelToken == t_name .and. .not. error ) then
                  label = line(6:11)
                  if ( label(6:6) == '' ) label(6:6) = sfx
                  call enter ( label, field, lc, index, ixlab, dup )
                  if ( dup ) then
                    call do_error ( 'Label ' // trim(line(6:11)) // &
                      & ' is a duplicate' )
                    errCode = labelErr
                  end if
                end if
                p_scratch = field
              end if
            end if
          end if
        case ( 'ALTER' )
          call do_error ( 'ALTER not handled -- use an editor' )
        case ( 'CALL' )
          ! Processed in Macro_Pass
        case ( 'CHAIN' )
          why = 'MACRO'
          call lex ( line, pos, end, token )
          if ( token /= t_number ) then
            call do_error ( 'Operand of CHAIN is not a number' )
            errCode = badStatement
          else
            read ( line(pos:end), * ) width
          end if
          if ( prevOp <= 0 .and. prevOp >= ubound(op_codes,1) ) then
            call do_error ( 'Previous OP code not a machine OP' )
          else if ( op_codes(prevOp)%machineOp == ' ' .or. &
                    op_codes(prevOp)%machineOp == 'p' ) then
            call do_error ( 'Previous OP code not a machine OP' )
          else if ( width == 0 ) then
            call do_error ( 'CHAIN amount is zero' )
            errCode = opErr
          end if
            !                                          P  LC Width ErrCode Num_Operands
          write ( u_scratch, fmt_s ) why, line, ixLab, 0, 0, 0,   errCode,  0
          if ( errCode == noErr ) then
            ixLab = 0
            line = ''
            line(16:) = prevOpText
            why = 'GEN'
            do i = 1, width-1
              write ( u_scratch, fmt_s ) why, line, ixLab, p_scratch, lc, 1, NoErr, 0
              p_scratch = p_scratch + 1
            end do
            p = p_scratch
            width = 1
          end if
        case ( 'CTL' )
          ! Ignored -- control is by command line options
        case ( 'DA' )
          clear = .false.
          groupMark = .false.
          index = 0
          num_operands = 3
          operands(1) = operand(1,k_actual,0,'  ',' ','      ')
          operands(2) = operand(1,k_actual,0,'  ',' ','      ')
          operands(3) = operand(0,k_da_opt,0,'  ',' ','      ')
          p_da = p
          if ( labelToken == t_number ) then
            read ( line(6:11), * ) p_scratch
            p_da = p_scratch
          end if
          recMark = .false.
          call lex ( line, pos, end, token, nosign=.true. )
          error = token /= t_number
          if ( error ) then
            errCode = noBXLerr
          else
            read ( line(pos:end), * ) nrecs
            error = line(end+1:end+1) /= 'X'
            if ( error ) then
              errCode = noBXLerr
            else
              pos = end + 2
              call lex ( line, pos, end, token )
              error = token /= t_number
              if ( error ) then
                errCode = noBXLerr
              else
                read ( line(pos:end), * ) recsiz
                width = nrecs * recsiz
                operands(1) = operand(nrecs,k_actual,0,'  ',' ','      ')
                operands(2) = operand(recsiz,k_actual,0,'  ',' ','      ')
                do
                  pos = end + 1
                  call lex ( line, pos, end, token )
                  if ( token == t_done ) exit
                  error = token /= t_comma
                  if ( error ) exit
                  pos = end + 1
                  call lex ( line, pos, end, token )
                  select case ( token )
                  case ( t_other )
                    if ( ascii_to_bcd(iachar(line(pos:end))) == B_RECMRK ) then
                      error = recMark
                      if ( error ) exit
                      recMark = .true.
                      operands(3)%label(3:3) = rmark
                    end if
                  case ( t_name )
                    select case ( line(pos:end) )
                    case ( 'C' )
                      error = clear
                      if ( error ) exit
                      clear = .true.
                      operands(3)%label(1:1) = 'C'
                    case ( 'G' )
                      error = groupMark
                      if ( error ) exit
                      groupMark = .true.
                      operands(3)%label(2:2) = 'G'
                    case ( 'X0', 'X1', 'X2', 'X3' )
                      index = ichar(line(end:end)) - ichar('0')
                      operands(3)%index = line(end:end)
                    case default
                      error = .true.
                      exit
                    end select
                  case default
                    error = .true.
                    exit
                  end select
                end do
                if ( recMark ) width = width + nrecs
                if ( groupMark ) width = width + 1
              end if
            end if
          end if
          if ( errCode == noBXLerr ) then
            nrecs = 1
            recsiz = 1
          end if
          if ( .not. error ) then
            if ( labelToken == t_name ) then
              label = line(6:11)
              if ( label(6:6) == '' ) label(6:6) = sfx
              call enter ( label, p, lc, index, ixlab, dup )
              if ( dup ) then
                call do_error ( 'Label ' // trim(line(6:11)) // &
                  & ' is a duplicate' )
                errCode = LabelErr
              end if
            else if ( labelToken == t_number ) then
              ixlab = -p_da
            end if
          end if
        case ( 'DC', 'DCW' )
          num_operands = 0
          call parse ( line, pos, status, .true., no_lit=.true. )
          if ( pos > 74 ) then
            errCode = badStatement
            width = 0
          else if ( line(pos-1:pos) /= '' ) then
            errCode = badStatement
            width = 0
          else
            call dcw ( operands(1) )
            if ( labelToken == t_name ) then
              label = line(6:11)
              if ( label(6:6) == '' ) label(6:6) = sfx
              call enter ( label, p + width - 1, lc, 0, ixlab, dup )
              if ( dup ) then
                call do_error ( 'Label ' // trim(line(6:11)) // &
                  & ' is a duplicate' )
                errCode = labelErr
              end if
            else if ( labelToken == t_number ) then
              if ( lc_tab(lc) < 0 ) then
                call do_error ( &
                  & "Absolute DC/DCW not allowed in relocatable location counter." )
              end if
              read ( line(6:11), * ) p_scratch
              ixLab = -(p_scratch - width + 1)
              p = p - width ! because we do p = p + width at the end
            end if
          end if
        case ( 'DELET', 'INSER', 'PRINT', 'PUNCH' )
          ! call do_error ( line(16:20) // ' not handled -- use an editor' )
          ! Ignored
        case ( 'DS' )
          call lex ( line, pos, end, token )
          if ( token /= t_number ) then
            call do_error ( 'Operand of DS must be a number' )
          else
            read ( line(pos:end), * ) width
            pos = end + 1
            call lex ( line, pos, end, token )
            if ( token /= t_done ) &
              & call do_error ( 'Junk after the number in a DS' )
            if ( .not. error .and. labelToken == t_name ) then
              label = line(6:11)
              if ( label(6:6) == '' ) label(6:6) = sfx
              call enter ( label, p + width - 1, lc, 0, ixlab, dup )
              add_width = .true.
              if ( dup ) then
                call do_error ( 'Label ' // trim(line(6:11)) // &
                  & ' is a duplicate' )
                errCode = labelErr
              end if
            end if
          end if
        case ( 'DSA' )
          p_scratch = p
          if ( labelToken == t_number ) read ( line(6:11), * ) p_scratch
          num_operands = 1
          width = 3
          operands(1) = operand(0,k_actual,0,'  ',' ','      ')
          call lex ( line, pos, end, token )
          select case ( token )
          case ( t_minus, t_plus )
            saveToken = token
            pos = end + 1
            call lex ( line, pos, end, token )
            if ( token == t_number ) then
              read ( line(pos:end), * ) operands(1)%addr
              if ( saveToken == t_minus ) &
                & operands(1)%addr = 16000 - operands(1)%addr
            else if ( token == t_name ) then
              error = saveToken == t_minus
              if ( error ) errCode = badStatement
              operands(1)%kind = k_symbolic
              operands(1)%label = line(pos:end)
              if ( operands(1)%label(6:6) == '' ) operands(1)%label(6:6) = sfx
              call enter ( operands(1)%label, ref, 0, 0, operands(1)%addr )
            else
              call do_error ( 'Improper operand for DSA' )
            end if
          case ( t_name )
            operands(1)%kind = k_symbolic
            operands(1)%label = line(pos:end)
            if ( operands(1)%label(6:6) == '' ) operands(1)%label(6:6) = sfx
            call enter ( operands(1)%label, ref, 0, 0, operands(1)%addr )
          case ( t_number )
            read ( line(pos:end), * ) operands(1)%addr
          case ( t_star )
            operands(1)%kind = k_asterisk
            operands(1)%addr = p + 2
          case default
            call do_error ( 'Improper operand for DSA' )
          end select
          pos = end + 1
          if ( .not. error ) then
            call lex ( line, pos, end, token )
            select case ( token )
            case ( t_done )
            case ( t_minus, t_plus )
              status = 0
              call adjust ( line, pos, end, token, 1, status )
              error = status /= 0
              if ( .not. error .and. token /= t_done ) then
                pos = end + 1
                call lex ( line, pos, end, token )
                error = token /= t_done
                if ( error ) call do_error ( 'Junk after the operand for DSA' )
              end if
            case default
              call do_error ( 'Junk after operand for DSA' )
            end select
          end if
          if ( labelToken == t_name ) then
            label = line(6:11)
            if ( label(6:6) == '' ) label(6:6) = sfx
            call enter ( label, p + 2, lc, 0, ixlab, dup )
            if ( dup ) call do_error ( 'Label ' // trim(line(6:11)) // &
              & ' is a duplicate' )
          else if ( labelToken == t_number ) then
              if ( lc_tab(lc) < 0 ) then
                call do_error ( &
                  & "Absolute DSA not allowed in relocatable location counter." )
              end if
            read ( line(6:11), * ) p_scratch
            ixLab = -(p_scratch -width + 1)
            p = p - width ! because we do p = p + width at the end
          end if
        case ( 'END' )
          call end_or_ex
!          call process_ltorg ( p, lc, .true., 'Pass 1' )
          write ( u_scratch, fmt_s ) why, line, ixLab, p_scratch, lc, num_lits, &
            & errCode, num_operands, operands(1:num_operands)
          exit
        case ( 'ENT' )
          call do_error ( 'Can''t change coding mode' )
        case ( 'EQU' )
          p_scratch = p
          error = line(6:11) /= '' .and. labelToken /= t_name
          call parse ( line, pos, status, .true., lc )
          error = error .or. status /= 1
          if ( .not. error ) then
            read ( operands(1)%index, '(i1)' ) index
            label = line(6:11)
            if ( label(6:6) == '' ) label(6:6) = sfx
            select case ( operands(1)%kind )
            case ( k_actual, k_asterisk )
              if ( operands(1)%kind == k_asterisk ) operands(1)%addr = p - 1
              call enter ( label, operands(1)%addr+operands(1)%offset, lc, &
                & index, ixlab, dup )
              if ( dup ) then
                call do_error ( 'Label ' // trim(line(6:11)) // &
                  & ' is a duplicate' )
                errCode = labelErr
              end if
              width = 0
            case ( k_device )
              call enter ( label, 0, 0, 0, ixlab, dev=operands(1)%label )
            case ( k_symbolic )
              if ( operands(1)%label(6:6) == '' ) operands(1)%label(6:6) = sfx
              call enter ( operands(1)%label, ref, 0, 0, operands(1)%addr )
              if ( symbols(operands(1)%addr)%value > ref ) then
                if ( operands(1)%index == ' ' ) &
                  & index = symbols(operands(1)%addr)%index
                call enter ( label, &
                  & symbols(operands(1)%addr)%value+operands(1)%offset, &
                  & symbols(operands(1)%addr)%lc, index, ixlab, dup )
                if ( dup ) then
                  call do_error ( 'Label ' // trim(line(6:11)) // &
                    & ' is a duplicate' )
                  errCode = labelErr
                end if
              else
                needPass2 = .true.
                call enter ( label, ref, 0, 0, ixlab, dup )
                if ( dup ) then
                  call do_error ( 'Label ' // trim(line(6:11)) // &
                    & ' is a duplicate' )
                  errCode = labelErr
                end if
              end if
              width = 0
            case default
              error = .true.
            end select
          end if
        case ( 'EX' )
          call end_or_ex
          add_width = .false.
          width = num_lits
!          call process_ltorg ( p, lc .true., 'Pass 1' )
        case ( 'INCLD' )
          ! Processed in Macro_Pass
        case ( 'JOB' )
          ! Ignored until pass 2
        case ( 'LC' ) ! Set current location counter
          call parse ( line, pos, status, .true., lc )
          if ( operands(1)%kind /= k_actual ) then
            call do_error ( 'First operand of LC is not a number' )
          else
            p_tab(lc) = p
            lc = operands(1)%addr
            if ( lc > LC_max ) then
              call do_error ( 'Location counter number > ' // LC_max_t // &
                & ', set to ' // LC_max_t )
              lc = LC_max
            end if
            p = p_tab(lc)
            p_scratch = p
          end if
          if ( status == 0 ) then ! Look for R
            call parse ( line, pos, status, .false., lc )
            if ( operands(2)%kind /= k_symbolic .or. &
              &  ( operands(2)%label /= 'R' .and. &
              &    operands(2)%label /= 'X') ) then
              call do_error ( 'Second operand of LC is not R or X' )
            else
              if ( lc_tab(lc) > 0 ) then
                call do_error ( 'Cannot change location counter from absolute to relocatable' )
              else
                lc_tab(lc) = -1
                rel = .true.
              end if
            end if
            if ( status == 0 ) then ! Look for X00 if R
              call parse ( line, pos, status, .false., lc )
              if ( ( operands(3)%kind /= k_symbolic .or. &
                &    operands(3)%label /= 'X00' ) .and. &
                &  operands(2)%label == 'R' ) then
                call do_error ( 'Third operand of LC R is not X00' )
              end if
              if ( p_tab(lc) > 0 ) call do_error ( &
                & 'Cannot change origin of established location counter' )
            else if ( operands(2)%label == 'X' ) then
              call do_error ( '"LC   X" must specify a label for the origin' )
            end if            
          else
            if ( lc_tab(lc) < 0 ) then
              call do_error ( 'Cannot change location counter from relocatable to absolute ' )
            else
              lc_tab(lc) = 1
            end if
          end if
        case ( 'LTORG', 'ORG' )
          if ( labelToken == t_name ) then
            label = line(6:11)
            if ( label(6:6) == '' ) label(6:6) = sfx
            call enter ( label, p, lc, 0, ixlab, dup )
            if ( dup ) then
              call do_error ( 'Label ' // trim(line(6:11)) // &
                & ' is a duplicate' )
              errCode = labelErr
            end if
          end if
          call parse ( line, pos, status, .true., lc, org=.true. )
          if ( operands(1)%index /= ' ' ) &
            & call do_error ( 'Indexing not permitted' )
          if ( line(21:22) == ' ' ) then
            operands(1)%kind = k_actual
            operands(1)%addr = p_max
          end if
          select case ( operands(1)%kind )
          case ( k_actual )
            p = operands(1)%addr
            if ( lc_tab(lc) < 0 ) call do_error ( &
              & 'Absolute ORG not allowed in relocatable location counter' )
          case ( k_asterisk )
          case ( k_symbolic )
            if ( operands(1)%label(6:6) == '' ) operands(1)%label(6:6) = sfx
            call enter ( operands(1)%label, ref, 0, 0, operands(1)%addr )
            addr = symbols(operands(1)%addr)%value
            if ( addr <= ref ) then
              needPass2 = .true.
              p = 2*ref
            else
              p = addr
            end if
            if ( lc_tab(lc) < 0 ) then
              if ( symbols(operands(1)%addr)%lc /= lc ) call do_error ( &
                & 'Symbolic origin in different relocatable location counter not allowed' )
            else
              if ( lc_tab(symbols(operands(1)%addr)%lc) < 0 ) call do_error ( &
                & 'Symbolic origin in relocatable location counter not allowed in absolute location counter' )
            end if
          case default
            call do_error ( 'Improper operand form' )
          end select
          if ( operands(1)%offset >= x00 ) then
            p = p + 99
            p = p - mod(p,100) + operands(1)%offset - x00
          else
            p = p + operands(1)%offset
          end if
          width = 0
          add_width = .false.
          if ( line(16:20) == 'LTORG' ) then
            width = num_lits
          end if
        case ( 'SFX' )
          sfx = line(21:21)
        case ( 'XFR' )
          call end_or_ex
          width = 0
        end select
      else                         ! An instruction
        if ( .not. error .and. labelToken == t_name ) then ! No error so far
          label = line(6:11)
          if ( label(6:6) == '' ) label(6:6) = sfx
          call enter ( label, p, lc, 0, ixlab, dup )
          if ( dup ) then
            call do_error ( 'Label ' // trim(line(6:11)) // &
              & ' is a duplicate' )
            errCode = labelErr
          end if
        end if
        width = 1
        do i = 1, size(operands)
          call parse ( line, pos, status, .false., lc ) ! might be a D modifier
          if ( status /= 0 ) exit
        end do
        if ( op_ix == 0 ) then
          direct = .true.
          machineOp = line(19:19)
          d = line(20:20)
          got_d = d /= ''
        else
          machineOp = op_codes(op_ix)%machineOp
          d = op_codes(op_ix)%d
          got_d = d /= opt .and. d /= pro .and. d /= req
        end if

        ! Analyze A or D field, or B field if A field is completely
        ! defined in the op_codes table
        if ( num_operands == 0 ) then
          if ( op_codes(op_ix)%a == req ) &
            & call do_error ( 'A field required' )
          if ( op_codes(op_ix)%a /= opt .and. &
            &  op_codes(op_ix)%d == req .and. .not. direct ) &
            & call do_error ( 'D field required' )
        else                                       ! A or D
          if ( op_codes(op_ix)%a == pro ) then ! A prohibited
            if ( num_operands > 1 ) then
              call do_error ( 'A field not allowed' )
            else if ( op_codes(op_ix)%d == opt .or. &
              &  op_codes(op_ix)%d == req ) then
                call analyze_d ( 1 )
            else if ( operands(1)%kind /= k_other ) then
              call do_error ( 'A field not allowed' )
            else
              num_operands = 0
              go to 998
            end if
          else if ( operands(1)%kind == k_other ) then
            if ( operands(2)%d == '@' ) call do_error ( 'Bad A field' )
            num_operands = 0
            go to 998
          else if ( op_codes(op_ix)%a(2:2) /= "" ) then
            ! A field defined completely by op_codes.  First operand is
            ! B field.
            if ( num_operands > 1 ) &
              & call do_error ( "Only one field allowed" )
            operands(2) = operands(1)
            operands(1) = operand(1,k_device,0,'  ',' ','%'//op_codes(op_ix)%a)
            num_operands = 2
            width = 7 ! Got D from op_codes table
            go to 998
          else
            width = width + 3
            if ( operands(1)%kind == k_symbolic .or. &
              & operands(1)%kind == k_addr_con ) then
                if ( operands(1)%label(6:6) == '' ) &
                  operands(1)%label(6:6) = sfx
            end if
            if ( operands(1)%kind == k_symbolic ) &
              & call enter ( operands(1)%label, ref, 0, 0, operands(1)%addr )
          end if

          ! Analyze B or D field
          if ( num_operands == 1 ) then
            if ( op_codes(op_ix)%b == req ) &
              & call do_error ( 'B field required' )
            if ( op_codes(op_ix)%d == req .and. .not. direct .and. .not. got_d ) &
              & call do_error ( 'D field required' )
          else                                    ! B or D
            if ( op_codes(op_ix)%b == pro ) then  ! B prohibited
              if ( op_codes(op_ix)%d == opt .or. &
                &  op_codes(op_ix)%d == req ) then
                call analyze_d ( 2 )
              else
                call do_error ( 'B field not allowed' )
              end if
            else
              if ( machineOp == 'B' .and. .not. got_d .and. &
                & line(16:18) /= '' .and. num_operands == 2 ) then
                call analyze_d ( 2 )
              else if ( operands(2)%kind == k_other ) then
                call do_error ( 'Bad B field' )
              else
                width = width + 3
                if ( operands(2)%kind == k_symbolic .or. &
                  & operands(2)%kind == k_addr_con ) then
                  if ( operands(2)%label(6:6) == '' ) &
                    operands(2)%label(6:6) = sfx
                end if
                if ( operands(2)%kind == k_symbolic ) &
                  & call enter ( operands(2)%label, ref, 0, 0, operands(2)%addr )
              end if
            end if

            ! Analyze D field
            if ( num_operands == 2 ) then
              if ( op_codes(op_ix)%d == req .and. .not. direct .and. .not. got_d ) &
                & call do_error ( 'D field required' )
            else                                  ! D
              if ( op_codes(op_ix)%d == pro .or. got_d ) then
                call do_error ( 'D field not allowed' )
              else
                call analyze_d ( 3 )
              end if
              if ( status == 0 ) call do_error ( 'Too many operands' )
            end if
          end if
        end if
998     if ( direct .and. d /= ' ' ) then
          num_operands = num_operands + 1
          operands(num_operands) = &
            & operand ( 0, k_symbolic, 0, d//' ', ' ', '      ' )
          got_d = .true.
        end if
        if ( got_d ) width = width + 1
      end if
      prevOp = op_ix
      prevOpText = op_field
      if ( error .and. errCode == noErr ) errCode = badStatement
999   write ( u_scratch, fmt_s ) why, line, ixLab, p_scratch, lc, width, &
        & errCode, num_operands, operands(1:num_operands)
      if ( add_width ) p = p + width
      p_max = max(p_max, p_scratch + width)
      if ( p_scratch+width > 15999 .or. p > 15999 ) coreMsg = .true.
!      if ( line(16:20) == 'LTORG' ) call process_ltorg ( p, lc, .true., 'Pass 1' )

    end do

    if ( coreMsg ) call do_error ( 'CORE STORAGE EXCEEDED' )
    end file ( u_scratch )
    rewind ( u_scratch )

  contains

    ! ------------------------------------------------  ANALYZE_D  -----
    subroutine ANALYZE_D ( N )
      ! Analyze a D modifier in the N'th element of Operands
      integer, intent(in) :: N
      if ( operands(n)%d(2:2) /= ' ' ) then
        call do_error ( 'D modifier must be a single character' )
      else
        d = operands(n)%d
        got_d = .true.
      end if
    end subroutine ANALYZE_D

    ! ------------------------------------------------------  DCW  -----
    subroutine DCW ( The_Operand )
      type(operand), intent(inout) :: The_Operand
      select case ( the_operand%kind )
      case ( k_actual, k_adcon_lit, k_addr_con, k_asterisk, k_blank_con, &
        & k_char_lit, k_num_lit, k_symbolic )
        width = the_operand%addr
        if ( the_operand%kind == k_symbolic ) the_operand%kind = k_addr_con
        if ( the_operand%kind == k_addr_con ) then
          call enter ( the_operand%label, ref, 0, 0, the_operand%addr )
          width = 3
        else if ( the_operand%kind == k_adcon_lit ) then
          call create_lit ( l_char_lit, width, line(pos-width-2:pos-3), lc, &
            & the_operand%addr )
          width = 3
        else if ( the_operand%kind == k_asterisk ) then
          width = 3
          the_operand%addr = p + 2
        else
          the_operand%addr = 0
        end if
        if ( width > 52 ) then
          call do_error ( 'DCW specifies area of more than 52 characters' )
          errCode = BadStatement
          the_operand%addr = 52
          width = 52
        end if
      case ( k_device )
          width = 3
      case default
        call do_error ( 'Improper operand for ' // trim(line(16:18)) )
      end select
    end subroutine DCW

    ! ------------------------------------------------  END_OR_EX  -----
    subroutine END_OR_EX
      ! Process the operand of END or EX -- name or number
      do i = 1, size(operands)
        call parse ( line, pos, status, .true., lc, .true. )
        if ( status /= 0 ) exit
      end do
      if ( num_operands == 0 ) then
        operands(1) = operand(0,k_actual,0,'  ',' ','      ')
      else if ( num_operands > 1 ) then
        call do_error ( 'Too many operands for ' // trim(line(16:18)) )
      else if ( operands(1)%index /= '' ) then
        call do_error ( 'Improper operand for ' // trim(line(16:18)) )
      end if
      operands(1)%d = ''
    end subroutine END_OR_EX

  end subroutine PASS_1

end module PASS_1_M
