-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathpass_1_m.f90
897 lines (867 loc) · 35.1 KB
/
pass_1_m.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
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