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 dcl partl(7) fixed bin;
124 dcl partno fixed bin;
125 dcl report_sw bit(1);
126 dcl (T_01ptr,T_02ptr) ptr;
127 dcl beginptr ptr;
128 dcl depth fixed bin;
129 dcl hold_ct fixed bin;
130 dcl stmtlistptr ptr;
131 dcl elselistptr (10)ptr;
132 dcl if_nest fixed bin;
133 dcl begin_ct fixed bin;
134 dcl set_type fixed bin;
135 dcl 1 hold_list like tree.table;
136 dcl 1 sort_list like tree.table;
137 dcl 1 stmt_list like tree.table;
138 semantics: proc(rulen,altn);
139
140 dcl rulen fixed bin(24),
141 altn fixed bin(24);
142
143 goto rule(rulen);
144
145 dcl bch fixed bin(24);
146 dcl tptr ptr;
147 dcl ki fixed bin(17);
148 dcl li fixed bin(24);
149 dcl ch2 char(2);
150
151 dcl 1 param_list like tree.table;
152 dcl class fixed bin;
153 dcl keyword bit(1);
154 dcl lstop_line fixed bin;
155 dcl dflt_ptr ptr;
156
157
158
159 rule(0001):
160 if (if_nest > 0)
161 then call mrpg_error_(2,(lstk.line(ls_top)),"END reached with ^i unterminated IFs.",if_nest);
162 if (ifi < ife)
163 then do;
164 call mrpg_error_ (1,(linenumber), "Text follows END statment.");
165 ifi = ife+1;
166 end;
167 if (exec.b = exec.e)
168 then do;
169 stmtptr = exec.b;
170 stmtptr = stmt.ref3.e;
171 if (stmt.type = "HD")
172 | (stmt.type = "SR")
173 | (stmt.type = "SU")
174 then stmt.type = "NT";
175 end;
176 return;
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194 rule(0004):
195 paptr, dflt_ptr = null();
196 keyword = "0"b;
197 if (pkey_ct ^= 0)
198 | (ppos_ct ^= 0)
199 then call mrpg_error_ (2,(lstk.line(ls_top-1)),"Only 1 PARAMETER declaration allowed.");
200 return;
201
202
203 rule(0005):
204 call link_list(parm_check,lstk.node_ptr(ls_top-1)->a_list);
205 return;
206
207
208
209 ;
210 rule(0007):
211
212
213 rule(0008):
214 paptr, dflt_ptr = null();
215 keyword = "0"b;
216 return;
217
218
219
220 rule(0009):
221 if (paptr = null())
222 then do;
223 call mrpg_error_ (2,(lstk.line(ls_top -1)),"Missing data-type");
224 return;
225 end;
226 if (param.kind = Bool) & ^keyword
227 then do;
228 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Missing keyword specification on Boolean parameter");
229 end;
230 if (dflt_ptr ^= null) & (param.leng = 0)
231 then do;
232 if (dflt_ptr->symref.type ^= "SY")
233 then do;
234 call mrpg_error_ (2,(lstk.line(ls_top-2)),"Default cannot be an expression on CHAR(*) parameter");
235 end;
236 end;
237 param.line = lstk.line(ls_top-1);
238 param.sym = lstk.node_ptr(ls_top-1);
239 call use_def(paptr);
240 if keyword
241 then do;
242 call link(parm_key,paptr);
243 pkey_ct = pkey_ct + 1;
244 end;
245 else do;
246 call link(parm_pos,paptr);
247 ppos_ct = ppos_ct + 1;
248 end;
249 if dmp_sw then call mrpg_dump_$all((paptr),0);
250 return;
251
252
253 ;
254
255
256
257 rule(0012):
258 bch = ls_top-3;
259 ki = Char;
260 li = 0;
261 goto parm_spec;
262
263
264 rule(0013):
265 bch = ls_top-3;
266 ki = Char;
267 li = lstk.val(ls_top-1);
268 goto parm_spec;
269
270
271 rule(0014):
272 bch = ls_top;
273 ki = Bool;
274 li = -1;
275 parm_spec:
276 call aloc_param(bch);
277 if (param.kind ^= 0)
278 then do;
279 call mrpg_error_ (2,(lstk.line(ls_top)),"Multiple data-type");
280 goto end_parm;
281 end;
282 param.kind = ki;
283 param.leng = li;
284 param.echar = lstk(ls_top).echar;
285 lstk.node_ptr(bch) = paptr;
286 if (ki = Bool)
287 then do;
288 call st_search("""0""b",tptr,"ST",0,0);
289 call aloc_attr(ls_top-1);
290 attr.type = "DV";
291 attr.sym = tptr;
292 call link(param.attr,atptr);
293 param.echar = lstk.echar(ls_top);
294 dflt_ptr = attr.sym;
295 end;
296 goto end_parm;
297
298
299 ;
300 rule(0015):
301 call aloc_param(ls_top-1);
302 call aloc_attr(ls_top-1);
303 attr.type = "DV";
304 attr.sym = lstk.node_ptr(ls_top);
305 call link(param.attr,atptr);
306 param.echar = lstk.echar(ls_top);
307 dflt_ptr = attr.sym;
308 goto end_parm;
309
310
311
312 ;
313
314
315
316 rule(0019):
317 srefptr = lstk.node_ptr(ls_top);
318 if (substr(symref.sym->symtab.data,2,1) ^= "-")
319 then do;
320 call mrpg_error_ (2,(lstk.line(ls_top)),"Keyword ^a does not begin with ""-""",symref.sym->symtab.data);
321 goto end_parm;
322 end;
323 call aloc_param(ls_top);
324 call aloc_attr(ls_top);
325 attr.type = "KY";
326 attr.sym = srefptr;
327 call link(param.attr,atptr);
328 param.echar = lstk.echar(ls_top);
329 keyword = "1"b;
330 end_parm:
331 return;
332
333
334 rule(0020):
335 if (paptr = null())
336 then do;
337 call mrpg_error_ (2,(lstk.line(ls_top)),"No data-type specified.");
338 return;
339 end;
340 call link_list(param.check,lstk.node_ptr(ls_top)->a_list);
341 return;
342
343
344
345 rule(0021):
346 daptr = null();
347 if (tree.input.b ^= null())
348 then call mrpg_error_ (2,(lstk.line(ls_top-1)),"Only 1 INPUT declaration allowed.");
349 return;
350
351
352
353
354
355 ;
356
357 ;
358
359
360 ;;
361
362
363 ;
364
365
366 ;
367
368 ;
369 rule(0034):
370 tree.res_siz = lstk.val(ls_top);
371 tree.rec_str = -1;
372 return;
373
374 ;
375 rule(0035):
376 tree.res_siz = lstk.val(ls_top);
377 tree.rec_str = -2;
378 return;
379
380 ;
381 rule(0036):
382 tree.rec_str = -1;
383 return;
384
385
386 rule(0037):
387 tree.rec_str = -2;
388 return;
389
390
391 ;
392 rule(0038):
393 symbol_leng = 9;
394 allocate symtab in (space);
395 symtab.type = "ST";
396 symtab.use.b, symtab.use.e = null();
397 symtab.data = """vfile_ """;
398 call aloc_opn(Cat,ls_top-1);
399 opn.kind = Char;
400 opn.op1 = symtabptr;
401 opn.op2 = lstk.node_ptr(ls_top);
402 call aloc_value("VL",ls_top-1);
403 value.sym = opptr;
404 value.numb = 0;
405 tree.from = valptr;
406 return;
407
408
409 rule(0039):
410 call aloc_value("VL",ls_top-1);
411 value.sym = lstk.node_ptr(ls_top);
412 tree.from = valptr;
413 return;
414
415 ;
416 ;
417
418 rule(0042):
419
420 rule(0043):
421 call link_list(lstk.node_ptr(ls_top-1)->a_list,lstk.node_ptr(ls_top)->a_list);
422 return;
423
424 dcl 1 a_list based like tree.table;
425
426
427 rule(0044):
428 ^K call mrpg_error_(2,(lstk.line(ls_top-3)),"SKIP not implemented.");
429 call make_bool(ls_top-5);
430 call make_char(ls_top-1);
431 call aloc_opn(Skip,ls_top-7);
432 opn.op1 = lstk.node_ptr(ls_top-5);
433 opn.op2 = lstk.node_ptr(ls_top-1);
434 call aloc_head;
435 call link(head.list,opptr);
436 lstk.node_ptr(ls_top-7) = headptr;
437 return;
438
439
440 rule(0045):
441 ^K call mrpg_error_(2,(lstk.line(ls_top-3)),"STOP not implemented.");
442 call make_bool(ls_top-5);
443 call make_char(ls_top-1);
444 call aloc_opn(Stop,ls_top-7);
445 opn.op1 = lstk.node_ptr(ls_top-5);
446 opn.op2 = lstk.node_ptr(ls_top-1);
447 call aloc_head;
448 call link(head.list,opptr);
449 lstk.node_ptr(ls_top-7) = headptr;
450 return;
451
452
453 ;
454 rule(0046):
455 ;
456 rule(0047):
457 call link_list(datum.check,lstk.node_ptr(ls_top)->a_list);
458 lstop_line = ls_top - 2;
459 goto ifld_com;
460
461 ;
462 rule(0048):
463 call link_list(lstk.node_ptr(ls_top-1)->a_list,lstk.node_ptr(ls_top)->a_list);
464 call link_list(datum.check,lstk.node_ptr(ls_top-1)->a_list);
465 lstop_line = ls_top - 3;
466 goto ifld_com;
467
468
469 rule(0049):
470 lstop_line = ls_top - 1;
471 ifld_com:
472 if (daptr = null())
473 then do;
474 call mrpg_error_ (2,(lstk.line(lstop_line)),"Missing data-type");
475 return;
476 end;
477 datum.sym = lstk.node_ptr(lstop_line);
478 indcl:
479 datum.type = "IN";
480 datum.line = lstk.line(lstop_line);
481 if (datum.sym ^= null())
482 then call use_def(daptr);
483 call link(tree.input,daptr);
484 daptr = null();
485 return;
486
487 ;
488 rule(0050):
489 call aloc_datum;
490 datum.pos = lstk.val(ls_top);
491 datum.kind = Char;
492 datum.leng = lstk.val(ls_top-3);
493 return;
494
495 ;
496 rule(0051):
497 call aloc_datum;
498 datum.kind = Char;
499 datum.leng = lstk.val(ls_top-1);
500 return;
501
502
503 rule(0052):
504 call aloc_datum;
505 datum.kind = Char;
506 datum.leng = -lstk.val(ls_top-2);
507 return;
508
509 ;
510 rule(0053):
511 call aloc_datum;
512 datum.kind = Chard;
513 datum.leng = lstk.val(ls_top-3);
514 call link(datum.datal, lstk.node_ptr(ls_top));
515 return;
516
517
518 rule(0054):
519 call aloc_datum;
520 datum.kind = Chard;
521 datum.leng = -lstk.val(ls_top-4);
522 call link(datum.datal, lstk.node_ptr(ls_top-1));
523 return;
524
525 ;
526 rule(0055):
527 call aloc_datum;
528 datum.kind = Charn;
529 datum.leng = lstk.val(ls_top-2);
530 return;
531
532
533 rule(0056):
534 call aloc_datum;
535 datum.kind = Charn;
536 datum.leng = -lstk.val(ls_top-3);
537 return;
538
539
540 rule(0057):
541 call aloc_datum;
542 datum.kind = Char;
543 datum.leng = -lstk.val(ls_top-4);
544 datum.pos = lstk.val(ls_top);
545 return;
546
547 ;
548 rule(0058):
549 call aloc_datum;
550 datum.kind = Chard;
551 datum.leng = lstk.val(ls_top-5);
552 call link(datum.datal, lstk.node_ptr(ls_top-2));
553 datum.pos = lstk.val(ls_top);
554 return;
555
556
557 rule(0059):
558 call aloc_datum;
559 datum.kind = Chard;
560 datum.leng = -lstk.val(ls_top-6);
561 call link(datum.datal, lstk.node_ptr(ls_top-3));
562 datum.pos = lstk.val(ls_top);
563 return;
564
565 ;
566 rule(0060):
567 call aloc_datum;
568 datum.kind = Charn;
569 datum.leng = lstk.val(ls_top-4);
570 datum.pos = lstk.val(ls_top);
571 return;
572
573
574 rule(0061):
575 call aloc_datum;
576 datum.kind = Charn;
577 datum.leng = -lstk.val(ls_top-5);
578 datum.pos = lstk.val(ls_top);
579 return;
580
581 ;
582 rule(0062):
583 call aloc_datum;
584 datum.pos = lstk.val(ls_top);
585 datum.kind = Decimal;
586 datum.leng = lstk.val(ls_top-3);
587 return;
588
589 ;
590 rule(0063):
591 call aloc_datum;
592 datum.kind = Decimal;
593 datum.leng = lstk.val(ls_top-1);
594 return;
595
596
597 rule(0064):
598 call aloc_datum;
599 datum.kind = Decimal;
600 datum.leng = -lstk.val(ls_top-2);
601 return;
602
603 ;
604 rule(0065):
605 call aloc_datum;
606 datum.kind = DecSpec;
607 datum.leng = 0;
608 return;
609
610
611 rule(0066):
612 call aloc_datum;
613 datum.kind = DecSpec;
614 datum.leng = -1;
615 return;
616
617
618 rule(0067):
619 call aloc_datum;
620 datum.kind = Decimal;
621 datum.leng = -lstk.val(ls_top-4);
622 datum.pos = lstk.val(ls_top);
623 return;
624
625 ;
626 rule(0068):
627 call aloc_datum;
628 datum.kind = DecSpec;
629 datum.leng = 0;
630 datum.pos = lstk.val(ls_top);
631 return;
632
633
634 rule(0069):
635 call aloc_datum;
636 datum.kind = DecSpec;
637 datum.leng = -1;
638 datum.pos = lstk.val(ls_top);
639 return;
640
641 ;
642 rule(0070):
643 call aloc_datum;
644 datum.kind = Decimal;
645 call link(datum.datal, lstk.node_ptr(ls_top));
646 return;
647
648
649 rule(0071):
650 call aloc_datum;
651 datum.kind = Decimal;
652 datum.leng = -1;
653 call link(datum.datal, lstk.node_ptr(ls_top-1));
654 return;
655
656 ;
657 rule(0072):
658 call aloc_datum;
659 datum.kind = Decimal;
660 call link(datum.datal, lstk.node_ptr(ls_top-2));
661 datum.pos = lstk.val(ls_top);
662 return;
663
664
665 rule(0073):
666 call aloc_datum;
667 datum.kind = Decimal;
668 datum.leng = -1;
669 call link(datum.datal, lstk.node_ptr(ls_top-3));
670 datum.pos = lstk.val(ls_top);
671 return;
672
673 ;
674 rule(0074):
675 call aloc_datum;
676 datum.kind = Fill;
677 datum.leng = lstk.val(ls_top-1);
678 datum.sym = null();
679 lstop_line = ls_top - 3;
680 goto indcl;
681
682
683
684 rule(0075):
685 call aloc_datum;
686 datum.type = "DC";
687 return;
688
689
690 rule(0076):
691 datum.sym = lstk.node_ptr(ls_top-2);
692 datum.line = lstk.line(ls_top-2);
693 call use_def(daptr);
694 call link(tree.local,daptr);
695 daptr = null();
696 return;
697
698
699 ;
700 rule(0077):
701 datum.kind = Decimal;
702 datum.echar = lstk.echar(ls_top);
703 return;
704
705
706 rule(0078):
707 datum.kind = Char;
708 datum.leng = lstk.val(ls_top-1);
709 datum.echar = lstk.echar(ls_top);
710 return;
711
712 ;
713 rule(0079):
714 datum.kind = Charn;
715 datum.leng = lstk.val(ls_top-2);
716 datum.echar = lstk.echar(ls_top);
717 return;
718
719 ;
720 rule(0080):
721 datum.kind = Bool;
722 datum.echar = lstk.echar(ls_top);
723 return;
724
725 ;
726 rule(0081):
727 datum.kind = Set;
728 return;
729
730 ;
731 rule(0082):
732 if (datum.kind = 0)
733 then datum.kind = Table;
734 return;
735
736
737 rule(0083):
738 if (datum.kind = 0)
739 then datum.kind = Tablev;
740 return;
741
742
743
744 ;
745
746
747
748 rule(0087):
749 opptr = datum.datal.b;
750 if (opptr ^= null())
751 then if (opn.op ^= n_n)
752 then do;
753 call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
754 return;
755 end;
756
757 call aloc_opn(n_n,ls_top-2);
758 opn.kind = Decimal;
759 opn.op1 = lstk.node_ptr(ls_top-2);
760 opn.op2 = lstk.node_ptr(ls_top);
761 call link(datum.datal,opptr);
762 return;
763
764
765
766
767 ;
768
769
770
771 rule(0091):
772 opptr = datum.datal.b;
773 if (opptr ^= null())
774 then if (opn.op ^= n_s)
775 then do;
776 call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
777 return;
778 end;
779 call aloc_opn(n_s,ls_top-2);
780 opn.kind = Char;
781 opn.op1 = lstk.node_ptr(ls_top-2);
782 opn.op2 = lstk.node_ptr(ls_top);
783 call link(datum.datal,opptr);
784 return;
785
786
787
788 ;
789
790
791
792 rule(0095):
793 opptr = datum.datal.b;
794 if (opptr ^= null())
795 then if (opn.op ^= s_n)
796 then do;
797 call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
798 return;
799 end;
800 call aloc_opn(s_n,ls_top-2);
801 opn.kind = Decimal;
802 opn.op1 = lstk.node_ptr(ls_top-2);
803 opn.op2 = lstk.node_ptr(ls_top);
804 call link(datum.datal,opptr);
805 return;
806
807
808
809
810 ;
811
812
813
814 rule(0099):
815 opptr = datum.datal.b;
816 if (opptr ^= null())
817 then if (opn.op ^= s_s)
818 then do;
819 call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
820 return;
821 end;
822 call aloc_opn(s_s,ls_top-2);
823 opn.kind = Char;
824 opn.op1 = lstk.node_ptr(ls_top-2);
825 opn.op2 = lstk.node_ptr(ls_top);
826 call link(datum.datal,opptr);
827 return;
828
829
830 rule(0100):
831 allocate report in (space);
832 report.type = "RP";
833 report.onlist.b, report.onlist.e = null();
834 report.brlist.b, report.brlist.e = null();
835 report.part.b, report.part.e = null();
836 report.line = lstk.line(ls_top-1);
837 report.sym = lstk.node_ptr(ls_top);
838 report.minl = -1;
839 report.maxl = -1;
840 partl = 0;
841 report.pw = 65;
842 report.pl = 66;
843 hold_list.b, hold_list.e = null();
844 call use_def(repptr);
845 return;
846
847
848
849
850
851
852
853
854
855 rule(0101):
856 if (report.maxl = -1)
857 then report.maxl = report.pl;
858 if (report.minl = -1)
859 then report.minl = min(1,report.pl);
860 if (report.minl > report.maxl)
861 then call mrpg_error_ (2,(lstk.line (ls_top-5)), "Effective MINLINE > effective MAXLINE.");
862 report.echar = lstk.echar(ls_top);
863 call link(tree.report,repptr);
864 if (report.onlist.b = null())
865 then do;
866 call st_search("""user_output""",tptr,"ST",0,0);
867 call aloc_value("SW",ls_top-5);
868 value.sym = tptr;
869 call linkr(report.onlist,valptr);
870 end;
871 repptr = null();
872 return;
873
874
875 ;
876
877
878 ;
879
880
881 ;
882 rule(0106):
883 report.pw = lstk.val(ls_top);
884 return;
885
886 ;
887 rule(0107):
888 report.pl = lstk.val(ls_top);
889 return;
890
891 ;
892 rule(0108):
893 report.minl = lstk.val(ls_top);
894 return;
895
896 ;
897 rule(0109):
898 report.maxl = lstk.val(ls_top);
899 return;
900
901 ;
902 rule(0110):
903 report.brlist = hold_list;
904 hold_list.b, hold_list.e = null();
905 return;
906
907 ;
908 rule(0111):
909 call linkr(report.onlist,lstk.node_ptr(ls_top));
910 return;
911
912
913
914 ;
915 rule(0113):
916 call linkr(report.onlist,lstk.node_ptr(ls_top));
917 return;
918
919
920 rule(0114):
921 call make_bool(ls_top-3);
922 valptr = lstk.node_ptr(ls_top - 6);
923 value.ctl = lstk.node_ptr (ls_top-3);
924 call linkr(report.onlist,valptr);
925 lstk.node_ptr (ls_top-6) = lstk.node_ptr(ls_top);
926 return;
927
928 ;
929 rule(0115):
930 call aloc_value("FL",ls_top-1);
931 value.sym = lstk.node_ptr(ls_top);
932 lstk.node_ptr (ls_top - 1) = valptr;
933 return;
934
935 ;
936 rule(0116):
937 ^K call mrpg_error_(2,(lstk.line(ls_top-1)),"FILE...NUMBER not implemented.");
938 call aloc_value("FL",ls_top-3);
939 value.sym = lstk.node_ptr(ls_top-2);
940 value.numb = lstk.val(ls_top);
941 lstk.node_ptr (ls_top - 3) = valptr;
942 return;
943
944
945 rule(0117):
946 call aloc_value("SW",ls_top-1);
947 value.sym = lstk.node_ptr(ls_top);
948 lstk.node_ptr (ls_top - 1) = valptr;
949 return;
950
951
952 ;
953
954
955 ;
956
957
958 ;
959 ;
960
961 rule(0124):
962 ch2 = "RH";
963 partno = 1;
964 goto part_common;
965
966
967 rule(0125):
968 ch2 = "PH";
969 partno = 2;
970 goto part_common;
971
972
973 rule(0126):
974 if (report.brlist.b = null())
975 then do;
976 call mrpg_error_ (2,(lstk(ls_top).line), "No break fields specified in this report.");
977 return;
978 end;
979 ch2 = "DH";
980 partno = 3;
981 goto part_common;
982
983
984 rule(0127):
985 ch2 = "DT";
986 partno = 4;
987 goto part_common;
988
989
990 rule(0128):
991 if (report.brlist.b = null())
992 then do;
993 call mrpg_error_ (2,(lstk(ls_top).line), "No break fields specified in this report.");
994 return;
995 end;
996 ch2 = "DF";
997 partno = 5;
998 goto part_common;
999
1000
1001 rule(0129):
1002 ch2 = "PF";
1003 partno = 6;
1004 goto part_common;
1005
1006
1007 rule(0130):
1008 ch2 = "RF";
1009 partno = 7;
1010 part_common:
1011 allocate part in (space);
1012 part.type = ch2;
1013 part.ctl = null();
1014 part.maxl = 0;
1015 part.lines.b, part.lines.e = null();
1016 part.sym = null();
1017 call link(report.part,partptr);
1018 return;
1019
1020
1021 rule(0131):
1022 ;
1023 rule(0132):
1024 part.sym = lstk.node_ptr(ls_top-1);
1025 call use_ref((part.sym));
1026 if (break_number (lstk.node_ptr (ls_top-1)) = 0)
1027 then call mrpg_error_ (2,(lstk.line (ls_top-1)), "Identifier ""^a"" is not a break field in this report",pull_name(ls_top-1));
1028 return;
1029
1030
1031 ;
1032
1033
1034
1035 rule(0135):
1036 part.sym = lstk.node_ptr(ls_top-1);
1037 part.line = lstk.line(ls_top-1);
1038 call use_def(partptr);
1039 return;
1040
1041
1042 rule(0136):
1043 part.sym = lstk.node_ptr(ls_top);
1044 part.line = lstk.line(ls_top);
1045 call use_def(partptr);
1046 return;
1047
1048
1049
1050
1051
1052
1053
1054 ;
1055
1056
1057
1058
1059 rule(0141):
1060 part.ctl = lstk(ls_top-1).node_ptr;
1061 return;
1062
1063 ;
1064 rule(0142):
1065 part.maxl = lstk(ls_top).val;
1066 return;
1067
1068
1069 rule(0143):
1070 ^K call mrpg_error_(2,(lstk.line(ls_top)),"FIT not implemented.");
1071 return;
1072
1073
1074 ;
1075
1076
1077 ;
1078
1079
1080 ;
1081
1082
1083 ;
1084
1085
1086
1087 rule(0152):
1088 allocate lines in (space);
1089 lines.type = "LN";
1090 lines.ctl = null();
1091 lines.field.b, lines.field.e = null();
1092 lines.number = 1;
1093 call link(part.lines,linptr);
1094 return;
1095
1096
1097 rule(0153):
1098 partl (partno) = partl (partno) + 1;
1099 if (partno = 2)
1100 then do;
1101 if (partl(2) = 1)
1102 then do;
1103 if (lines.number > 0)
1104 then do;
1105 call mrpg_error_ (2,(lstk.line(ls_top-2)), "First PAGEHEAD must have absolute line number.");
1106 return;
1107 end;
1108 end;
1109 return;
1110 end;
1111 if (partno = 6)
1112 then do;
1113 if (partl(6) = 1)
1114 then do;
1115 if (lines.number > 0)
1116 then do;
1117 call mrpg_error_ (2,(lstk.line(ls_top-2)), "First PAGEFOOT must have absolute line number.");
1118 return;
1119 end;
1120 if (report.maxl = -1)
1121 then report.maxl = -lines.number - 1;
1122 else if (-lines.number < report.maxl)
1123 then call mrpg_error_(2,(lstk.line(ls_top-2)),"Page footing starts above MAXLINE.");
1124 end;
1125 return;
1126 end;
1127 return;
1128
1129
1130 ;
1131
1132
1133
1134 rule(0156):
1135 call make_bool(ls_top-1);
1136 lines.number = -lstk.val(ls_top-4);
1137 lines.ctl = lstk.node_ptr(ls_top-1);
1138 goto check_absolute;
1139
1140
1141 rule(0157):
1142 call make_bool(ls_top-1);
1143 lines.number = lstk.val(ls_top-4);
1144 lines.ctl = lstk.node_ptr(ls_top-1);
1145 return;
1146
1147 ;
1148 rule(0158):
1149 lines.number = -lstk.val(ls_top);
1150 check_absolute:
1151 if (-lines.number > report.pl)
1152 then do;
1153 call mrpg_error_ (2,(lstk.line(ls_top)), "Absolute line number beyond end-of-page.");
1154 end;
1155 return;
1156
1157 ;
1158 rule(0159):
1159 lines.number = lstk.val(ls_top);
1160 return;
1161
1162
1163 rule(0160):
1164 call make_bool(ls_top-1);
1165 lines.ctl = lstk.node_ptr(ls_top-1);
1166 return;
1167
1168 ;
1169 rule(0161):
1170 call make_bool(ls_top-1);
1171 lines.ctl = lstk.node_ptr(ls_top-1);
1172
1173 rule(0162):
1174 lines.number = 0;
1175
1176 return;
1177
1178
1179 ;
1180
1181
1182 ;
1183
1184
1185
1186 rule(0167):
1187 if (lines.number = 0)
1188 then do;
1189 call mrpg_error_ (2,(lstk.line(ls_top)),"LINE 0 and LINE PAUSE cannot have any fields specified.");
1190 lines.number = 1;
1191 end;
1192 allocate field in (space);
1193 field.type = "FD";
1194 field.alch = "";
1195 field.value.b, field.value.e = null();
1196 field.let.b, field.let.e = null();
1197 field.data = null();
1198 field.bsp = "0"b;
1199 call link(lines.field,fldptr);
1200 report_sw = "1"b;
1201 return;
1202
1203
1204 ;
1205 rule(0168):
1206 li = ls_top-1;
1207 goto field_1;
1208
1209
1210 ;
1211 rule(0169):
1212 li = ls_top;
1213 field_1:
1214 field.line = lstk.line(li);
1215 if (lstk.datype(li) = BOOL)
1216 then call make_char(li);
1217 tptr = lstk.node_ptr(li);
1218 if (tptr = null())
1219 then return;
1220 if (tptr->symref.type = "OP")
1221 then do;
1222 if (lstk.datype(li) = DEC)
1223 then call st_search("D_01",T_01ptr,"ID",Decimal,0);
1224 else call st_search("T_01",T_01ptr,"ID",Chard,256);
1225 call aloc_stmt(":=",ls_top);
1226 call link (stmt.ref1,T_01ptr);
1227 call link (stmt.ref2,lstk.node_ptr(li));
1228 call link (field.value,stmtptr);
1229 end;
1230 else do;
1231 call aloc_value("VL",ls_top);
1232 value.sym = tptr;
1233 call link (field.value,valptr);
1234 end;
1235 if dmp_sw then call mrpg_dump_$all((fldptr),0);
1236 report_sw = "0"b;
1237 if (field.value.b->stmt.type = ":=")
1238 then do;
1239 tptr = field.value.b->stmt.ref1.b;
1240 call link_list(field.let,field.value);
1241 call aloc_value("VL",ls_top-1);
1242 value.sym = tptr;
1243 field.value.b, field.value.e = null();
1244 call link (field.value, valptr);
1245 if (field.kind = 0)
1246 then field.kind = Chard;
1247 end;
1248 if (field.kind = Pic)
1249 then do;
1250 ch2 = "cP";
1251 goto pe_field;
1252 end;
1253 if (field.kind = Edit)
1254 then do;
1255 ch2 = "cE";
1256 pe_field:
1257 call st_search("T_02",T_02ptr,"ID",Chard,256);
1258 call aloc_stmt(ch2,ls_top);
1259 call link(stmt.ref1,T_02ptr);
1260 call link(stmt.ref2,(field.value.b));
1261 call link(stmt.ref2,(field.data));
1262 call link(field.let,stmtptr);
1263 call aloc_value("VL",ls_top-1);
1264 value.sym = T_02ptr;
1265 field.value.b, field.value.e = null();
1266 call link (field.value, valptr);
1267 field.kind = Chard;
1268 end;
1269 valptr = field.value.b;
1270 if (value.type = "VL")
1271 then do;
1272 srefptr = value.sym;
1273 if (symref.type = "SY")
1274 then do;
1275 symtabptr = symref.sym;
1276 if (symtab.type = "ST")
1277 then if (index(symtab.data,BSP) ^= 0)
1278 then field.bsp = "1"b;
1279 end;
1280 end;
1281 fldptr = null();
1282 return;
1283 dcl BSP char(1) int static init("^H");
1284
1285
1286 ;
1287
1288
1289
1290 rule(0172):
1291 if (field.kind ^= 0)
1292 then do;
1293 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple data-type");
1294 return;
1295 end;
1296 symtabptr = lstk.node_ptr(ls_top)->symref.sym;
1297 call check_picture;
1298 field.kind = Pic;
1299 field.data = lstk.node_ptr(ls_top);
1300 return;
1301
1302 check_picture: proc;
1303
1304 dcl info char(100);
1305 dcl pic char(symtab.leng-2);
1306 dcl picture_info_ entry (char(*),ptr,fixed bin);
1307
1308 pic = substr(symtab.data,2);
1309 call picture_info_(pic,addr(info),ki);
1310 if (ki = 0)
1311 then return;
1312 if (ki = 414)
1313 then call mrpg_error_(2,(lstk.line(ls_top)),"Normalized picture > 64 characters. ""^a""",pic);
1314 else if (ki = 434)
1315 then call mrpg_error_(2,(lstk.line(ls_top)),"Picture scale factor outside range -128:+127 ""^a""",pic);
1316 else call mrpg_error_(2,(lstk.line(ls_top)),"Syntax error in picture. ""^a""",pic);
1317 return;
1318
1319 end check_picture;
1320
1321
1322 rule(0173):
1323 call mrpg_error_(2,(lstk.line(ls_top-1)),"EDIT not implemented");
1324 if (field.kind ^= 0)
1325 then do;
1326 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple data-type");
1327 return;
1328 end;
1329 field.kind = Edit;
1330 field.data = lstk.node_ptr(ls_top);
1331 return;
1332
1333
1334 rule(0174):
1335 if (field.kind ^= 0)
1336 then do;
1337 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple data-type");
1338 return;
1339 end;
1340 field.kind = Char;
1341 field.leng = lstk.val(ls_top-1);
1342 return;
1343
1344
1345
1346 rule(0175):
1347 min_paren = 1;
1348 report_sw = "0"b;
1349 return;
1350
1351
1352 ;
1353 rule(0176):
1354 min_paren = 0;
1355 report_sw = "1"b;
1356 return;
1357
1358 ;
1359 rule(0177):
1360 field.col = lstk.val(ls_top);
1361 return;
1362
1363
1364 ;
1365 rule(0178):
1366 field.bsp = "1"b;
1367 return;
1368
1369 ;
1370 rule(0179):
1371 if (field.align ^= 0)
1372 then do;
1373 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
1374 return;
1375 end;
1376 field.align = Left;
1377 return;
1378
1379 ;
1380 rule(0180):
1381 if (field.align ^= 0)
1382 then do;
1383 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
1384 return;
1385 end;
1386 field.align = Center;
1387 return;
1388
1389 ;
1390 rule(0181):
1391 if (field.align ^= 0)
1392 then do;
1393 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
1394 return;
1395 end;
1396 field.align = Right;
1397 return;
1398
1399 ;
1400 rule(0182):
1401 ^K call mrpg_error_(2,(lstk.line(ls_top)),"FILL not implemented.");
1402 if (field.align ^= 0)
1403 then do;
1404 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
1405 return;
1406 end;
1407 field.align = Fill;
1408 return;
1409
1410 ;
1411 rule(0183):
1412 ^K call mrpg_error_(2,(lstk.line(ls_top-5)),"FILL not implemented.");
1413 if (field.align ^= 0)
1414 then do;
1415 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
1416 return;
1417 end;
1418 field.align = Fill;
1419 field.fill(1) = lstk.val(ls_top-3);
1420 field.fill(2) = lstk.val(ls_top-1);
1421 return;
1422
1423 ;
1424 rule(0184):
1425 if (field.align ^= 0)
1426 then do;
1427 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
1428 return;
1429 end;
1430 field.align = Align;
1431 tptr = lstk.node_ptr(ls_top);
1432 if (tptr ^= null())
1433 then do;
1434 if (tptr->symref.sym->symtab.leng ^= 3)
1435 then call mrpg_error_ (2,(lstk.line(ls_top-1)),"Align string more than 1 character");
1436 field.alch = substr(tptr->symref.sym->symtab.data,2,1);
1437 end;
1438 return;
1439
1440
1441 rule(0185):
1442 ^K call mrpg_error_(2,(lstk.line(ls_top)),"FOLD not implemented.");
1443 if (field.align ^= 0)
1444 then do;
1445 call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
1446 return;
1447 end;
1448 field.align = Fold;
1449 return;
1450
1451
1452
1453 rule(0186):
1454 if (if_nest > 0)
1455 then do;
1456 call mrpg_error_(2,(lstk.line(ls_top)),"BEGIN preceded by ^i unterminated IFs.",if_nest);
1457 end;
1458 call aloc_stmt("BG",ls_top);
1459 beginptr = stmtptr;
1460 begin_ct = begin_ct + 1;
1461 stmtlistptr = addr(stmt.ref3);
1462 stmt_list.b, stmt_list.e = null();
1463 min_paren = 1;
1464 return;
1465
1466
1467 rule(0187):
1468 min_paren = 0;
1469 return;
1470
1471
1472
1473
1474
1475 rule(0188):
1476 call link(exec,beginptr);
1477 beginptr = null();
1478 return;
1479
1480 ;
1481 rule(0189):
1482 if (begin_ct > 1)
1483 then call mrpg_error_ (2,(lstk.line(ls_top-4)),"No useful statements in this phase.");
1484 return;
1485
1486
1487
1488 ;
1489
1490
1491 rule(0193):
1492 if_nest = if_nest + 1;
1493 call aloc_stmt("IF",ls_top-2);
1494 call link(stmtlistptr->a_list,stmtptr);
1495 call link(stmt.ref1,lstk.node_ptr(ls_top-1));
1496 lstk.node_ptr(ls_top-2) = stmtlistptr;
1497 stmtlistptr = addr(stmt.ref2);
1498 elselistptr (if_nest) = addr(stmt.ref3);
1499 return;
1500
1501
1502 rule(0194):
1503 stmtlistptr = elselistptr (if_nest);
1504 return;
1505
1506 ;
1507 rule(0195):
1508 call make_bool(ls_top-4);
1509 if_nest = if_nest - 1;
1510 stmtlistptr = lstk.node_ptr(ls_top-5);
1511 return;
1512
1513 ;
1514 rule(0196):
1515 if_nest = if_nest - 1;
1516 stmtlistptr = lstk.node_ptr(ls_top-4);
1517 call mrpg_error_(0,(lstk.line(ls_top-4)),"Is the ""IF"" terminated.");
1518 return;
1519
1520
1521 rule(0197):
1522 call make_bool(ls_top-6);
1523 if_nest = if_nest - 1;
1524 stmtlistptr = lstk.node_ptr(ls_top-7);
1525 return;
1526
1527
1528 rule(0198):
1529 if_nest = if_nest - 1;
1530 stmtlistptr = lstk.node_ptr(ls_top-6);
1531 call mrpg_error_(0,(lstk.line(ls_top-6)),"Is the ""IF"" terminated.");
1532 return;
1533
1534 ;
1535 rule(0199):
1536 call link(stmtlistptr->a_list,lstk.node_ptr(ls_top));
1537 return;
1538
1539 ;
1540 rule(0200):
1541 call aloc_stmt("PR",ls_top-2);
1542 call link(stmt.ref1, lstk.node_ptr(ls_top-1));
1543 tptr = lstk.node_ptr(ls_top-1);
1544 call use_ref((tptr));
1545 ch2 = tptr->symref.sym->symtab.use.b->datum.type;
1546 if (ch2 ^= "RP") & (ch2 ^= "DT")
1547 then do;
1548 call mrpg_error_ (2,(tptr->symref.line),"The ^a name ""^a"" cannot be the object of a PRINT statement."
1549 ,dt_s(lstk.datype(ls_top)),pull_name(ls_top-1));
1550 end;
1551 call link(stmtlistptr->a_list,stmtptr);
1552 return;
1553
1554
1555
1556 rule(0202):
1557 call mrpg_error_(2,(lstk.line(ls_top)),"Extra THEN present.");
1558 return;
1559
1560
1561 rule(0203):
1562 hold_list.b, hold_list.e = null();
1563 return;
1564
1565 ;
1566 rule(0204):
1567 if (begin_ct = 1)
1568 then do;
1569 call hold_input;
1570 goto hold_common;
1571 end;
1572 return;
1573
1574
1575 rule(0205):
1576 if (begin_ct = 1)
1577 then call hold_input;
1578 goto hold_common;
1579
1580
1581 rule(0206):
1582 if (begin_ct ^= 1)
1583 then do;
1584 call mrpg_error_ (2,(lstk.line(ls_top-2)),"HOLD values allowed only in first phase.");
1585 hold_list.b, hold_list.e = null();
1586 end;
1587 hold_common:
1588 call aloc_stmt("HD",ls_top);
1589 stmt.ref1 = hold_list;
1590 call link(stmtlistptr->a_list,stmtptr);
1591 hold_list.b, hold_list.e = null();
1592 return;
1593
1594 ;
1595 rule(0207):
1596 ch2 = "SR";
1597 li = -1;
1598 goto sort_common;
1599
1600
1601 rule(0208):
1602 if (begin_ct = 1)
1603 then call mrpg_error_ (2,(lstk.line(ls_top)),"SORT not allowed in first phase.");
1604 return;
1605
1606 ;
1607 rule(0209):
1608 ch2 = "SR";
1609 li = 2;
1610 goto sort_common;
1611
1612 ;
1613 rule(0210):
1614 ch2 = "SU";
1615 li = 4;
1616 sort_common:
1617 call aloc_stmt(ch2,ls_top-li);
1618 stmt.ref2 = sort_list;
1619 call link (stmtlistptr->a_list,stmtptr);
1620 sort_list.b, sort_list.e = null();
1621 return;
1622
1623 ;
1624
1625
1626 ;
1627 rule(0213):
1628 allocate attr in (space);
1629 attr.type = "KY";
1630 attr.asc = "1"b;
1631 ki = ls_top;
1632 sortkey:
1633 attr.sym = lstk.node_ptr(ki);
1634 if (lstk.datype(ki) = 0)
1635 | (lstk.datype(ki) > DEC)
1636 then do;
1637 call mrpg_error_(2,lstk.line(ki),"The ^a name ""^a"" cannot be a sort key."
1638 ,dt_s(lstk.datype(ki)),pull_name(ki));
1639 return;
1640 end;
1641 call use_ref((attr.sym));
1642 call link(sort_list,atptr);
1643 return;
1644
1645 ;
1646 rule(0214):
1647 allocate attr in (space);
1648 attr.type = "KY";
1649 attr.asc = "1"b;
1650 ki = ls_top-1;
1651 goto sortkey;
1652
1653
1654 rule(0215):
1655 allocate attr in (space);
1656 attr.type = "KY";
1657 attr.des = "1"b;
1658 ki = ls_top-1;
1659 goto sortkey;
1660
1661 ;
1662
1663 ;
1664 rule(0218):
1665
1666 rule(0219):
1667 tptr = lstk.node_ptr(ls_top);
1668 if (fldptr ^= null())
1669 then do;
1670 call link(field.let,tptr);
1671 end;
1672 else do;
1673 call link(beginptr->stmt.ref1,tptr);
1674 end;
1675 return;
1676
1677 ;
1678 rule(0220):
1679 goto cv_assign(lstk.datype(ls_top-3));
1680 cv_assign(0):
1681 cv_assign(4):
1682 cv_assign(5):
1683 cv_assign(6):
1684 cv_assign(7):
1685 call mrpg_error_(2,(lstk.line(ls_top-3)),"The ^a name ""^a"" cannot be the object of an assignment."
1686 ,dt_s(lstk.datype(ls_top-3)),pull_name(ls_top-3));
1687 return;
1688
1689 cv_assign(1):
1690 call make_bool(ls_top-1);
1691 goto cvassign;
1692
1693 cv_assign(2):
1694 if (lstk.node_ptr(ls_top-3)->symref.sym->symtab.use.b->datum.kind = Pic)
1695 then goto cvassign;
1696 if (lstk.datype(ls_top-1) = DEC)
1697 then do;
1698 call aloc_stmt("=:",ls_top-3);
1699 goto cvassign1;
1700 end;
1701 call make_char(ls_top-1);
1702 goto cvassign;
1703
1704 cv_assign(3):
1705 call make_dec(ls_top-1);
1706
1707 cvassign:
1708
1709 call aloc_stmt(":=",ls_top-3);
1710 cvassign1:
1711 call link(stmt.ref1, lstk.node_ptr(ls_top-3));
1712 call use_ref((lstk.node_ptr(ls_top-3)));
1713 call link(stmt.ref2, lstk.node_ptr(ls_top-1));
1714 lstk.node_ptr(ls_top-3) = stmtptr;
1715 return;
1716
1717
1718
1719 rule(0221):
1720
1721 rule(0222):
1722
1723 rule(0223):
1724
1725 rule(0224):
1726 depth = depth + 1;
1727 return;
1728
1729 ;
1730 rule(0225):
1731 depth = depth - 1;
1732 if (lstk.datype(ls_top-1) ^= TABLE)
1733 then do;
1734 call mrpg_error_(2,(lstk.line(ls_top-1)),"TRANSFORM must reference a table.");
1735 return;
1736 end;
1737 call use_ref ((lstk.node_ptr(ls_top-1)));
1738 ki = lstk.node_ptr(ls_top-1)->symref.sym->symtab.use.b->datum.datal.b->opn.op;
1739 if (ki = n_n)
1740 then do;
1741 call make_dec(ls_top-3);
1742 lstk.datype(ls_top-5) = DEC;
1743 end;
1744 else if (ki = n_s)
1745 then do;
1746 call make_dec(ls_top-3);
1747 lstk.datype(ls_top-5) = CHAR;
1748 end;
1749 else if (ki = s_n)
1750 then do;
1751 call make_char(ls_top-3);
1752 lstk.datype(ls_top-5) = DEC;
1753 end;
1754 else if (ki = s_s)
1755 then do;
1756 call make_char(ls_top-3);
1757 lstk.datype(ls_top-5) = CHAR;
1758 end;
1759 else do;
1760 call mrpg_error_(3,(lstk.line(ls_top-5)),"Bad table type.");
1761 return;
1762 end;
1763 call aloc_opn(Tran,ls_top-5);
1764 opn.kind = lstk.node_ptr(ls_top-1)->symref.kind;
1765 opn.op1 = lstk.node_ptr(ls_top-1);
1766 opn.op2 = lstk.node_ptr(ls_top-3);
1767 lstk.node_ptr(ls_top-5) = opptr;
1768 return;
1769
1770 ;
1771 rule(0226):
1772
1773 rule(0227):
1774 call link(hold_list,lstk.node_ptr(ls_top));
1775 call use_ref((lstk.node_ptr(ls_top)));
1776 return;
1777
1778
1779 rule(0228):
1780 call hold_input;
1781 return;
1782
1783 hold_input: proc;
1784 do daptr = tree.input.b
1785 repeat (datum.next)
1786 while (daptr ^= null());
1787 if (datum.sym ^= null())
1788 then do;
1789 allocate symref in (space);
1790 symref = datum.sym->symref;
1791 symref.next = null();
1792 call link(hold_list,srefptr);
1793 call use_ref(srefptr);
1794 end;
1795 end;
1796 end hold_input;
1797
1798 ;
1799 rule(0229):
1800 call make_bool (ls_top-2);
1801 call make_bool (ls_top);
1802 call aloc_opn(Or,ls_top-2);
1803 opn.kind = Bool;
1804 opn.op1 = lstk.node_ptr(ls_top-2);
1805 opn.op2 = lstk.node_ptr(ls_top);
1806 lstk.node_ptr(ls_top-2) = opptr;
1807 lstk.datype(ls_top-2) = BOOL;
1808 lstk.datype(ls_top-2) = BOOL;
1809 return;
1810
1811
1812
1813 ;
1814 rule(0231):
1815 call make_bool (ls_top-2);
1816 call make_bool (ls_top);
1817 call aloc_opn(And,ls_top-2);
1818 opn.kind = Bool;
1819 opn.op1 = lstk.node_ptr(ls_top-2);
1820 opn.op2 = lstk.node_ptr(ls_top);
1821 lstk.node_ptr(ls_top-2) = opptr;
1822 return;
1823
1824
1825
1826 ;
1827 ;
1828 rule(0234):
1829 call make_bool(ls_top);
1830 call aloc_opn(Not,ls_top-1);
1831 opn.kind = Bool;
1832 opn.op2 = lstk.node_ptr(ls_top);
1833 lstk.node_ptr(ls_top-1) = opptr;
1834 lstk.datype(ls_top-1) = BOOL;
1835 return;
1836
1837 ;
1838
1839 ;
1840 rule(0237):
1841 lstk.val(ls_top) = EQ;
1842 return;
1843
1844 ;
1845 rule(0238):
1846 lstk.val(ls_top) = NE;
1847 return;
1848
1849 ;
1850 rule(0239):
1851 lstk.val(ls_top) = LE;
1852 return;
1853
1854 ;
1855 rule(0240):
1856 lstk.val(ls_top) = GE;
1857 return;
1858
1859 ;
1860 rule(0241):
1861 lstk.val(ls_top) = LT;
1862 return;
1863
1864
1865 rule(0242):
1866 lstk.val(ls_top) = GT;
1867 return;
1868
1869
1870 rule(0243):
1871 if (lstk.datype(ls_top-2) ^= lstk.datype(ls_top))
1872 then do;
1873 if (lstk.datype(ls_top) = CHAR)
1874 then call make_char(ls_top-2);
1875 else if (lstk.datype(ls_top-2) = CHAR)
1876 then call make_char(ls_top);
1877 else do;
1878 call make_dec(ls_top);
1879 call make_dec(ls_top-2);
1880 end;
1881 end;
1882 goto rels;
1883
1884
1885 rule(0244):
1886
1887 rule(0245):
1888 call make_char (ls_top-2);
1889 call make_char (ls_top);
1890 rels:
1891 call aloc_opn((lstk.val(ls_top-1)),ls_top-2);
1892 opn.kind = Bool;
1893 opn.op1 = lstk.node_ptr(ls_top-2);
1894 opn.op2 = lstk.node_ptr(ls_top);
1895 lstk.node_ptr(ls_top-2) = opptr;
1896 lstk.val(ls_top-2) = 1;
1897 lstk.datype(ls_top-2) = BOOL;
1898 return;
1899
1900 ;
1901 rule(0246):
1902 lstk.val (ls_top) = Beg;
1903 return;
1904
1905 ;
1906 rule(0247):
1907 lstk.val (ls_top - 1) = Nbeg;
1908 return;
1909
1910 ;
1911 rule(0248):
1912 lstk.val (ls_top) = End;
1913 return;
1914
1915 ;
1916 rule(0249):
1917 lstk.val (ls_top - 1) = Nend;
1918 return;
1919
1920 ;
1921 rule(0250):
1922 lstk.val (ls_top) = Cont;
1923 return;
1924
1925
1926 rule(0251):
1927 lstk.val (ls_top - 1) = Ncont;
1928 return;
1929
1930 ;
1931 rule(0252):
1932 lstk.val (ls_top - 1) = Begw;
1933 return;
1934
1935 ;
1936 rule(0253):
1937 lstk.val (ls_top - 2) = Nbegw;
1938 return;
1939
1940 ;
1941 rule(0254):
1942 lstk.val (ls_top - 1) = Endw;
1943 return;
1944
1945 ;
1946 rule(0255):
1947 lstk.val (ls_top - 2) = Nendw;
1948 return;
1949
1950 ;
1951 rule(0256):
1952 lstk.val (ls_top - 1) = Contw;
1953 return;
1954
1955
1956 rule(0257):
1957 lstk.val (ls_top - 2) = Ncontw;
1958 return;
1959
1960 ;
1961 rule(0258):
1962 class = ls_top-2;
1963 call aloc_opn(In,(class));
1964 IN_rtn:
1965 if (lstk.datype(ls_top) ^= SET)
1966 then do;
1967 call mrpg_error_(2,(lstk.line(ls_top)),"The ^a name ""^a"" cannot be the object of an IN."
1968 ,dt_s(lstk.datype(ls_top)),pull_name((ls_top)));
1969 return;
1970 end;
1971 ki = lstk.node_ptr(ls_top)->symref.sym->symtab.use.b->datum.datal.b->opn.op;
1972 if (ki = n_n) & (lstk.datype (class) ^= DEC)
1973 | (ki = s_s) & (lstk.datype (class) ^= CHAR)
1974 then do;
1975 call mrpg_error_ (2, (lstk.line (class)), """^a"" has the wrong data type for SET ""^a"".",
1976 pull_name ((class)), pull_name ((ls_top)));
1977 return;
1978 end;
1979 call use_ref ((lstk.node_ptr(ls_top)));
1980 opn.kind = Bool;
1981 opn.op1 = lstk.node_ptr(ls_top);
1982 opn.op2 = lstk.node_ptr(class);
1983 lstk.node_ptr(class) = opptr;
1984 lstk.datype(class) = BOOL;
1985 return;
1986
1987
1988 rule(0259):
1989 class = ls_top-3;
1990 call aloc_opn(Nin,(class));
1991 goto IN_rtn;
1992
1993 ;
1994
1995
1996
1997 ;
1998 rule(0262):
1999 set_type = n_n;
2000 goto set_comm;
2001
2002 ;
2003 rule(0263):
2004 set_type = s_s;
2005 goto set_comm;
2006
2007
2008 rule(0264):
2009
2010 rule(0265):
2011 set_comm:
2012 call aloc_opn(set_type,ls_top);
2013 opn.kind = Bool;
2014 opn.op1 = lstk.node_ptr(ls_top);
2015 call link (datum.datal,opptr);
2016 return;
2017
2018
2019 ;
2020
2021 ;
2022 rule(0267):
2023 ;
2024 rule(0268):
2025 lstk.node_ptr(ls_top)->symref.kind = Bool;
2026 lstk.datype(ls_top) = BOOL;
2027 return;
2028
2029
2030
2031 ;
2032 rule(0270):
2033 if (repptr ^= null())
2034 then do;
2035 li = break_number(lstk.node_ptr(ls_top-1));
2036 if (li = 0)
2037 then do;
2038 call mrpg_error_(2,(lstk.line(ls_top-1)),"Identifier ""^a"" is not a break field in this report.",
2039 pull_name(ls_top-1));
2040 return;
2041 end;
2042 lstk.val(ls_top-1) = li;
2043 call use_ref ((lstk.node_ptr(ls_top-1)));
2044 end;
2045
2046 ;
2047 rule(0271):
2048 if (repptr = null)
2049 then do;
2050 call mrpg_error_(2,(lstk.line(ls_top-3)),"%LEVEL is only allowed within a REPORT definition.");
2051 return;
2052 end;
2053 call aloc_opn (Level, ls_top-3);
2054 opn.kind = Bool;
2055 opn.op1 = report.sym;
2056 dcl pic2 pic"99";
2057 pic2 = lstk.val(ls_top-1);
2058 call st_search((pic2),tptr,"NU",0,0);
2059 opn.op2 = tptr;
2060 lstk.node_ptr(ls_top-3) = opptr;
2061 lstk.datype(ls_top-3) = BOOL;
2062 return;
2063
2064 ;
2065 rule(0272):
2066 ^K call mrpg_error_(2,(lstk.line(ls_top-3)),"%ABSENT not implemented.");
2067 return;
2068
2069 ;
2070 rule(0273):
2071 ^K call mrpg_error_(2,(lstk.line(ls_top-3)),"%PRESENT not implemented.");
2072 return;
2073
2074
2075 rule(0274):
2076 ^K call mrpg_error_(2,(lstk.line(ls_top-3)),"%FIT not implemented.");
2077 return;
2078
2079 ;
2080 rule(0275):
2081 call make_bool(ls_top-2);
2082 call make_char(ls_top);
2083 tptr = lstk.node_ptr(ls_top);
2084 call aloc_opn(If,ls_top-4);
2085 opn.kind = tptr->symref.kind;
2086 opn.op1 = lstk.node_ptr(ls_top-2);
2087 opn.op2 = tptr;
2088 lstk.node_ptr(ls_top-4) = opptr;
2089 lstk(ls_top-4).datype = tptr->symref.kind;
2090 return;
2091
2092
2093 ;
2094 rule(0277):
2095 call make_char (ls_top-2);
2096 call make_char (ls_top);
2097 call aloc_opn(Cat,ls_top-2);
2098 opn.kind = Char;
2099 opn.op1 = lstk.node_ptr(ls_top-2);
2100 opn.op2 = lstk.node_ptr(ls_top);
2101 lstk.node_ptr(ls_top-2) = opptr;
2102 lstk.datype(ls_top-2) = CHAR;
2103 return;
2104
2105
2106
2107 ;
2108 ;
2109
2110
2111 ;
2112 rule(0282):
2113 call make_char (ls_top-5);
2114 call make_dec (ls_top-3);
2115 call make_dec (ls_top-1);
2116 call aloc_opn(Substr,ls_top-7);
2117 opn.kind = Char;
2118 opn.op1 = lstk.node_ptr(ls_top-5);
2119 opn.op2 = lstk.node_ptr(ls_top-3);
2120 opn.op3 = lstk.node_ptr(ls_top-1);
2121 lstk.node_ptr(ls_top-7) = opptr;
2122 lstk.datype(ls_top-7) = CHAR;
2123 depth = depth - 1;
2124 return;
2125
2126 ;
2127 rule(0283):
2128 call make_dec (ls_top-1);
2129 call make_char (ls_top-3);
2130 call aloc_opn(Substr,ls_top-5);
2131 opn.kind = Char;
2132 opn.op1 = lstk.node_ptr(ls_top-3);
2133 opn.op2 = lstk.node_ptr(ls_top-1);
2134 lstk.node_ptr(ls_top-5) = opptr;
2135 lstk.datype(ls_top-5) = CHAR;
2136 depth = depth - 1;
2137 return;
2138
2139 ;
2140 rule(0284):
2141 ^K call mrpg_error_(2,(lstk.line(ls_top-3)),"%ROMAN not implemented.");
2142 depth = depth - 1;
2143 return;
2144
2145 ;
2146 ;
2147 ;
2148 ;
2149 ;
2150
2151 rule(0290):
2152 call make_dec(ls_top-1);
2153 call make_char(ls_top-3);
2154 call aloc_opn(Rpt,ls_top-5);
2155 opn.kind = Char;
2156 opn.op1 = lstk.node_ptr(ls_top-3);
2157 opn.op2 = lstk.node_ptr(ls_top-1);
2158 lstk.node_ptr(ls_top-5) = opptr;
2159 lstk.datype(ls_top-5) = CHAR;
2160 depth = depth - 1;
2161 return;
2162
2163
2164 ;
2165 rule(0291):
2166 call make_dec (ls_top-2);
2167 call make_dec(ls_top);
2168 call aloc_opn(Add,ls_top-2);
2169 opn.kind = Decimal;
2170 opn.op1 = lstk.node_ptr(ls_top-2);
2171 opn.op2 = lstk.node_ptr(ls_top);
2172 lstk.node_ptr(ls_top-2) = opptr;
2173 lstk.datype(ls_top-2) = DEC;
2174 return;
2175
2176 ;
2177 rule(0292):
2178 call make_dec (ls_top-2);
2179 call make_dec(ls_top);
2180 call aloc_opn(Sub,ls_top-2);
2181 opn.kind = Decimal;
2182 opn.op1 = lstk.node_ptr(ls_top-2);
2183 opn.op2 = lstk.node_ptr(ls_top);
2184 lstk.node_ptr(ls_top-2) = opptr;
2185 lstk.datype(ls_top-2) = DEC;
2186 return;
2187
2188
2189
2190 ;
2191 rule(0294):
2192 call make_dec (ls_top-2);
2193 call make_dec(ls_top);
2194 call aloc_opn(Mul,ls_top-2);
2195 opn.kind = Decimal;
2196 opn.op1 = lstk.node_ptr(ls_top-2);
2197 opn.op2 = lstk.node_ptr(ls_top);
2198 lstk.node_ptr(ls_top-2) = opptr;
2199 lstk.datype(ls_top-2) = DEC;
2200 return;
2201
2202 ;
2203 rule(0295):
2204 call make_dec (ls_top-2);
2205 call make_dec(ls_top);
2206 call aloc_opn(Div,ls_top-2);
2207 opn.kind = Decimal;
2208 opn.op1 = lstk.node_ptr(ls_top-2);
2209 opn.op2 = lstk.node_ptr(ls_top);
2210 lstk.node_ptr(ls_top-2) = opptr;
2211 lstk.datype(ls_top-2) = DEC;
2212 return;
2213
2214
2215
2216 ;
2217 ;
2218 rule(0298):
2219 call make_dec(ls_top);
2220 call aloc_opn(Sub,ls_top-2);
2221 opn.kind = Decimal;
2222 opn.op2 = lstk.node_ptr(ls_top);
2223 lstk.node_ptr(ls_top-1) = opptr;
2224 lstk.datype(ls_top-1) = DEC;
2225 return;
2226
2227 ;
2228 rule(0299):
2229 call make_dec(ls_top);
2230 call aloc_opn(Add,ls_top-1);
2231 opn.kind = Decimal;
2232 opn.op2 = lstk.node_ptr(ls_top);
2233 lstk.node_ptr(ls_top-1) = opptr;
2234 lstk.datype(ls_top-1) = DEC;
2235 return;
2236
2237 ;
2238 rule(0300):
2239 call make_dec(ls_top-1);
2240 call aloc_opn(Paren,ls_top-2);
2241 opn.kind = Decimal;
2242 opn.op1 = lstk.node_ptr(ls_top-1);
2243 lstk.node_ptr(ls_top) = opptr;
2244 lstk.datype(ls_top-3) = DEC;
2245 call aloc_opn(Sub,ls_top-3);
2246 opn.kind = Decimal;
2247 opn.op2 = lstk.node_ptr(ls_top);
2248 lstk.node_ptr(ls_top-3) = opptr;
2249 return;
2250
2251 ;
2252 rule(0301):
2253 call make_dec(ls_top-1);
2254 call aloc_opn(Paren,ls_top-2);
2255 opn.kind = Decimal;
2256 opn.op1 = lstk.node_ptr(ls_top-1);
2257 lstk.node_ptr(ls_top) = opptr;
2258 lstk.datype(ls_top-3) = DEC;
2259 call aloc_opn(Add,ls_top-3);
2260 opn.kind = Decimal;
2261 opn.op2 = lstk.node_ptr(ls_top);
2262 lstk.node_ptr(ls_top-3) = opptr;
2263 return;
2264
2265
2266 rule(0302):
2267 call aloc_opn(Paren,ls_top-2);
2268 opn.kind = lstk.node_ptr(ls_top-1)->datum.kind;
2269 opn.op1 = lstk.node_ptr(ls_top-1);
2270 lstk.node_ptr(ls_top-2) = opptr;
2271 lstk.datype(ls_top-2) = lstk.datype(ls_top-1);
2272 return;
2273
2274
2275 ;
2276 ;
2277 rule(0304):
2278 lstk.datype(ls_top) = DEC;
2279 return;
2280
2281 ;
2282 rule(0305):
2283 if (lstk.datype (ls_top) = 0)
2284 then do;
2285 call mrpg_error_ (2,((lstk.line(ls_top))),"Variable ""^a"" not defined before reference.",symtab.data);
2286 return;
2287 end;
2288 return;
2289
2290
2291
2292 ;
2293 rule(0307):
2294 tptr = lstk.node_ptr(ls_top-1);
2295 call use_ref((tptr));
2296 ch2 = tptr->symref.sym->symtab.use.b->datum.type;
2297 if (ch2 ^= "RP")
2298 then do;
2299 call mrpg_error_ (2,(tptr->symref.line),"The ^a name ""^a"" cannot be in a %PAGENUMBER function."
2300 ,dt_s(lstk.datype(ls_top)),pull_name(ls_top-1));
2301 end;
2302 call use_ref ((lstk.node_ptr(ls_top)));
2303 srefptr = lstk.node_ptr(ls_top-1);
2304 ki = ls_top - 3;
2305 goto pgno;
2306
2307
2308 rule(0308):
2309 srefptr = report.sym;
2310 ki = ls_top-2;
2311 pgno:
2312 symtabptr = symref.sym;
2313 call st_search (symtab.data || ".I_page",tptr,"ID",Integer,0);
2314 lstk(ki).node_ptr = tptr;
2315 lstk.datype(ki) = DEC;
2316 return;
2317
2318 end semantics;
2319 ^K
2320 make_dec: proc(e);
2321
2322 dcl e fixed bin(24);
2323
2324 if (lstk.datype(e) = DEC)
2325 then return;
2326 call aloc_opn(c_d,e);
2327 opn.kind = Decimal;
2328 if (lstk.datype(e) = BOOL)
2329 then opn.op = b_d;
2330 opn.op1 = lstk.node_ptr(e);
2331 lstk.node_ptr(e) = opptr;
2332 if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^2i^a",e,op_char(opn.op));
2333 return;
2334
2335 end make_dec;
2336 ^K
2337 make_char: proc(e);
2338
2339 dcl e fixed bin(24);
2340
2341 if (lstk.datype(e) = CHAR)
2342 then return;
2343 call aloc_opn(d_c,e);
2344 opn.kind = Char;
2345 if (lstk.datype(e) = BOOL)
2346 then opn.op = b_c;
2347 opn.op1 = lstk.node_ptr(e);
2348 lstk.node_ptr(e) = opptr;
2349 if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^2i^a",e,op_char(opn.op));
2350 return;
2351
2352 end make_char;
2353 ^K
2354 make_bool: proc(e);
2355
2356 dcl e fixed bin(24);
2357
2358 if (lstk.datype(e) = BOOL)
2359 then return;
2360 call aloc_opn(c_b,e);
2361 opn.kind = Bool;
2362 if (lstk.datype(e) = DEC)
2363 then opn.op = d_b;
2364 opn.op1 = lstk.node_ptr(e);
2365 lstk.node_ptr(e) = opptr;
2366 if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^2i^a",e,op_char(opn.op));
2367 return;
2368
2369 end make_bool;
2370 ^K
2371 break_number: proc(p)returns(fixed bin);
2372
2373 dcl p ptr;
2374 dcl i fixed bin;
2375
2376 i = 0;
2377 do srefptr = report.brlist.b
2378 repeat (symref.next)
2379 while (srefptr ^= null());
2380 i = i + 1;
2381 if (symref.sym = p->symref.sym)
2382 then return(i);
2383 end;
2384 return (0);
2385
2386 end break_number;
2387 ^K
2388 aloc_datum: proc;
2389
2390 allocate datum in (space);
2391 datum.check.b, datum.check.e = null();
2392 datum.datal.b, datum.datal.e = null();
2393 datum.echar = lstk.echar(ls_top);
2394
2395 end aloc_datum;
2396 ^K
2397 aloc_attr: proc(first);
2398 dcl first fixed bin(24);
2399
2400 dcl tptr ptr;
2401
2402 allocate attr in (space);
2403 tptr = lstk.node_ptr(first);
2404 if (tptr ^= null())
2405 then do;
2406 attr.line = tptr->symref.line;
2407 end;
2408 tptr = lstk.node_ptr(ls_top);
2409 attr.echar = tptr->symref.echar;
2410
2411 end aloc_attr;
2412 ^K
2413 aloc_param: proc(first);
2414 dcl first fixed bin(24);
2415
2416 if (paptr ^= null())
2417 then return;
2418 allocate param in (space);
2419 param.type = "PM";
2420 param.attr.b, param.attr.e = null();
2421 param.check.b, param.check.e = null();
2422 call fill_hdr(paptr,first);
2423
2424 end aloc_param;
2425 ^K
2426 aloc_opn: proc(operand,first);
2427 dcl operand fixed bin,
2428 first fixed bin(24);
2429
2430 dcl tptr ptr;
2431
2432 allocate opn in (space);
2433 opn.type = "OP";
2434 opn.op = operand;
2435 opn.op1, opn.op2, opn.op3 = null();
2436 call fill_hdr(opptr,first);
2437
2438 end aloc_opn;
2439 ^K
2440 aloc_value: proc(id,first);
2441 dcl id char(2),
2442 first fixed bin(24);
2443
2444 dcl tptr ptr;
2445
2446 allocate value in (space);
2447 value.type = id;
2448 value.ctl = null();
2449 call fill_hdr(valptr,first);
2450
2451 end aloc_value;
2452 ^K
2453 aloc_stmt: proc(id,first);
2454 dcl id char(2),
2455 first fixed bin(24);
2456
2457 dcl tptr ptr;
2458
2459 allocate stmt in (space);
2460 stmt.type = id;
2461 stmt.ref1.b, stmt.ref1.e = null();
2462 stmt.ref2.b, stmt.ref2.e = null();
2463 stmt.ref3.b, stmt.ref3.e = null();
2464 call fill_hdr(stmtptr,first);
2465
2466 end aloc_stmt;
2467 ^K
2468 fill_hdr: proc(refp,first);
2469
2470 dcl refp ptr,
2471 first fixed bin(24);
2472
2473 tptr = lstk.node_ptr(first);
2474 if (tptr = null())
2475 then do;
2476 refp->stmt.line = lstk.line(first);
2477 end;
2478 else do;
2479 refp->stmt.line = tptr->symref.line;
2480 end;
2481 tptr = lstk.node_ptr(ls_top);
2482 if (tptr = null())
2483 then do;
2484 refp->stmt.echar = lstk.echar(ls_top);
2485 end;
2486 else do;
2487 refp->stmt.echar = tptr->symref.echar;
2488 end;
2489 refp->stmt.usage = null();
2490 refp->stmt.sym = null();
2491 refp->stmt.next = null();
2492
2493 end fill_hdr;
2494 ^K
2495 aloc_head: proc;
2496
2497 allocate head in (space);
2498 head.type = "HD";
2499
2500 end aloc_head;
2501 ^K
2502 link_list: proc(lista,listb);
2503
2504
2505
2506 dcl 1 (lista,listb) like tree.table;
2507
2508 if (listb.b = null())
2509 then return;
2510
2511 if (lista.b = null())
2512 then do;
2513 lista.b = listb.b;
2514 lista.e = listb.e;
2515 end;
2516 else do;
2517 lista.e-> symref.next = listb.b;
2518 lista.e = listb.e;
2519 end;
2520 listb.b, listb.e = null();
2521
2522 end link_list;
2523 ^K
2524 link: proc(list,ref);
2525
2526
2527 dcl 1 list like tree.table,
2528 ref ptr;
2529
2530 if (ref = null())
2531 then return;
2532 if (list.b = null())
2533 then do;
2534 list.b, list.e = ref;
2535 ref->symref.next = null();
2536 end;
2537 else do;
2538 list.e-> symref.next = ref;
2539 list.e = ref;
2540 end;
2541 ref-> symref.next = null();
2542
2543 end link;
2544 ^K
2545 linkr: proc(list,ref);
2546
2547
2548 dcl 1 list like tree.table,
2549 ref ptr;
2550
2551 if (list.b = null())
2552 then do;
2553 list.b, list.e = ref;
2554 ref-> symref.next = null();
2555 end;
2556 else do;
2557 ref-> symref.next = list.b;
2558 list.b = ref;
2559 end;
2560
2561 end linkr;
2562 use_def: proc(ref);
2563 dcl ref ptr;
2564
2565 dcl tptr ptr;
2566
2567 if (ref = null())
2568 then return;
2569 tptr = ref->datum.sym;
2570 if (tptr = null())
2571 then return;
2572 tptr = tptr->symref.sym;
2573 if (tptr = null())
2574 then return;
2575 if (tptr->symtab.use.b = null())
2576 then do;
2577 tptr->symtab.use.b, tptr->symtab.use.e = ref;
2578 ref-> datum.usage = null();
2579 end;
2580 else do;
2581 dcl ch2 char(2);
2582 ch2 = tptr->symtab.use.b->symref.type;
2583 if (index("*IN*DC*PM*RP*RH*PH*DH*DT*DF*PF*RF*",ch2)^=0)
2584 then do;
2585 call mrpg_error_ (2,(ref->symref.line),"Symbol ""^a"" already defined.",tptr->symtab.data);
2586 return;
2587 end;
2588 ref-> datum.usage = tptr->symtab.use.b;
2589 tptr->symtab.use.b = ref;
2590 end;
2591
2592 end use_def;
2593
2594 use_ref: proc(ref);
2595 dcl ref ptr;
2596
2597 dcl tptr ptr;
2598
2599 if (ref = null())
2600 then return;
2601 tptr = ref->symref.sym;
2602 if (tptr = null())
2603 then return;
2604 if (tptr->symtab.use.b = null())
2605 then tptr->symtab.use.b, tptr->symtab.use.e = ref;
2606 else do;
2607 tptr->symtab.use.e-> datum.usage = ref;
2608 tptr->symtab.use.e = ref;
2609 end;
2610 ref-> datum.usage = null();
2611
2612 end use_ref;
2613
2614 pull_name: proc(ii)returns(char(64)var);
2615
2616 dcl ii fixed bin;
2617
2618 tptr = lstk.node_ptr(ii);
2619 if (tptr = null())
2620 then return("** NULL NODEPTR **");
2621 tptr = tptr->symref.sym;
2622 if (tptr = null())
2623 then return("** NULL SYMREF **");
2624 return (tptr -> symtab.data);
2625 end pull_name;
2626