module PASS_1_M ! Take a pass at the input use BCD_TO_ASCII_M, only: Ascii_To_Bcd, Bcd_To_Ascii, RecordMark use ERROR_M, only: AddrErr, BadStatement, DO_ERROR, ErrCode, ERROR, LabelErr, & & MacroErr, NoBXLErr, NoErr, N_ERRORS, OpErr, Overcall, SymErr, UndefOrg use INPUT_M, only: INUNIT, LINE_NO, READ_LINE use IO_UNITS, only: INPUT, U_SCRATCH 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_ADCON_LIT, L_CHAR_LIT, & & LITERALS, NUM_LITS, PROCESS_LTORG use MACHINE, only: IO_ERROR use OPERAND_M, only: K_ACTUAL, K_ADCON_LIT, K_ADDR_CON, K_AREA_DEF, & & K_ASTERISK, K_BLANK_CON, K_CHAR_LIT, K_DA_OPT, K_DEVICE, K_NUM_LIT, & & K_OTHER, K_SYMBOLIC, NUM_OPERANDS, OPERAND, OPERANDS, X00 use OP_CODES_M, only: OP_CODES, OPT, PRO, REQ use PARSER, only: ADJUST, PARSE, SFX use SYMTAB_M, only: ENTER, INIT_SYM_TABLE, REF, SYMBOLS implicit NONE private public :: PASS_1 contains subroutine PASS_1 ( IOSTAT, NeedPass2 ) 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 :: 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 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 character(len=80) :: LINE character :: MachineOp ! Machine op code, or ' ' for pseudo-op logical :: NEED_LTORG ! Lits need to be processed integer :: NRECS ! Number of records in a DA integer :: OP_IX = 0 ! Index in op code table integer :: P ! Program 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 :: 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. line_no = 0 needPass2 = .false. n_errors = 0 p = 333 ! Default, changed by ORG prevOp = 0 prevOpText = '' p_max = 0 rmark = bcd_to_ascii(recordMark) do add_width = .true. errCode = ' ' error = .false. direct = .false. got_d = .false. ixlab = 0 line_no = line_no + 1 need_ltorg = .false. width = 0 call read_line ( line, iostat ) if ( iostat < 0 ) exit ! End of file if ( iostat > 0 ) then ! Error call io_error ( "While reading input", inunit, input ) stop end if ! 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) == '*' ) then ! Comment line ! ! Why, Line, ixLab, P, Width, ErrCode, Num_Operands write ( u_scratch, 200 ) ' ', line, 0, 0, 0, NoErr, 0 cycle end if ! Process the label pos = 6 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 call do_error ( 'Junk after the label, or in CC 12-15', warning=.true. ) errCode = labelErr end if p_scratch = p why = ' ' ! 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 ( line(16:20) == op_codes(op_ix)%op ) then machineOp = op_codes(op_ix)%machineOp exit end if end do if ( op_ix >= ubound(op_codes,1) ) then call do_error ( 'Unrecognized op code' ) errCode = opErr cycle end if end if num_operands = 0 pos = 21 ! Position in analysis of operand if ( machineOp == ' ' .and. op_ix /= 0 ) then ! A pseudo-op select case ( line(16:20) ) case ( '' ) if ( prevOp <= 0 .and. prevOp >= ubound(op_codes,1) ) then call do_error ( 'Previous OP code not DA' ) errCode = opErr else if ( op_codes(prevOp)%op /= 'DA' ) then call do_error ( 'Previous OP code not DA' ) errCode = opErr else call parse ( line, pos, status, .true. ) 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. ) 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 = trim(line(6:11)) // sfx call enter ( label, field, 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 ( 'CHAIN' ) why = 'MACRO' call lex ( line, pos, end, token ) if ( token /= t_number ) then call do_error ( 'Operand of CHAIN is not a number' ) 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 == ' ' ) 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 Width, ErrCode, NumOperands write ( u_scratch, 200 ) why, line, ixLab, 0, 0, errCode, 0 if ( errCode == noErr ) then ixLab = 0 line = '' line(16:) = prevOpText why = 'GEN' do i = 1, width-1 write ( u_scratch, 200 ) why, line, ixLab, p_scratch, 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 ) 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))) == recordMark ) 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 = trim(line(6:11)) // sfx call enter ( label, p, 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 if ( labelToken == t_number ) read ( line(6:11), * ) p_scratch call parse ( line, pos, status, .true., .true. ) select case ( operands(1)%kind ) case ( k_actual, k_adcon_lit, k_addr_con, k_blank_con, k_char_lit, & & k_num_lit, k_symbolic ) width = operands(1)%addr if ( operands(1)%kind == k_symbolic ) operands(1)%kind = k_addr_con if ( operands(1)%kind == k_addr_con ) then call enter ( operands(1)%label , ref, 0, operands(1)%addr ) width = 3 else if ( operands(1)%kind == k_adcon_lit ) then call create_lit ( l_char_lit, width, line(pos-width-1:pos-2), & & operands(1)%addr ) width = 3 else operands(1)%addr = 0 end if case default call do_error ( 'Improper operand for ' // trim(line(16:18)) ) end select if ( labelToken == t_name ) then label = trim(line(6:11)) // sfx call enter ( label, p + width - 1, 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 ixLab = -(p_scratch -width + 1) p = p - width ! because we do p = p + width at the end end if case ( 'DELET', 'INSER', 'PRINT', 'PUNCH' ) call do_error ( line(16:20) // ' not handled -- use an editor' ) 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 = trim(line(6:11)) // sfx call enter ( label, p + width - 1, 0, ixlab, dup ) 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 ) pos = end + 1 call lex ( line, pos, end, token ) if ( token == t_number ) then read ( line(pos-1:end), * ) operands(1)%addr else if ( token == t_name ) then error = line(21:21) == '-' if ( error ) errCode = badStatement operands(1)%kind = k_symbolic operands(1)%label = line(pos:end) // sfx call enter ( operands(1)%label, ref, 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 = trim(line(pos:end)) // sfx call enter ( operands(1)%label, ref, 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 ) 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 = trim(line(6:11)) // sfx call enter ( label, p + 2, 0, ixlab, dup ) if ( dup ) call do_error ( 'Label ' // trim(line(6:11)) // & & ' is a duplicate' ) else if ( labelToken == t_number ) then ixLab = -p_scratch end if case ( 'END' ) call process_ltorg ( p, .true. ) call end_or_ex write ( u_scratch, 200 ) why, line, ixLab, p_scratch, num_lits, & & errCode, num_operands, operands(:num_operands) exit case ( 'ENT' ) call do_error ( 'Can''t change coding mode' ) case ( 'EQU' ) p_scratch = 0 error = line(6:11) /= '' .and. labelToken /= t_name call parse ( line, pos, status, .true. ) error = error .or. status /= 1 if ( .not. error ) then read ( operands(1)%index, '(i1)' ) index label = trim(line(6:11)) // 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, & & 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, ixlab, & & dev=operands(1)%label ) case ( k_symbolic ) operands(1)%label = trim(operands(1)%label)! // sfx call enter ( operands(1)%label, ref, 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, & & 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, 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 process_ltorg ( p, .true. ) call end_or_ex width = num_lits add_width = .false. case ( 'JOB' ) ! Ignored until pass 2 case ( 'LTORG', 'ORG' ) if ( labelToken == t_name ) then label = trim(line(6:11)) // sfx call enter ( label, p, 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. ) 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 case ( k_asterisk ) case ( k_symbolic ) operands(1)%label = trim(operands(1)%label) call enter ( operands(1)%label, ref, 0, operands(1)%addr ) addr = symbols(operands(1)%addr)%value if ( addr <= ref ) then needPass2 = .true. p = 2*ref else p = addr 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) else p = p + operands(1)%offset end if width = 0 if ( line(16:20) /= 'ORG' ) then need_ltorg = .true. width = num_lits end if case ( 'SFX' ) sfx = line(21:21) case ( 'XFR' ) call end_or_ex end select else ! An instruction if ( .not. error .and. labelToken == t_name ) then ! No error so far label = trim(line(6:11)) // sfx call enter ( label, p, 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. ) ! 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 if ( num_operands == 0 ) then if ( op_codes(op_ix)%a == req ) & & call do_error ( 'A field required' ) if ( 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 ( 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 999 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 999 else width = width + 3 if ( operands(1)%kind == k_symbolic .or. & & operands(1)%kind == k_addr_con ) & & operands(1)%label = trim(operands(1)%label) // sfx if ( operands(1)%kind == k_symbolic ) & & call enter ( operands(1)%label, ref, 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 ) & & operands(2)%label = trim(operands(2)%label) // sfx if ( operands(2)%kind == k_symbolic ) & & call enter ( operands(2)%label, ref, 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 999 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 = line(16:20) if ( error .and. errCode == noErr ) errCode = badStatement write ( u_scratch, 200 ) why, line, ixLab, p_scratch, width, & & errCode, num_operands, operands(:num_operands) 200 format ( a5, a80, 3i6, a1, i6, 4(3i6,a2,a1,a6)) if ( need_ltorg ) then call process_ltorg ( p, .true. ) else if ( add_width ) p = p + width end if p_max = max(p_max, p_scratch + width) if ( p_scratch+width > 15999 .or. p > 15999 ) coreMsg = .true. 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 subroutine END_OR_EX ! Process the operand of END or EX -- name or number call lex ( line, pos, end, token ) select case ( token ) case ( t_done ) operands(1) = operand(0,k_actual,0,' ',' ',' ') case ( t_name ) operands(1) = operand(0,k_symbolic,0,' ',' ',line(pos:end)//sfx) call enter ( operands(1)%label, ref, 0, operands(1)%addr ) case ( t_number ) operands(1) = operand(0,k_actual,0,' ',' ',' ') read ( line(pos:end), * ) operands(1)%addr case default call do_error ( 'Improper operand for ' // trim(line(16:18)) ) errCode = badStatement end select num_operands = 1 end subroutine END_OR_EX end subroutine PASS_1 end module PASS_1_M