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 pass2_:
34 procedure( decor,target_value,no_target_given,first_time_thru );
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 % include varcom;
81
82 % include concom;
83
84 % include erflgs;
85
86 % include codtab;
87
88 % include alm_prototypes;
89
90 % include relbit;
91
92 % include labarg;
93
94 % include alm_lc;
95
96 % include sthedr;
97
98 % include alm_options;
99
100 % include alm_data;
101
102
103
104
105
106 dcl decor fixed bin(35);
107 dcl target_value fixed bin(17);
108 dcl (no_target_given,first_time_thru) bit(1);
109
110
111
112
113 dcl cleanup condition;
114
115
116
117
118 dcl long_int_based fixed bin(71) based unaligned;
119
120 dcl 1 word based aligned,
121 2 (left, right) bit (18) unaligned;
122
123 dcl 1 glpl_words (0:262143) based (eb_data_$lavptr) aligned,
124 2 left bit (18) unaligned,
125 2 right bit (18) unaligned;
126
127 dcl 1 acc_string based ( addr (sym (1))) aligned,
128 2 length fixed bin (9) unsigned unaligned,
129 2 chars char (acc_string.length) unaligned;
130
131 dcl 1 opcode_overlay based aligned,
132 2 filler bit (18) unaligned,
133 2 opcode bit (10) unaligned,
134 2 flags bit (4) unaligned,
135 2 iclass bit (4) unaligned;
136
137 dcl 1 descop_overlay based aligned,
138 2 filler bit(24) unaligned,
139 2 format bit(4) unaligned,
140 2 flags bit(4) unaligned,
141 2 decor bit(4) unaligned;
142
143
144
145 dcl alm_symtab_$block entry(char(*)),
146 alm_symtab_$cleanup entry,
147 alm_symtab_$end_block entry,
148 alm_symtab_$end_enum entry,
149 alm_symtab_$end_source entry,
150 alm_symtab_$end_structure entry,
151 alm_symtab_$end_union entry,
152 alm_symtab_$enum entry(char(*)),
153 alm_symtab_$initialize entry,
154 alm_symtab_$source entry(char(*), bit(36) aligned, fixed bin(71)),
155 alm_symtab_$statement entry(fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26)),
156 alm_symtab_$structure entry(char(*)),
157 alm_symtab_$symbol entry(char(*), char(*), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26)),
158 alm_symtab_$union entry(char(*)),
159 getid_$getid_ ext entry,
160 getid_$getnam ext entry,
161 getid_$setid ext entry (fixed bin (26)),
162 getbit_$getbit_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
163 inputs_$next ext entry,
164 inputs_$nxtnb ext entry,
165 inputs_$next_statement ext entry,
166 inputs_$next_statement_nolist ext entry,
167 litevl_$itbevl ext entry (fixed bin (26), fixed bin (26)),
168 utils_$upkflg ext entry (fixed bin),
169 utils_$abort ext entry,
170 litevl_$itsevl ext entry (fixed bin (26), fixed bin (26)),
171 litevl_$litasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
172 prwrd_$source_only ext entry,
173 prnter_$prnter_ ext entry (char (*)),
174 putout_$putwrd ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
175 prwrd_$prwrd_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
176 putout_$putlst ext entry (fixed bin (26), fixed bin (26), fixed bin (26),
177 fixed bin (26), fixed bin (26)),
178 glpl_$slwrd ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
179 glpl_$storl ext entry (fixed bin (26), fixed bin (26)),
180 glpl_$storr ext entry (fixed bin (26), fixed bin (26));
181 dcl alm_include_file_$pass2 ext entry,
182 alm_include_file_$insert ext entry (ptr, fixed bin (26), fixed bin (26)),
183 alm_include_file_$pop ext entry,
184 expand_pathname_$component entry(char(*), char(*), char(*), char(*), fixed bin(35)),
185 initiate_file_$component entry(char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)),
186 inputs_$get_ptr entry (ptr, fixed bin (26), fixed bin (26), bit (1) aligned),
187 mexp_ ext entry (char (*), fixed bin (17), fixed bin(17), bit(1), bit(1)),
188 mexp_$define_macro ext entry (char (*)),
189 oplook_$reset ext entry,
190 oplook_$redefine entry,
191 system_type_ entry (char(*), char(*), fixed bin, fixed bin(35)),
192 terminate_file_ entry(ptr, fixed bin(24), bit(*), fixed bin(35)),
193 translator_info_$component_get_source_info entry(ptr, char(*), char(*), char(*), fixed bin(71), bit(36) aligned, fixed bin(35));
194
195
196
197 dcl (ascevl_$accevl ext entry (fixed bin (26)),
198 ascevl_$acievl ext entry (fixed bin (26)),
199 ascevl_$ac4evl ext entry (fixed bin (26)),
200 ascevl_$bcdevl ext entry (fixed bin (26)),
201 expevl_$expevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
202 lstman_$blkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
203 glpl_$cwrd ext entry (fixed bin (26)),
204 glpl_$glwrd ext entry (fixed bin (26), fixed bin (26)),
205 decevl_$decevl_ ext entry (fixed bin (26), fixed bin (26)),
206 lstman_$eptasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
207 fixed bin (26), fixed bin (26)),
208 utils_$exadrs ext entry (fixed bin (26), fixed bin (26)),
209 lstman_$lnkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
210 lstman_$outasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
211 lstman_$calser ext entry (fixed bin (26), fixed bin (26)),
212 lstman_$sdfasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26),
213 fixed bin (26), fixed bin (26)),
214 lstman_$namasn ext entry (fixed bin (26)),
215 utils_$rs ext entry (fixed bin (26), fixed bin (26)),
216 utils_$and ext entry (fixed bin (26), fixed bin (26)),
217 utils_$makins ext entry (fixed bin (26), fixed bin (26), fixed bin (26),
218 fixed bin (26), fixed bin (26)),
219 octevl_$octevl_ ext entry (fixed bin (26)),
220 oplook_$oplook_ ext entry (fixed bin, fixed bin (26)),
221 table_$table_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
222 fixed bin (26)),
223 lstman_$trpasn ext entry (fixed bin (26), fixed bin (26)),
224 varevl_$varevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
225 fixed bin (26), fixed bin (26)),
226 vfdevl_$vfdevl_ ext entry (fixed bin (26), fixed bin (26)),
227 vfdevl_$vfdcnt ext entry (fixed bin (26), fixed bin (26))
228 ) returns (fixed bin (26));
229 dcl alm_eis_parse_$descriptor ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
230 alm_eis_parse_$instruction ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26));
231
232
233
234 dcl (rleft, rright, rslts (128), binop, flags, basno, value, b29, admod, class, instruction_class,
235 type, xnlnk, ptrarg, ptrcal, trplnk, blklnk, symlnk, zleft, zright, rrslts (128), option,
236 argout, traout, tderr, tbss, tlc, i, iaddr, ik, iloc, irtblk, itemp, itype, j, junk,
237 k, lcl, lcloc, lcr, link, lnkorg, lpaswd, n, name, nobits, nowrds, last_p2pcl) fixed bin (26);
238
239 dcl link_not_found bit(1);
240 dcl termination_conditions bit (7);
241 dcl full_word_temp fixed bin (26);
242 dcl stkclst fixed bin(26);
243 dcl dup_ptr ptr init (null ()),
244 temp_ptr ptr,
245 dup_count fixed bin (26),
246 dup_start fixed bin (26),
247 dup_string (0:262143) char (1) unal based (dup_ptr),
248 tmacl bit (2) aligned,
249 operand char(32) varying,
250 canonical_operand char(24),
251 code fixed bin(35),
252 unique_id bit(36) aligned,
253 dtcm fixed bin(71),
254 (path, var_name, var_type) char(256) varying,
255 (st_offset, st_length, st_line, st_num) fixed bin(26);
256
257 dcl trprtn label local;
258
259 dcl label_flag bit (1) aligned;
260 dcl end_statement_flag bit (1) aligned;
261
262
263
264 dcl (eb_data_$unwind (3), eb_data_$atext (2), eb_data_$alink (2), eb_data_$asym (2), eb_data_$astat (2), eb_data_$asys (2),
265 eb_data_$aheap (2),
266 eb_data_$mstaq, eb_data_$ion, eb_data_$ioff, eb_data_$mx7, eb_data_$ib6,
267 eb_data_$isave, eb_data_$irestore, eb_data_$iobject,
268 eb_data_$nmxsav, eb_data_$tsym, eb_data_$anl) ext fixed bin (26),
269 eb_data_$rpt_terminators (7) external fixed bin (35);
270 dcl eb_data_$lavptr external pointer;
271 dcl eb_data_$entry_bound ext fixed bin(26);
272 dcl eb_data_$macro_depth ext fixed bin (26),
273 eb_data_$macro_listing_control bit (36) aligned ext;
274
275
276 dcl (ifun1 init(1100540526), ifun2 init(13318017647), ifun3 init(14763950080))
277 int static options(constant) fixed bin(35);
278
279
280
281
282
283
284 label_100:
285 pc = 0;
286
287
288
289
290
291
292
293
294
295
296 label_110:
297
298 rrslts (*) = 0;
299 curlc = lptext;
300 tvorg = fixed (glpl_words (lptv + 3).left, 18);
301 lnkorg = fixed (glpl_words (lpsect + 3).left, 18);
302 call glpl_$storr (lplit + 1, litc);
303 on cleanup call alm_symtab_$cleanup;
304 call alm_symtab_$initialize;
305 litorg = fixed (glpl_words (lplit + 3).left, 18);
306 lreter = fixed (glpl_words (lpcall + 3).left, 18);
307
308
309 stkclst = stkc;
310 stkc = fixed(glpl_words(stkclst).left);
311 stkclst = fixed(glpl_words(stkclst).right);
312
313 stkc = 16 * (divide (stkc + 15, 16, 17, 0));
314 p2pcl = pclst;
315 binlin = 1;
316 eb_data_$macro_listing_control = (36)"0"b;
317 call oplook_$reset;
318
319
320
321 label_200:
322 spc = pc;
323 tpc = fixed (glpl_words (p2pcl).left, 18);
324 tlc = fixed (glpl_words (p2pcl + 2).left, 18);
325 call utils_$upkflg (glpl_$cwrd (p2pcl + 1));
326 last_p2pcl = p2pcl;
327 p2pcl = fixed (glpl_words (p2pcl).right, 18);
328 value = 0;
329
330 label_flag = ""b;
331 label_220:
332 brk (1) = isp;
333 call getid_$getid_;
334 if (brk (1) ^= icol) then go to label_300;
335 if (eb_data_$tsym ^= 0) then if (table_$table_ (iassgn, sym (1), pc, flocrf, curlc) = 0) then prnts = 1;
336 label_flag = "1"b;
337 go to label_220;
338
339
340
341 label_300:
342 if eb_data_$tsym ^= 0 then go to label_301;
343 if brk (1) = inl then go to label_870;
344 if brk (1) = iquot then go to label_870;
345 label_301:
346 binop = oplook_$oplook_ (prnto, itype);
347 if prnto ^= 0 then do;
348 call mexp_ (addr (sym (1)) -> acc_string.chars, prnto, target_value, no_target_given,first_time_thru);
349 if prnto ^= 0 then go to label_3200;
350 else go to label_200;
351 end;
352 if (brk (1) = isp | brk (1) = inl) then go to label_305;
353
354
355 prnto = 1;
356 go to label_3200;
357
358 label_305:
359 instruction_class = fixed (addr (binop) -> opcode_overlay.iclass, 4);
360 if ^data2.compatible(instruction_class,decor)
361 then prntb = 1;
362
363 go to label_vector (itype);
364
365
366
367
368
369
370
371
372 label_vector (1):
373 label_450:
374
375 if label_flag then call prwrd_$prwrd_(spc+fixed (glpl_words(curlc+3).left, 18),0,ibb); else call prwrd_$source_only;
376 return;
377
378
379
380 label_vector (50):
381 label_include:
382 call getid_$getid_ ();
383 if eb_data_$tsym = 0 then goto label_3100;
384 call prwrd_$source_only ();
385 call inputs_$next_statement ();
386 call alm_include_file_$pass2 ();
387 goto label_220;
388
389
390
391 label_vector (2):
392 label_500:
393
394 call getid_$getid_;
395 if (eb_data_$tsym = 0) then go to label_3100;
396
397
398 call glpl_$storr (curlc + 1, pc);
399
400
401 if (table_$table_ (iserch, sym (1), pc, fmlcrf, curlc) ^= 0) then go to label_3010;
402 call prnter_$prnter_ ("fatal error in PASS2 in symbol table search for USE lc");
403 call utils_$abort;
404
405
406
407
408 label_vector (3):
409 label_525:
410
411 if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3110;
412 if (iaddr ^= 0) then go to label_3300;
413 pc = value;
414 go to label_3200;
415
416
417
418 label_vector (4):
419 label_550:
420
421 go to label_3010;
422
423
424
425 label_vector (5):
426 label_600:
427
428 if (mod (spc, 2) ^= 0) then
429 call putout_$putwrd (pc, (mnopdu), i642, 0);
430 go to label_3010;
431
432
433
434 label_vector (6):
435 label_630:
436
437 if (mod (spc, 2) = 0) then
438 call putout_$putwrd (pc, (mnopdu), i642, 0);
439 go to label_3010;
440
441
442
443 label_vector (7):
444 label_660:
445
446 if (mod (pc, 8) = 0) then go to label_3010;
447 call putout_$putwrd (pc, (mnopdu), i642, 0);
448 go to label_660;
449
450
451
452 label_vector (8):
453 label_680:
454
455 if (mod (pc, 64) = 0) then go to label_3010;
456 call putout_$putwrd (pc, (mnopdu), i642, 0);
457 go to label_680;
458
459
460
461 label_vector (11):
462 label_755:
463 label_vector (61):
464
465 go to label_3300;
466
467
468
469
470
471 label_vector (62):
472 label_decor:
473
474 call getid_$getid_();
475 operand = addr(sym(1)) -> acc_string.chars;
476 call system_type_((operand),canonical_operand,(0),code);
477 if code ^=0
478 then prntf = 1;
479 else do;
480 do n = 1 to hbound(data1.decor,1) while(rtrim(canonical_operand) ^= data1.decor(n).name);
481 end;
482 decor = data1.decor(n).number;
483 end;
484
485 goto label_3300;
486
487
488
489
490 label_vector (63):
491 label_error:
492 tfatal = 3;
493 goto label_3300;
494
495
496
497
498
499 label_vector (48):
500 label_firstref:
501 if tfirstreftrap ^= 1 then prntp = 1;
502 if varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120;
503 if b29 = 0 then value = lstman_$lnkasn (myblk, value, admod, iaddr);
504 if first_ref_trap_proc_linkno ^= value then prntu = 1;
505 first_ref_trap_proc_linkno = first_ref_trap_proc_linkno + fixed (glpl_words (lpsect + 3).left, 18);
506 if brk (1) = ilpar then do;
507 if varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120;
508 if b29 = 0 then value = lstman_$lnkasn (myblk, value, admod, iaddr);
509 if first_ref_trap_arg_linkno ^= value then prntu = 1;
510 first_ref_trap_arg_linkno = first_ref_trap_arg_linkno + fixed (glpl_words (lpsect + 3).left, 18);
511 end;
512 else if first_ref_trap_arg_linkno ^= 0 then prntu = 1;
513 goto label_3300;
514
515
516
517 label_vector (12):
518 label_760:
519
520 call getid_$getid_;
521 if (eb_data_$tsym = 0) then go to label_765;
522 if (sym (1) = eb_data_$ion) then go to label_770;
523 if (sym (1) = eb_data_$ioff) then go to label_775;
524 prntf = 1;
525 go to label_3300;
526
527
528 label_765:
529
530 if tinhib = 1 then
531 tinhib = 0;
532 else tinhib = 1;
533 go to label_3300;
534
535
536 label_770:
537
538 tinhib = 1;
539 go to label_3300;
540
541
542 label_775:
543
544 tinhib = 0;
545 go to label_3300;
546
547
548
549 label_vector (14):
550 label_820:
551
552 goto label_3300;
553
554
555
556 label_vector (15):
557 label_850:
558
559 go to label_3300;
560
561
562
563 label_vector (16):
564 label_870:
565
566 if label_flag then goto label_850;
567 do i = 1 to 36;
568 flgvec(i) = 0;
569 end;
570 p2pcl = last_p2pcl;
571 go to label_3040;
572
573
574
575
576
577
578 label_vector (17):
579 label_900:
580
581 call getid_$getid_;
582 if (eb_data_$tsym = 0) then go to label_910;
583 if (table_$table_ (iserch, sym (1), value, clbas, junk) ^= 0) then go to label_915;
584
585 label_905:
586
587 do i = 1 to 8;
588 if (sym (1) ^= symbas (i)) then
589 go to label_905a;
590 value = i - 1;
591 go to label_915;
592
593 label_905a:
594
595 end label_905;
596 if (table_$table_ (iserch, sym (1), basno, clint, junk) ^= 0) then go to label_915;
597 go to label_3130;
598
599
600 label_910:
601
602 if (varevl_$varevl_ (invrvp, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
603 if (iaddr ^= 0) then go to label_3300;
604
605
606 label_915:
607
608 link = utils_$exadrs (value, 0);
609 type = 2;
610 class = fbasrf;
611
612
613
614 label_920:
615
616 call getid_$getid_;
617 xnlnk = lstman_$namasn (sym (1));
618
619 label_930:
620
621 trprtn = label_970;
622 tderr = 0;
623 trplnk = 0;
624
625 label_933:
626
627 if (brk (1) ^= ilpar) then go to label_970;
628 ptrcal = 0;
629 ptrarg = 0;
630 if (varevl_$varevl_ (ixvrvl, basno, ptrcal, admod, b29, iaddr) ^= 0) then go to label_935;
631 tderr = 1;
632 go to label_945;
633
634 label_935:
635
636 if (b29 ^= 0) then go to label_945;
637 if tprot = 1 then go to label_940;
638 ptrcal = lstman_$lnkasn (myblk, ptrcal, admod, iaddr);
639 go to label_945;
640
641 label_940:
642
643 ptrcal = lstman_$eptasn (ptrcal, 0, mylnk, curlc, 0, 1);
644
645 label_945:
646
647 if (brk (1) ^= ilpar) then go to label_960;
648 if (varevl_$varevl_ (ixvrvl, basno, ptrarg, admod, b29, iaddr) ^= 0) then go to label_950;
649 tderr = 1;
650 go to label_955;
651
652 label_950:
653
654 if (b29 = 0) then
655 ptrarg = lstman_$lnkasn (myblk, ptrarg, admod, iaddr);
656
657 label_955:
658
659 if (brk (1) = irpar) then
660 call inputs_$next;
661
662 label_960:
663
664 if (brk (1) = irpar) then go to label_965;
665 tderr = 1;
666 go to trprtn;
667
668 label_965:
669
670 call inputs_$next;
671 if (tderr ^= 0) then go to trprtn;
672 trplnk = lstman_$trpasn (ptrcal, ptrarg);
673 go to trprtn;
674
675
676 label_970:
677
678 if (tderr = 0) then go to label_975;
679 prntf = 1;
680 go to label_980;
681
682 label_975:
683
684 if (table_$table_ (iassgn, fixed (glpl_words (xnlnk).left, 18), lstman_$blkasn (type, link, xnlnk, trplnk), class,
685 junk) = 0) then
686 prnts = 1;
687
688 label_980:
689
690 if (brk (1) = icomma) then go to label_920;
691 go to label_3300;
692
693
694
695 label_vector (18):
696 label_1000:
697
698 call getid_$setid (symlnk);
699 if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
700 if (varevl_$varevl_ (ibvrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
701 if (iaddr ^= 0) then go to label_3300;
702 if (table_$table_ (iassgn, symlnk, value, fbolrf, junk) = 0) then go to label_3120;
703 go to label_3200;
704
705
706
707 label_vector (19):
708 label_1100:
709
710 call getid_$setid (symlnk);
711 if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
712 if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
713 class = fequrf;
714 if (iaddr ^= 0) then
715 class = flocrf;
716 if (table_$table_ (iassgn, symlnk, value, class, iaddr) = 0) then go to label_3120;
717 if (iaddr = 0) then go to label_3200;
718
719
720 value = value + fixed (glpl_words (iaddr + 3).left, 18);
721 go to label_3200;
722
723
724
725 label_vector (20):
726 label_1200:
727
728 call getid_$setid (symlnk);
729 if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
730 if (varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
731 if (b29 = 0) then
732 value = lstman_$lnkasn (myblk, value, admod, iaddr);
733 if (table_$table_ (iassgn, symlnk, value, flocrf, lpsect) = 0) then go to label_3120;
734
735
736 value = value + fixed (glpl_words (lpsect + 3).left, 18);
737 go to label_3200;
738
739
740
741 label_vector (65):
742
743 call getid_$getid_;
744 if (eb_data_$tsym = 0) then go to label_3100;
745 if (table_$table_ (iserch, sym(1), value, flocrf, lcloc) = 0) then go to label_3130;
746 if (brk(1) ^= icomma) then go to label_3100;
747 itemp = value + fixed(glpl_words(lcloc+3).left,18);
748 if (varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
749 j = lnklst;
750 link_not_found = "1"b;
751 i = 1;
752 do while (link_not_found);
753 if (fixed(glpl_words(j).left,18) = 2) then
754 j = fixed(glpl_words(j).right, 18);
755 else do;
756 if (i <= value/2) then do;
757 j = fixed(glpl_words(j).right, 18);
758 i = i + 1;
759 end;
760 else link_not_found = "0"b;
761 end;
762 end;
763 j = fixed(glpl_words(j+1).left, 18);
764 j = fixed(glpl_words(j+1).left, 18);
765 glpl_words(j+1).right = bit(fixed(itemp+1, 18), 18);
766
767 go to label_3200;
768
769
770
771 label_vector (21):
772 label_1250:
773
774 call getid_$setid (symlnk);
775 if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
776 if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
777 if (iaddr ^= 0) then go to label_3300;
778 if (table_$table_ (iassgn, symlnk, value, fsetrf, junk) = 0) then go to label_3120;
779 go to label_3200;
780
781
782
783 label_vector (22):
784 label_1300:
785
786 call getid_$getnam;
787 if (brk (1) ^= icomma) then go to label_3100;
788 class = fsegrf;
789 if (sym (1) ^= eb_data_$atext (1) | sym (2) ^= eb_data_$atext (2)) then go to label_1310;
790 type = 5;
791 link = 0;
792 go to label_920;
793
794 label_1310:
795
796 if (sym (1) ^= eb_data_$alink (1) | sym (2) ^= eb_data_$alink (2)) then go to label_1320;
797 type = 5;
798 link = 1;
799 go to label_920;
800
801 label_1320:
802
803 if (sym (1) ^= eb_data_$asym (1) | sym (2) ^= eb_data_$asym (2)) then go to label_1330;
804 type = 5;
805 link = 2;
806 go to label_920;
807
808 label_1330:
809
810 if (sym (1) ^= eb_data_$astat (1) | sym (2) ^= eb_data_$astat (2)) then go to label_1340;
811 type = 5;
812 link = 4;
813 go to label_920;
814
815 label_1340:
816
817 if (sym (1) ^= eb_data_$asys (1) | sym (2) ^= eb_data_$asys (2)) then go to label_1350;
818 type = 5;
819 link = 5;
820 go to label_920;
821
822 label_1350:
823 if (sym (1) ^= eb_data_$aheap (1) | sym (2) ^= eb_data_$aheap (2)) then go to label_1360;
824 type = 5;
825 link = 6;
826 go to label_920;
827
828 label_1360:
829
830 type = 4;
831 link = lstman_$namasn (sym (1));
832 go to label_920;
833
834
835
836 label_vector (23):
837 label_1400:
838
839
840 label_vector (24):
841 label_1500:
842
843 go to label_3010;
844
845 label_vector (25):
846 label_1505:
847
848 go to label_3010;
849
850
851
852
853
854
855
856
857 label_vector (26):
858 label_1600:
859 n = ascevl_$accevl (rslts (1));
860 go to label_1710;
861
862 label_vector (27):
863 label_1700:
864 n = ascevl_$acievl (rslts (1));
865 goto label_1710;
866
867 label_vector (13):
868 label_bci:
869 n = ascevl_$bcdevl (rslts (1));
870 go to label_1710;
871
872 label_vector (59):
873 label_ac4:
874 n = ascevl_$ac4evl (rslts (1));
875
876 label_1710:
877 do i = 1 to n;
878 rrslts (i) = 0;
879 end label_1710;
880 call putout_$putlst (pc, rslts (1), i3333, n, rrslts (1));
881 go to label_3010;
882
883
884
885
886 label_vector (28):
887 label_1800:
888
889 n = decevl_$decevl_ (rslts (1), type);
890 if (n >= 2 & mod (pc, 2) ^= 0) then
891 call putout_$putwrd (pc, 0, i66, 0);
892 rrslts (1) = 0;
893 rrslts (2) = 0;
894 call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
895 if (brk (1) = icomma) then go to label_1800;
896 go to label_3010;
897
898
899
900
901 label_vector (66):
902 label_1801:
903
904 n = decevl_$decevl_ (rslts (1), type);
905 rrslts (1) = 0;
906 rrslts (2) = 0;
907 call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
908 if (brk (1) = icomma) then go to label_1801;
909 go to label_3010;
910
911
912
913
914 label_vector (29):
915 label_1900:
916
917 n = octevl_$octevl_ (rslts (1));
918 if (n >= 2 & mod (pc, 2) ^= 0) then
919 call putout_$putwrd (pc, 0, i66, 0);
920 rrslts (1) = 0;
921 rrslts (2) = 0;
922 call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
923 if (brk (1) = icomma) then go to label_1900;
924 go to label_3010;
925
926
927
928
929 label_vector (67):
930 label_1901:
931
932 n = octevl_$octevl_ (rslts (1));
933 rrslts (1) = 0;
934 rrslts (2) = 0;
935 call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
936 if (brk (1) = icomma) then go to label_1901;
937 go to label_3010;
938
939
940
941 label_vector (30):
942 label_2000:
943
944 prnte = 0;
945
946 label_2001:
947
948 rrslts(*) = 0;
949 n = vfdevl_$vfdevl_ (rslts (1), flags);
950 if (flags = 0) then go to label_2015;
951
952 label_2010:
953
954 do k = 1 to n;
955 lcl = fixed (glpl_words (flags + k - 1).left, 18);
956 lcr = fixed (glpl_words (flags + k - 1).right, 18);
957 zleft = utils_$rs (rslts (k), 18);
958 zright = utils_$and (rslts (k), sixsev);
959 rleft = 0;
960 rright = 0;
961 if (lcl = 0) then
962 go to label_2003;
963 zleft = zleft + fixed (glpl_words (lcl + 3).left, 18);
964 call getbit_$getbit_ (lcl, 0, 0, rleft);
965
966 label_2003:
967
968 if (lcr = 0) then
969 go to label_2005;
970 zright = zright + fixed (glpl_words (lcr + 3).left, 18);
971 call getbit_$getbit_ (lcr, 0, 0, rright);
972
973 label_2005:
974
975 rslts (k) = glpl_$glwrd (zleft, zright);
976 rrslts (k) = glpl_$glwrd (rleft, rright);
977 end label_2010;
978
979 label_2015:
980
981 call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
982 go to label_3010;
983
984
985
986 label_vector (31):
987 label_2020:
988
989 call getid_$getid_;
990 junk = expevl_$expevl_ (0, value, iaddr);
991 if iaddr ^= 0 then prntr = 1;
992
993 label_2025:
994
995 if (mod (pc, value) = 0) then go to label_3010;
996 call putout_$putwrd (pc, (mnopdu), i642, 0);
997 go to label_2025;
998
999
1000
1001
1002
1003
1004 label_vector (32):
1005 label_2100:
1006
1007 tbss = 0;
1008 go to label_2210;
1009
1010
1011
1012 label_vector (33):
1013 label_2200:
1014
1015 tbss = 1;
1016
1017 label_2210:
1018
1019 call getid_$setid (symlnk);
1020 if (brk (1) ^= icomma) then go to label_3100;
1021 if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3110;
1022 if (iaddr = 0) then go to label_2220;
1023 prntr = 1;
1024 go to label_3120;
1025
1026 label_2220:
1027
1028 pc = spc + value;
1029 if (b29 ^= 0 ) then prntf = 1;
1030 value = pc;
1031 if (tbss = 1) then
1032 value = spc;
1033 if symlnk ^= 0 then if (table_$table_ (iassgn, symlnk, value, flocrf, curlc) = 0) then prnts = 1;
1034 call prwrd_$prwrd_ (value + fixed (glpl_words (curlc + 3).left, 18), 0, ibb);
1035 go to label_3010;
1036
1037
1038
1039 label_vector (34):
1040 label_2350:
1041
1042 junk = varevl_$varevl_ (invrvl, basno, zleft, admod, b29, iaddr);
1043 call getbit_$getbit_ (iaddr, basno, b29, rleft);
1044 if (iaddr ^= 0) then
1045 zleft = zleft + fixed (glpl_words (iaddr + 3).left, 18);
1046 rright, zright = 0;
1047 if (brk (1) = icomma) then
1048 do;
1049 junk = varevl_$varevl_ (invrvl, basno, zright, admod, b29, iaddr);
1050 call getbit_$getbit_ (iaddr, basno, b29, rright);
1051 if (iaddr ^= 0) then
1052 zright = zright + fixed (glpl_words (iaddr + 3).left, 18);
1053 end;
1054 call putout_$putwrd (pc, glpl_$glwrd (zleft, zright), i66, glpl_$glwrd (rleft, rright));
1055 go to label_3010;
1056
1057
1058
1059 label_vector (35):
1060 label_2400:
1061
1062 call litevl_$itbevl (rslts (1), rrslts (1));
1063 go to label_2455;
1064
1065
1066
1067 label_vector (36):
1068 label_2450:
1069
1070 call litevl_$itsevl (rslts (1), rrslts (1));
1071
1072 label_2455:
1073
1074 if (mod (spc, 2) ^= 0) then
1075 call putout_$putwrd (pc, (mnopdu), i642, 0);
1076 call putout_$putlst (pc, rslts (1), i66, 2, rrslts (1));
1077 go to label_3010;
1078
1079
1080
1081
1082
1083
1084 label_vector (37):
1085 label_2500:
1086
1087 junk = varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr);
1088 call getbit_$getbit_ (iaddr, basno, b29, rleft);
1089
1090 addr (nslbit (5)) -> word.left , addr (new_nslbit (3)) -> word.left = addr (rleft) -> word.right;
1091
1092 if (iaddr ^= 0) then
1093 value = value + fixed (glpl_words (iaddr + 3).left, 18);
1094 traout = utils_$makins (basno, value, mtra, b29, admod);
1095 new_slcall (3) = utils_$makins (basno, value, new_slcall (3), b29, admod);
1096 if (brk (1) = ilpar) then go to label_2510;
1097 call litevl_$litasn (value, dzero (1), 2, 0);
1098 argout = utils_$makins (0, value + fixed (glpl_words (lplit + 3).left, 18), meapap, 0, 0);
1099 nslbit (3), new_nslbit (2) = iltext;
1100 go to label_2520;
1101
1102 label_2505:
1103
1104
1105
1106
1107 argout = utils_$makins (6, 30, meapap, 1, 0);
1108 nslbit (3), new_nslbit (2) = iltext;
1109 go to label_2520;
1110
1111 label_2510:
1112
1113 junk = varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr);
1114 call getbit_$getbit_ (iaddr, basno, b29, rleft);
1115
1116 addr (nslbit (3)) -> word.left, addr (new_nslbit (2)) -> word.left = addr (rleft) -> word.right;
1117
1118 if (iaddr ^= 0) then
1119 value = value + fixed (glpl_words (iaddr + 3).left, 18);
1120 argout = utils_$makins (basno, value, meapap, b29, admod);
1121
1122 label_2520:
1123
1124 if (tstsw (1) ^= 0) then go to label_2550;
1125 slcall (3), new_slcall (2) = argout;
1126 slcall (5) = traout;
1127 if tnewcall ^= 0 then call putout_$putlst (pc, new_slcall (1), i642, new_nslcal, new_nslbit (1));
1128 else call putout_$putlst (pc, slcall (1), i642, nslcal, nslbit (1));
1129 go to label_3140;
1130
1131
1132
1133
1134
1135
1136
1137
1138 label_2550:
1139
1140 j = lstman_$calser (spc, link);
1141 link = link + fixed (glpl_words (lpsect + 3).left, 18);
1142 call litevl_$litasn (lpaswd, fixed (glpl_words (j + 2).right, 18), 1, 0);
1143 mxcall (3) = utils_$makins (lp, link, meapap, 1, 0);
1144 mxcall (5) = argout;
1145 mxcbit (5) = nslbit (3);
1146 mxcall (7) = utils_$makins (0, lpaswd + fixed (glpl_words (lplit + 3).left, 18), mldq, 0, 0);
1147 mxcall (11) = traout;
1148 mxcbit (11) = nslbit (5);
1149 call putout_$putlst (pc, mxcall (1), i642, nmxcal, mxcbit (1));
1150
1151 mxclbk (2) = utils_$makins (0, lpaswd + fixed (glpl_words (lplit + 3).left, 18), mcmpq, 0, 0);
1152 mxlbit (2) = iltext;
1153 mxclbk (3) = utils_$makins (0, lreter, mtnz, 0, 0);
1154 mxlbit (3) = iltext;
1155 call putout_$putlst (pc, mxclbk (1), i642, nmxclb, mxlbit (1));
1156 go to label_3140;
1157
1158
1159
1160 label_vector (51):
1161 label_short_call:
1162 junk = varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr);
1163 call getbit_$getbit_ (iaddr, basno, b29, rleft);
1164 addr (short_nslbit (1)) -> word.left = addr (rleft) -> word.right;
1165 if iaddr ^= 0 then value = value + fixed (glpl_words (iaddr + 3).left, 18);
1166 short_slcall (1) = utils_$makins (basno, value, short_slcall (1), b29, admod);
1167 call putout_$putlst (pc, short_slcall (1), i642, short_nslcal, short_nslbit (1));
1168 goto label_3140;
1169
1170
1171
1172 label_vector (38):
1173 label_2600:
1174
1175 call getid_$getid_;
1176 if (eb_data_$tsym = 0) then go to label_3100;
1177 if (table_$table_ (iserch, sym (1), value, flocrf, lcloc) = 0) then go to label_3130;
1178 link = mylnk;
1179 name = lstman_$namasn (sym (1));
1180
1181
1182
1183 if (tprot = 0) then if tnewobject = 0 then
1184 link = lstman_$lnkasn (lstman_$blkasn (1, fixed (glpl_words (lcloc + 4).right, 18), 0, 0), 0, eb_data_$mx7, 0);
1185 else link = 0;
1186 trplnk = 0;
1187 if (brk (1) ^= ilpar) then go to label_2620;
1188 tmvdef = 1;
1189 tderr = 0;
1190 trprtn = label_2610;
1191 go to label_933;
1192
1193 label_2610:
1194
1195 if (tderr ^= 0) then
1196 prntf = 1;
1197
1198 label_2620:
1199
1200 class = 1;
1201 if (brk (1) ^= ilsb) then go to label_2640;
1202 call getid_$getid_;
1203 if (expevl_$expevl_ (0, class, iaddr) = 0) then
1204 prntr,prntf = 1;
1205 if (iaddr ^= 0) then
1206 prntr = 1;
1207 if (brk (1) = irsb) then go to label_2630;
1208 prntf = 1;
1209 go to label_2640;
1210
1211 label_2630:
1212
1213 call inputs_$next;
1214
1215 label_2640:
1216
1217 junk = lstman_$eptasn (value, name, link, lcloc, trplnk, class);
1218 if (brk (1) = icomma) then go to label_2600;
1219 if (lcloc = 0) then go to label_3200;
1220 value = value + fixed (glpl_words (lcloc + 3).left, 18);
1221 go to label_3200;
1222
1223
1224
1225 label_vector (64):
1226 label_2641:
1227 call getid_$getid_;
1228 if eb_data_$tsym = 0 then goto label_3100;
1229 j = bin("000240000"b3, 26);
1230
1231
1232 stkc = fixed(glpl_words(stkclst).left);
1233 stkclst = fixed(glpl_words(stkclst).right);
1234 i = stkc;
1235
1236 if table_$table_(iserch, sym(1), value, flocrf, lcloc) = 0 then goto label_3130;
1237 if lcloc = 0 then goto label_3200;
1238 value = value + fixed(glpl_words(lcloc+3).left, 18);
1239 name = lstman_$namasn(sym(1));
1240 if brk(1) ^= icomma then goto label_2642;
1241
1242 junk = varevl_$varevl_(invrvl, basno, k, admod, b29, iaddr);
1243 if junk ^= 0 & k ^= 0 then i = k;
1244 if iaddr ^= 0 then prntr = 1;
1245 if brk(1) ^= icomma then goto label_2642;
1246 call getid_$getid_;
1247
1248 if brk(1) ^= icomma then goto label_2642;
1249 call getid_$getid_;
1250
1251 if sym(1) ^= 0 then do;
1252 if table_$table_(iserch, sym(1), j, flocrf, iaddr) = 0 then goto label_3130;
1253 if iaddr^=0 then j = j + fixed(glpl_words(iaddr+3).left, 18);
1254 call putout_$putlst(pc, 262144 * j, i66, 1, iltext);
1255 j = bin("000300000"b3, 26);
1256 end;
1257 if brk(1) ^= icomma then goto label_2642;
1258 call getid_$getid_;
1259
1260 if sym(1) ^= 0 then do;
1261 if (sym(1) ^= ifun1) | (sym(2) ^= ifun2) | (sym(3) ^= ifun3) then goto label_3130;
1262 else j = j + bin("000020000"b3, 26);
1263 end;
1264
1265 label_2642:
1266 class = fixed(glpl_words(curlc + 4).right, 18) + fixed("100000"b3, 18);
1267 junk = lstman_$sdfasn (pc + 1 + fixed(glpl_words(curlc+3).left, 18), name, curlc, 0, class);
1268
1269
1270 call putout_$putlst(pc, j, i66, 1, ildefs);
1271
1272
1273 i = 16 * divide(i + 15, 16, 18, 0);
1274 call putout_$putlst(pc, i*262144 + bin("627000"b3, 19), i66, 1, 0);
1275
1276
1277 call putout_$putlst(pc, bin("700034352120"b3, 36), i66, 1, 0);
1278
1279
1280 call putout_$putlst(pc, bin("201045272100"b3, 36), i66, 1, 0);
1281
1282
1283 call putout_$putlst(pc, 0, i66, 1, 0);
1284 call putout_$putlst(pc, 0, i66, 1, isymbl);
1285
1286
1287 call putout_$putlst(pc, value * 262144 + bin("710000"b3, 26), i66, 1, iltext);
1288 goto label_3010;
1289
1290
1291
1292
1293 label_vector (39):
1294 label_2700:
1295
1296 call getid_$getid_;
1297 if (brk (1) ^= iques) then go to label_2720;
1298 junk = varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr);
1299 if (iaddr = 0) then go to label_2710;
1300 pc = spc + nertls;
1301 go to label_3300;
1302
1303
1304 label_2710:
1305
1306 ertlst (5) = utils_$makins (ap, 2 * value, mldaq, 1, 0);
1307 ertlst (6) = utils_$makins (sp, labarg + 2, eb_data_$mstaq, 1, 0);
1308 ertlst (7) = utils_$makins (sp, labarg, meapap, 1, 0);
1309 irtblk = lstman_$blkasn (4, lstman_$namasn (eb_data_$unwind (1)), lstman_$namasn (eb_data_$unwind (1)), 0);
1310 ertlst (11) = utils_$makins (lp, lstman_$lnkasn (irtblk, 0, 0, 0) + fixed (glpl_words (lpsect + 3).left, 18),
1311 mtra, 1, mri);
1312 call putout_$putlst (pc, ertlst (1), i642, nertls, merbit (1));
1313 go to label_3140;
1314
1315
1316
1317 label_2720:
1318
1319 if tnewcall ^= 0 then call putout_$putlst (pc, new_retlst (1), i642, new_nretls, new_mrtbit (1));
1320 else call putout_$putlst (pc, retlst (1), i642, nretls, mrtbit (1));
1321 go to label_3140;
1322
1323
1324
1325 label_vector (46):
1326 label_short_return:
1327 if tnewcall = 0 then prnto = 1;
1328 call putout_$putlst (pc, short_retlst (1), i642, short_nretls, short_mrtbit (1));
1329 goto label_3140;
1330
1331
1332
1333 label_vector (41):
1334 label_2800:
1335
1336 junk = varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr);
1337 if (value = 0) then go to label_2810;
1338 if (iaddr = 0) then go to label_2805;
1339 prntr = 1;
1340 if tnewcall ^= 0 then pc = spc + new_nslsav;
1341 else pc = spc + nslsav;
1342 if tprot = 1 then
1343 pc = pc + eb_data_$nmxsav;
1344 go to label_3300;
1345
1346 label_2805:
1347
1348 value = 8 * (divide (value + 7, 8, 17, 0));
1349 go to label_2820;
1350
1351 label_2810:
1352
1353 value = stkc;
1354 basno, admod, b29 = 0;
1355
1356 label_2820:
1357
1358 if tnewcall ^= 0 then if tprot = 0 then do;
1359 value = 16 * divide (value + 15, 16, 17, 0);
1360 new_slsave (1) = utils_$makins (basno, value, new_slsave (1), b29, admod);
1361 call putout_$putlst (pc, new_slsave (1), i642, new_nslsav, new_mslbit (1));
1362 goto label_3140;
1363 end;
1364
1365 slsave (3) = utils_$makins (bp, value, meapbp, 1, 0);
1366 slsave (4) = utils_$makins (bp, 18 - value, mstpbp, 1, 0);
1367 slsave (5) = utils_$makins (bp, - value, meabsp, 1, 0);
1368 if tprot = 1 then
1369 call putout_$putlst (pc, mxsave (1), i642, eb_data_$nmxsav, mxsbit (1));
1370 call putout_$putlst (pc, slsave (1), i642, nslsav, mslbit (1));
1371 go to label_3140;
1372
1373
1374
1375 label_vector (42):
1376 label_2900:
1377
1378 call getid_$getid_;
1379 if (eb_data_$tsym = 0) then go to label_3100;
1380 if (table_$table_ (iserch, sym (1), value, flocrf, lcloc) = 0) then go to label_3130;
1381 name = lstman_$namasn (sym (1));
1382 trplnk = 0;
1383 if (brk (1) ^= ilpar) then go to label_2920;
1384 tmvdef = 1;
1385 tderr = 0;
1386 trprtn = label_2910;
1387 go to label_933;
1388
1389 label_2910:
1390
1391 if (tderr = 1) then
1392 prntf = 1;
1393
1394 label_2920:
1395
1396 class = fixed (glpl_words (lcloc + 4).right, 18);
1397 if (brk (1) ^= ilsb) then go to label_2940;
1398 call getid_$getid_;
1399 if (expevl_$expevl_ (0, class, iaddr) = 0) then
1400 prntr,prntf = 1;
1401 if (iaddr ^= 0) then
1402 prntr = 1;
1403 if (brk (1) = irsb) then go to label_2930;
1404 prntf = 1;
1405 go to label_2940;
1406
1407 label_2930:
1408
1409 call inputs_$next;
1410
1411 label_2940:
1412
1413 junk = lstman_$sdfasn (value, name, lcloc, trplnk, class);
1414 if (brk (1) = icomma) then go to label_2900;
1415 if (lcloc = 0) then go to label_3200;
1416 value = value + fixed (glpl_words (lcloc + 3).left, 18);
1417 go to label_3200;
1418
1419
1420
1421 label_vector (68):
1422 call getid_$getid_;
1423 if eb_data_$tsym = 0 then call alm_symtab_$block("");
1424 else call alm_symtab_$block( addr(sym(1)) -> acc_string.chars );
1425 goto label_3140;
1426
1427
1428 label_vector (69):
1429 call alm_symtab_$end_block;
1430 goto label_3140;
1431
1432
1433 label_vector (70):
1434 call getid_$getid_;
1435 var_name = addr(sym(1)) -> acc_string.chars;
1436 do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
1437 var_name = var_name || addr(brk(2)) -> dup_string(3);
1438 call getid_$getid_;
1439 var_name = var_name || addr(sym(1)) -> acc_string.chars;
1440 end;
1441 if var_name = "" then goto label_3100;
1442 else call alm_symtab_$enum( (var_name) );
1443 goto label_3140;
1444
1445
1446 label_vector (71):
1447 call alm_symtab_$end_enum;
1448 goto label_3140;
1449
1450
1451 label_vector (72):
1452 unique_id = "0"b;
1453 dtcm = 0;
1454 call getid_$getid_;
1455 path = addr(sym(1)) -> acc_string.chars;
1456 do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
1457 path = path || addr(brk(2)) -> dup_string(3);
1458 call getid_$getid_;
1459 path = path || addr(sym(1)) -> acc_string.chars;
1460 end;
1461 if path = "" then goto label_3100;
1462 if brk(1) = icomma then do;
1463 n = octevl_$octevl_ (rslts (1));
1464 if n >=2 then goto label_3100;
1465 unique_id = unspec(rslts(1));
1466 if brk(1) ^= icomma then goto label_3100;
1467 n = decevl_$decevl_(rslts(1), type);
1468 if n = 1 then dtcm = rslts(1);
1469 else dtcm = addr(rslts(1)) -> long_int_based;
1470 end;
1471 else begin;
1472 dcl (dirname char(256), entryname char(32), compname char(32)) automatic;
1473 dcl seg_ptr ptr;
1474 dcl code fixed bin(35);
1475
1476 seg_ptr = null();
1477 call expand_pathname_$component((path), dirname, entryname, compname, code);
1478 if code ^= 0 then goto label_2950;
1479 on cleanup call terminate_file_(seg_ptr, 0, "001"b, 0);
1480 call initiate_file_$component(dirname, entryname, compname, "100"b, seg_ptr, 0, code);
1481 if code ^= 0 then goto label_2950;
1482 call translator_info_$component_get_source_info(seg_ptr, dirname, entryname, compname, dtcm, unique_id, code);
1483 if code ^= 0 then goto label_2950;
1484 call terminate_file_(seg_ptr, 0, "001"b, code);
1485 path = rtrim(dirname, "> ") || ">" || rtrim(entryname, " ");
1486 if compname ^= "" then path = path || "::" || compname;
1487 end;
1488 label_2950:
1489 call alm_symtab_$source((path), unique_id, dtcm);
1490 goto label_3140;
1491
1492
1493 label_vector (73):
1494 call alm_symtab_$end_source;
1495 goto label_3140;
1496
1497
1498 label_vector (74):
1499 junk = varevl_$varevl_(invrvl, basno, st_offset, admod, b29, iaddr);
1500 if iaddr ^= 0 then prntr = 1;
1501 if brk(1) ^= icomma then goto label_3100;
1502 junk = varevl_$varevl_(invrvl, basno, st_length, admod, b29, iaddr);
1503 if iaddr ^= 0 then prntr = 1;
1504 if brk(1) ^= icomma then goto label_3100;
1505 junk = varevl_$varevl_(invrvl, basno, st_line, admod, b29, iaddr);
1506 if iaddr ^= 0 then prntr = 1;
1507 if brk(1) = icomma then do;
1508 junk = varevl_$varevl_(invrvl, basno, st_num, admod, b29, iaddr);
1509 if iaddr ^= 0 then prntr = 1;
1510 end;
1511 else st_num = 1;
1512 call alm_symtab_$statement(pc + fixed(glpl_words(curlc+3).left, 18),
1513 st_offset, st_length, st_line, st_num);
1514 goto label_3140;
1515
1516
1517 label_vector (75):
1518 call getid_$getid_;
1519 var_name = addr(sym(1)) -> acc_string.chars;
1520 do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
1521 var_name = var_name || addr(brk(2)) -> dup_string(3);
1522 call getid_$getid_;
1523 var_name = var_name || addr(sym(1)) -> acc_string.chars;
1524 end;
1525 if var_name = "" then goto label_3100;
1526 else call alm_symtab_$structure( (var_name) );
1527 goto label_3140;
1528
1529
1530 label_vector (76):
1531 call alm_symtab_$end_structure;
1532 goto label_3140;
1533
1534 label_vector (77):
1535 call getid_$getid_;
1536 var_name = addr(sym(1)) -> acc_string.chars;
1537 do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
1538 var_name = var_name || addr(brk(2)) -> dup_string(3);
1539 call getid_$getid_;
1540 var_name = var_name || addr(sym(1)) -> acc_string.chars;
1541 end;
1542 if var_name = "" then goto label_3100;
1543
1544 call getid_$getid_;
1545 var_type = addr(sym(1)) -> acc_string.chars;
1546 i = 0;
1547 do while(brk(1) ^= inl & (brk(1) ^= icomma | i > 0) & brk(1) ^= iquot);
1548 if brk(1) = ilsb then i = i + 1;
1549 else if brk(1) = irsb then i = i - 1;
1550 var_type = var_type || addr(brk(2)) -> dup_string(3);
1551 if brk(1) ^= ilsb & brk(1) ^= icomma & brk(1) ^= icol then do;
1552 call getid_$getid_;
1553 var_type = var_type || addr(sym(1)) -> acc_string.chars;
1554 end;
1555 else do;
1556 call getid_$getid_;
1557
1558 junk = table_$table_(iserch, sym(1), value, flocrf, lcloc);
1559 if junk=0 then var_type = var_type || addr(sym(1)) -> acc_string.chars;
1560 else do;
1561 if lcloc ^= 0 then value = value + fixed(glpl_words(lcloc+3).left, 18);
1562 var_type = var_type || ltrim(char(value));
1563 end;
1564 end;
1565 end;
1566 if var_type = "" | i > 0 then goto label_3100;
1567
1568
1569 i = 0;
1570 if brk(1) = icomma then do;
1571 if varevl_$varevl_(ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120;
1572 if brk(1) = ilpar then do;
1573 if varevl_$varevl_(invrvp, 0, i, 0, 0, 0) = 0 then goto label_3120;
1574 end;
1575 if basno = 0 & value = 0 & admod = 0 & b29 = 0 & iaddr = 0 & i = 0 then goto label_3100;
1576 call alm_symtab_$symbol((var_name), (var_type), basno, value, admod, b29, iaddr, i);
1577 end;
1578 else call alm_symtab_$symbol((var_name), (var_type), 0, 0, 0, 0, 0, 0);
1579 goto label_3140;
1580
1581
1582
1583 label_vector (78):
1584 call getid_$getid_;
1585 var_name = addr(sym(1)) -> acc_string.chars;
1586 do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
1587 var_name = var_name || addr(brk(2)) -> dup_string(3);
1588 call getid_$getid_;
1589 var_name = var_name || addr(sym(1)) -> acc_string.chars;
1590 end;
1591 if var_name = "" then goto label_3100;
1592 else call alm_symtab_$union( (var_name) );
1593 goto label_3140;
1594
1595
1596 label_vector (79):
1597 call alm_symtab_$end_union;
1598 goto label_3140;
1599
1600
1601
1602
1603
1604 label_vector (45):
1605 label_2970:
1606
1607 call putout_$putwrd (pc, utils_$makins (0, - fixed (glpl_words (curlc + 3).left, 18) - pc, meaplp, 0, mpc),
1608 i642, glpl_$glwrd (imlink, 0));
1609 go to label_3010;
1610
1611
1612
1613 label_vector (49):
1614 label_getlp:
1615 call putout_$putlst (pc, new_getlp (1), i642, new_ngetlp, new_getbit (1));
1616 goto label_3140;
1617
1618
1619
1620
1621
1622 label_vector (55):
1623 label_eis_desca:
1624 type = 1;
1625 goto desc_common;
1626
1627 label_vector (56):
1628 label_eis_descb:
1629 type = 2;
1630 goto desc_common;
1631
1632 label_vector (57):
1633 label_eis_descn:
1634 type = 3;
1635
1636 desc_common:
1637 nobits = fixed (addr (binop) -> descop_overlay.flags, 4);
1638 class = fixed (addr (binop) -> descop_overlay.format, 4);
1639 full_word_temp = alm_eis_parse_$descriptor (type, nobits, class, rleft);
1640 call putout_$putwrd (pc, full_word_temp, i66, rleft);
1641 goto label_3015;
1642
1643
1644 label_vector (52):
1645 label_repeat:
1646
1647
1648
1649
1650
1651 call getid_$getid_;
1652 if expevl_$expevl_ (0, zleft, iaddr) = 0 then prnte = 1;
1653 if iaddr ^= 0 then prntr = 1;
1654 if brk (1) = icomma then do;
1655 call getid_$getid_;
1656 if expevl_$expevl_ (0, zright, iaddr) = 0 then prnte = 1;
1657 if iaddr ^= 0 then prntr = 1;
1658 if zright < 0 | zright > 63 then prnte = 1;
1659 end;
1660 else zright = 1;
1661
1662 termination_conditions = ""b;
1663 do i = 1 to 7 while (brk (1) = icomma);
1664 call getid_$getid_;
1665 do j = 1 to 7;
1666 if sym (1) = eb_data_$rpt_terminators (j) then do;
1667 substr (termination_conditions, j, 1) = "1"b;
1668 goto rpt_out;
1669 end;
1670 end;
1671 prntu = 1;
1672 rpt_out: end;
1673
1674 zleft = zleft * 1024 + fixed (addr (binop) -> opcode_overlay.flags || termination_conditions, 11);
1675 itemp = tinhib;
1676 tinhib = 1;
1677 call putout_$putwrd (pc, utils_$makins (0, zleft, binop, 0, zright), i642, 0);
1678 tinhib = itemp;
1679 goto label_3015;
1680
1681
1682 label_vector (53):
1683 label_eis_single:
1684
1685
1686
1687
1688
1689 if varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then prnte = 1;
1690 if b29 = 0 then do;
1691 prnte = 1;
1692 b29 = 1;
1693 end;
1694 if iaddr = 0 then rleft = 0;
1695 else do;
1696 value = value + fixed (glpl_words (iaddr + 3).left, 18);
1697 call getbit_$getbit_ (iaddr, basno, b29, rleft);
1698 rleft = rleft * 262144;
1699 end;
1700
1701 full_word_temp = utils_$makins (basno, value, binop, b29, admod);
1702 if addr (binop) -> opcode_overlay.flags then full_word_temp = full_word_temp - 64;
1703 call putout_$putwrd (pc, full_word_temp, i642, rleft);
1704 goto label_3015;
1705
1706 label_vector (54):
1707 label_eis_multiple:
1708
1709
1710
1711 flags = fixed (addr (binop) -> opcode_overlay.flags, 4);
1712 full_word_temp = alm_eis_parse_$instruction (binop, flags, rleft);
1713 call putout_$putwrd (pc, full_word_temp, i642, rleft);
1714 goto label_3015;
1715
1716
1717 label_vector (44):
1718 label_get_base:
1719
1720
1721
1722 rslts (1) = sym (1); rslts (2) = sym (2);
1723 call getid_$getid_;
1724 do itemp = 0 to 7;
1725 if sym (1) = symbas (itemp + 1) then goto got_index;
1726 end;
1727 goto get_index;
1728
1729 label_vector (43):
1730 label_get_index:
1731 rslts (1) = sym (1); rslts (2) = sym (2);
1732 call getid_$getid_;
1733
1734 get_index:
1735 if expevl_$expevl_ (0, itemp, iaddr) = 0 then prnte = 1;
1736 if iaddr ^= 0 then prntr = 1;
1737
1738 got_index:
1739 if itemp < 0 | itemp > 7 then do;
1740 prnte = 1;
1741 itemp = 0;
1742 end;
1743 sym (1) = rslts (1); sym (2) = rslts (2);
1744
1745 j = addr (sym) -> acc_string.length + 1;
1746 addr (sym) -> acc_string.length = j;
1747 substr (addr (sym) -> acc_string.chars, j, 1) = substr ("01234567", itemp + 1, 1);
1748 if brk (1) = icomma then brk (1) = isp;
1749 goto label_301;
1750
1751 label_vector (58):
1752 label_entrybound:
1753 eb_data_$entry_bound = spc + fixed(glpl_words(curlc + 3).left, 18);
1754 goto label_3010;
1755
1756
1757
1758
1759 label_vector (0):
1760 label_3000:
1761 if (varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0) then prnte = 1;
1762 rleft = 0;
1763 if (iaddr = 0) then go to label_3008;
1764 value = value + fixed (glpl_words (iaddr + 3).left, 18);
1765
1766
1767
1768 call getbit_$getbit_ (iaddr, basno, b29, rleft);
1769
1770
1771
1772
1773 rleft = rleft * 262144;
1774
1775 label_3008:
1776
1777 call putout_$putwrd (pc, utils_$makins (basno, value, binop, b29, admod), i642, rleft);
1778 goto label_3015;
1779
1780
1781
1782 label_3010:
1783 call prwrd_$source_only;
1784 label_3015:
1785
1786 if (pc = tpc & curlc = tlc) then go to label_3040;
1787 call prnter_$prnter_ ("fatal phase error in pass2.");
1788 call utils_$abort;
1789
1790
1791
1792
1793
1794 label_3040:
1795
1796 call inputs_$next_statement;
1797 go to label_200;
1798
1799
1800
1801
1802
1803
1804 label_3100:
1805
1806 prntf = 1;
1807 go to label_3200;
1808
1809
1810
1811 label_3110:
1812
1813 prntp = 1;
1814 go to label_3200;
1815
1816
1817
1818 label_3120:
1819
1820 prnts = 1;
1821 go to label_3200;
1822
1823
1824
1825 label_3130:
1826
1827 prntu = 1;
1828 go to label_3200;
1829
1830
1831
1832 label_3140:
1833
1834 if curlc = tlc then go to label_3150;
1835 call prnter_$prnter_ ("fatal multiple location counter mismatch in pass2.");
1836 call utils_$abort;
1837
1838 label_3150:
1839
1840 if pc = tpc then go to label_3040;
1841 prntp = 1;
1842 pc = tpc;
1843 go to label_3040;
1844
1845
1846 label_vector (9):
1847 label_dup:
1848 if dup_ptr ^= null () then go to label_3120;
1849 if varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0 then go to label_3120;
1850 if iaddr ^= 0 then go to label_3300;
1851 if value <= 0 then go to label_3120;
1852 dup_count = value - 1;
1853 call prwrd_$prwrd_ (spc + fixed (glpl_words (curlc + 3).left, 18), value, eb_data_$ib6);
1854 call inputs_$next_statement;
1855 call inputs_$get_ptr (dup_ptr, dup_start, junk, end_statement_flag);
1856 go to label_200;
1857
1858 label_vector (10):
1859 label_dupend:
1860 if dup_ptr = null () then go to label_3120;
1861 call inputs_$get_ptr (temp_ptr, i, j, end_statement_flag);
1862 if temp_ptr ^= dup_ptr then go to label_3100;
1863 i = begin_line;
1864 call inputs_$next_statement;
1865 if dup_count > 0 then
1866 call alm_include_file_$insert (addr (dup_string (dup_start)), i - dup_start, dup_count);
1867 dup_ptr = null ();
1868 go to label_200;
1869
1870 label_vector (60):
1871 label_macro:
1872 call getid_$getid_;
1873 if eb_data_$tsym = 0 then goto label_3100;
1874 call oplook_$redefine;
1875 call inputs_$next_statement;
1876 call mexp_$define_macro (addr (sym (1)) -> acc_string.chars);
1877 go to label_200;
1878
1879 label_vector (40):
1880 label_maclist:
1881 call getid_$getid_;
1882 if eb_data_$tsym = eb_data_$ion then
1883 tmacl = "00"b;
1884 else if eb_data_$tsym = eb_data_$ioff then
1885 tmacl = "11"b;
1886 else if eb_data_$tsym = eb_data_$iobject then
1887 tmacl = "10"b;
1888 else if eb_data_$tsym = eb_data_$irestore then do;
1889 eb_data_$macro_listing_control = substr (eb_data_$macro_listing_control, 3);
1890 go to end_maclist;
1891 end;
1892 else go to label_3100;
1893
1894 if brk (1) = icomma then do;
1895 call getid_$getid_;
1896 if eb_data_$tsym = eb_data_$isave then
1897 eb_data_$macro_listing_control = tmacl || eb_data_$macro_listing_control;
1898 else go to label_3100;
1899 end;
1900
1901 else substr (eb_data_$macro_listing_control, 1, 2) = tmacl;
1902
1903 end_maclist:
1904 if eb_data_$macro_depth > 0 then do;
1905 call inputs_$next_statement_nolist;
1906 go to label_200;
1907 end;
1908 else go to label_3300;
1909
1910
1911
1912
1913
1914 label_3200:
1915
1916 if (pc = tpc) then go to label_3210;
1917 prntp = 1;
1918 pc = tpc;
1919
1920 label_3210:
1921
1922 call prwrd_$prwrd_ (spc + fixed (glpl_words (curlc + 3).left, 18), value, eb_data_$ib6);
1923 go to label_3040;
1924
1925
1926
1927 label_3300:
1928
1929 call prwrd_$prwrd_ (spc + fixed (glpl_words (curlc + 3).left, 18), 0, ibb);
1930 go to label_3015;
1931
1932
1933 end pass2_;