1
2
3 dcl not_flag fixed bin init(0);
4 dcl min_paren fixed bin init(0);
5
6 scanner: proc;
7
8 dcl NL char(1)int static init("
9 ");
10 dcl AN char(63)int static init("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_");
11 dcl AZ char(26)int static init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
12 dcl az char(26)int static init("abcdefghijklmnopqrstuvwxyz");
13 dcl symt char(32);
14 dcl hold_symt char(32);
15 dcl hold_ifi fixed bin(24);
16 dcl hold_line fixed bin(24);
17 dcl (sym_len, hold_sym_len) fixed bin(24);
18 dcl ctype fixed bin(24);
19 dcl jj fixed bin(24);
20
21 if (not_flag > 0)
22 then not_flag = not_flag - 1;
23 get_more:
24 if (ifi>ifl)
25 then do;
26 if (ifi > ife)
27 then do;
28 lstk (-la_put).symbol = 0;
29 return;
30 end;
31 call get_line;
32 goto get_more;
33 end;
34 sym_len = verify(substr(ifile,ifi,ifl-ifi+1),AN) -1;
35 if (sym_len > 0)
36 then do;
37 symt = translate (substr(ifile,ifi,sym_len),AZ,az);
38 ctype = classify(fixed(unspec(substr(symt,1,1))));
39 end;
40 else do;
41 symt = "";
42 ctype = classify(fixed(unspec(substr(ifile,ifi,1))));
43 sym_len = 1;
44 end;
45 lstk (-la_put).symptr = addr(ifilea(ifi));
46 lstk (-la_put).symlen = sym_len;
47 lstk (-la_put).line = linenumber;
48 lstk (-la_put).node_ptr = null();
49 lstk (-la_put).bchar = ifi;
50 lstk (-la_put).datype = 0;
51 call typer;
52 lstk (-la_put).echar = ifi - 1;
53 return;
54
55 typer: proc;
56
57 goto type(ctype);
58
59 type( 0):
60 call mrpg_error_ (1, linenumber, "Invalid character ""^a"" ignored", substr(ifile, ifi, 1));
61
62 type( 1):
63 ifi=ifi+1;
64 goto get_more;
65
66 type( 2):
67 symbol:
68 if (sym_len > 1)
69 then do;
70 Ch2 = substr (ifile, lstk (-la_put).bchar, 2);
71 if (substr (Ch2, 2, 1) = "_")
72 then if (index (AZ, substr (Ch2, 1, 1)) ^= 0)
73 then call mrpg_error_ (3, lstk.line (-la_put), "Symbol may not begin with ""^a""", Ch2);
74 dcl Ch2 char(2);
75 end;
76 lstk (-la_put).symlen = sym_len;
77 ifi = ifi + sym_len;
78 lstk (-la_put).echar = ifi - 1;
79 lstk (-la_put).symbol = 103 ;
80 call st_search (substr (ifile, lstk (-la_put).bchar, lstk (-la_put).symlen), tptr, "ID", 0, 0);
81 lstk (-la_put).node_ptr = tptr;
82 tptr = tptr->symref.sym->symtab.use.b;
83 if (tptr = null())
84 then lstk (-la_put).datype = 0;
85 else if (tptr->datum.type = "RP")
86 then lstk.datype(-la_put) = REP;
87 else if (tptr->datum.type = "DT")
88 then lstk.datype(-la_put) = DET;
89 else if (index("*PM*IN*DC*",tptr->datum.type) = 0)
90 then lstk (-la_put).datype = 0;
91 else do;
92 jj = tptr->datum.kind;
93 if (jj = DecSpec)
94 then jj = Decimal;
95 if (jj = Bool)
96 then lstk (-la_put).datype=BOOL;
97 else if (jj = Decimal)
98 then lstk (-la_put).datype = DEC;
99 else if (jj = Table)
100 then do;
101 lstk.datype(-la_put) = TABLE;
102 jj = Char;
103 end;
104 else if (jj = Tablev)
105 then do;
106 lstk.datype(-la_put) = TABLE;
107 jj = Chard;
108 end;
109 else if (jj = Tabled)
110 then do;
111 lstk.datype(-la_put) = TABLE;
112 jj = Decimal;
113 end;
114 else if (jj = Set)
115 then do;
116 lstk.datype(-la_put) = SET;
117 jj = Bool;
118 end;
119 else do;
120 lstk.datype(-la_put) = CHAR;
121 if (jj ^= Char)
122 then jj = Chard;
123 end;
124 lstk.node_ptr(-la_put)->symref.kind = jj;
125 if db_sw then call ioa_("^a ^a ^a ^a",
126 tptr->datum.type,
127 kind_char(tptr->datum.kind),
128 dt_s(lstk.datype(-la_put)),
129 tptr->datum.sym->symref.sym->symtab.data);
130 end;
131 return;
132 type( 3):
133 number:
134 lstk (-la_put).symlen, jj = verify (substr (ifile, ifi, 32), "0123456789.") - 1;
135 if (jj < sym_len)
136 then do;
137 call mrpg_error_ (2, lstk.line(-la_put), "Invalid number ""^a"". Initial digits will be assumed as a number.",
138 substr(ifile,ifi,sym_len));
139 end;
140 else if (index (after (substr (ifile, ifi, jj), "."), ".") ^= 0)
141 then do;
142 call mrpg_error_ (2, lstk.line (-la_put), "Invalid number ""^a""", substr (ifile, ifi, jj));
143 end;
144 ifi = ifi + jj;
145 lstk (-la_put).echar = ifi - 1;
146 lstk (-la_put).symbol = 104 ;
147 lstk (-la_put).datype = DEC;
148 call st_search(substr(ifile,lstk (-la_put).bchar,lstk (-la_put).symlen),tptr,"NU",0,0);
149 tptr->symref.kind = Decimal;
150 lstk (-la_put).node_ptr = tptr;
151 lstk.val(-la_put) = fixed(symtab.data,24);
152 return;
153 type( 4):
154 dcl sbl fixed bin(24);
155 sbl=ifi;
156 ifi=ifi+1;
157 try_again:
158 jj = index(substr(ifile,ifi,ifl-ifi+1),"""");
159 if (jj = 0)
160 then do;
161 ifi = ifl+1;
162 if (ifi > ife)
163 then do;
164 call mrpg_error_(3,lstk.line(-la_put),"Unterminated quoted string.");
165 end;
166 call get_line;
167 goto try_again;
168 end;
169 ifi=ifi+jj;
170 if(substr(ifile,ifi,1)="""")
171 then do;
172 ifi=ifi+1;
173 goto try_again;
174 end;
175 lstk (-la_put).symlen=ifi-sbl;
176 lstk (-la_put).echar = ifi - 1;
177 lstk (-la_put).symbol = 105 ;
178 lstk (-la_put).datype = CHAR;
179 call st_search(substr(ifile,lstk (-la_put).bchar,lstk (-la_put).symlen),tptr,"ST",0,0);
180 tptr->symref.kind = Char;
181 lstk (-la_put).node_ptr = tptr;
182 return;
183
184 type( 5):
185
186
187
188
189
190
191 if (translate(substr(ifile,ifi,4),AZ,az)="%DAY") then do;
192 ifi = ifi + 4;
193 lstk (-la_put).symlen = 4;
194 lstk (-la_put).symbol = 2 ;
195 call st_search("I_DAY",tptr,"ID",Chard,12);
196 tree.day = "1"b;
197 lstk (-la_put).node_ptr = tptr;
198 lstk (-la_put).datype = 2;
199 return;
200 end;
201
202
203
204
205
206
207 else if (translate(substr(ifile,ifi,7),AZ,az)="%HHMMSS") then do;
208 ifi = ifi + 7;
209 lstk (-la_put).symlen = 7;
210 lstk (-la_put).symbol = 4 ;
211 call st_search("I_HHMMSS",tptr,"ID",Char,8);
212 tree.hhmmss = "1"b;
213 lstk (-la_put).node_ptr = tptr;
214 lstk (-la_put).datype = 2;
215 return;
216 end;
217 else if (translate(substr(ifile,ifi,6),AZ,az)="%LEVEL") then do;
218 ifi = ifi + 6;
219 lstk (-la_put).symlen = 6;
220 lstk (-la_put).symbol = 5 ;
221 return;
222 end;
223 else if (translate(substr(ifile,ifi,7),AZ,az)="%MMDDYY") then do;
224 ifi = ifi + 7;
225 lstk (-la_put).symlen = 7;
226 lstk (-la_put).symbol = 6 ;
227 call st_search("I_MMDDYY",tptr,"ID",Char,8);
228 tree.mmddyy = "1"b;
229 lstk (-la_put).node_ptr = tptr;
230 lstk (-la_put).datype = 2;
231 return;
232 end;
233 else if (translate(substr(ifile,ifi,6),AZ,az)="%MONTH") then do;
234 ifi = ifi + 6;
235 lstk (-la_put).symlen = 6;
236 lstk (-la_put).symbol = 7 ;
237 call st_search("I_MONTH",tptr,"ID",Chard,12);
238 tree.month = "1"b;
239 lstk (-la_put).node_ptr = tptr;
240 lstk (-la_put).datype = 2;
241 return;
242 end;
243 else if (translate(substr(ifile,ifi,11),AZ,az)="%PAGENUMBER") then do;
244 ifi = ifi + 11;
245 lstk (-la_put).symlen = 11;
246 lstk (-la_put).symbol = 8 ;
247 return;
248 end;
249
250
251
252
253
254
255 else if (translate(substr(ifile,ifi,7),AZ,az)="%REPEAT") then do;
256 ifi = ifi + 7;
257 lstk (-la_put).symlen = 7;
258 lstk (-la_put).symbol = 10 ;
259 return;
260 end;
261 else if (translate(substr(ifile,ifi,6),AZ,az)="%ROMAN") then do;
262 ifi = ifi + 6;
263 lstk (-la_put).symlen = 6;
264 lstk (-la_put).symbol = 11 ;
265 return;
266 end;
267 else if (translate(substr(ifile,ifi,7),AZ,az)="%SUBSTR") then do;
268 ifi = ifi + 7;
269 lstk (-la_put).symlen = 7;
270 lstk (-la_put).symbol = 12 ;
271 return;
272 end;
273 else if (translate(substr(ifile,ifi,6),AZ,az)="%YYDDD") then do;
274 ifi = ifi + 6;
275 lstk (-la_put).symlen = 6;
276 lstk (-la_put).symbol = 13 ;
277 call st_search("I_YYDDD",tptr,"ID",Char,5);
278 tree.yyddd = "1"b;
279 lstk (-la_put).node_ptr = tptr;
280 lstk (-la_put).datype = 2;
281 return;
282 end;
283 goto error;
284
285 type( 6):
286 do;
287 ifi = ifi + 1;
288 lstk (-la_put).symbol = 25 ;
289 return;
290 end;
291 goto error;
292
293 type( 7):
294 do;
295 parenct = parenct + 1;
296 ifi = ifi + 1;
297 lstk (-la_put).symbol = 14 ;
298 return;
299 end;
300 goto error;
301
302 type( 8):
303 do;
304 parenct = parenct - 1;
305 ifi = ifi + 1;
306 lstk (-la_put).symbol = 15 ;
307 return;
308 end;
309 goto error;
310
311 type( 9):
312 do;
313 ifi = ifi + 1;
314 lstk (-la_put).symbol = 16 ;
315 return;
316 end;
317 goto error;
318
319 type( 10):
320 do;
321 ifi = ifi + 1;
322 lstk (-la_put).symbol = 17 ;
323 return;
324 end;
325 goto error;
326
327 type( 11):
328 hold_ifi = ifi;
329 hold_line = linenumber;
330 ifi = ifi + 1;
331 if (parenct = 0)
332 then if skip()
333 then do;
334 call digit_test;
335 if (substr(symt,1,1)="2") then do;
336 ifi = ifi + 1;
337 lstk (-la_put).symbol = 106 ;
338 lstk (-la_put).symlen = ifi - hold_ifi;
339 return;
340 end;
341 else if (substr(symt,1,1)="3") then do;
342 ifi = ifi + 1;
343 lstk (-la_put).symbol = 107 ;
344 lstk (-la_put).symlen = ifi - hold_ifi;
345 return;
346 end;
347 else if (substr(symt,1,1)="4") then do;
348 ifi = ifi + 1;
349 lstk (-la_put).symbol = 108 ;
350 lstk (-la_put).symlen = ifi - hold_ifi;
351 return;
352 end;
353 end;
354 ifi = hold_ifi;
355 linenumber = hold_line;
356 ifi = ifi + 1;
357 lstk (-la_put).symbol = 18 ;
358 return;
359
360 type( 12):
361 if (substr(ifile,ifi,2)="->") then do;
362 ifi = ifi + 2;
363 lstk (-la_put).symlen = 2;
364 lstk (-la_put).symbol = 20 ;
365 return;
366 end;
367 else do;
368 ifi = ifi + 1;
369 lstk (-la_put).symbol = 19 ;
370 return;
371 end;
372 goto error;
373
374 type( 13):
375 if (substr(ifile,ifi,2) = "
376
377
378
379
380
381
382
383
384
385
386
387 if (substr(ifile,ifi,2)=":=") then do;
388 ifi = ifi + 2;
389 lstk (-la_put).symlen = 2;
390 lstk (-la_put).symbol = 22 ;
391 return;
392 end;
393 goto error;
394
395 type( 15):
396 if (parenct > min_paren)
397 then do;
398 parenct = parenct - 1;
399 lstk(-la_put).symbol = 15;
400 call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before "";"".");
401 return;
402 end;
403 do;
404 ifi = ifi + 1;
405 lstk (-la_put).symbol = 23 ;
406 return;
407 end;
408 goto error;
409
410 type( 16):
411 if (substr(ifile,ifi,2)="<=") then do;
412 ifi = ifi + 2;
413 lstk (-la_put).symlen = 2;
414 lstk (-la_put).symbol = 67 ;
415 return;
416 end;
417 else do;
418 ifi = ifi + 1;
419 lstk (-la_put).symbol = 71 ;
420 return;
421 end;
422 goto error;
423
424 type( 17):
425 do;
426 ifi = ifi + 1;
427 lstk (-la_put).symbol = 51 ;
428 return;
429 end;
430 goto error;
431
432 type( 18):
433 if (substr(ifile,ifi,2)=">=") then do;
434 ifi = ifi + 2;
435 lstk (-la_put).symlen = 2;
436 lstk (-la_put).symbol = 59 ;
437 return;
438 end;
439 else do;
440 ifi = ifi + 1;
441 lstk (-la_put).symbol = 60 ;
442 return;
443 end;
444 goto error;
445
446 type( 19):
447 if (symt="ASCENDING") then do;
448 ifi = ifi + sym_len;
449 lstk (-la_put).symbol = 26 ;
450 lstk (-la_put).symlen = sym_len;
451 return;
452 end;
453 else if (symt="ASC") then do;
454 ifi = ifi + sym_len;
455 lstk (-la_put).symbol = 26 ;
456 lstk (-la_put).symlen = sym_len;
457 return;
458 end;
459 else if (symt="ALIGN") then do;
460 ifi = ifi + sym_len;
461 lstk (-la_put).symbol = 24 ;
462 lstk (-la_put).symlen = sym_len;
463 return;
464 end;
465 else if (symt="AND") then do;
466 ifi = ifi + sym_len;
467 lstk (-la_put).symbol = 25 ;
468 lstk (-la_put).symlen = sym_len;
469 return;
470 end;
471 else if (symt="ATTACH") then do;
472 ifi = ifi + sym_len;
473 lstk (-la_put).symbol = 27 ;
474 lstk (-la_put).symlen = sym_len;
475 return;
476 end;
477 goto symbol;
478
479 type( 20):
480 if (symt="BEGINS") then do;
481 ifi = ifi + sym_len;
482 lstk (-la_put).symbol = 29 ;
483 lstk (-la_put).symlen = sym_len;
484 return;
485 end;
486 else if (symt="BEGIN") then do;
487 if (not_flag = 0)
488 then do;
489 if (parenct > 0)
490 then do;
491 parenct = parenct - 1;
492 lstk(-la_put).symbol = 15;
493 call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""BEGIN"".");
494 return;
495 end;
496 if (if_nest > 0)
497 then do;
498 lstk.symbol(-la_put) = 117;
499 call mrpg_error_(2, lstk.line(-la_put), "Missing ""FI;"" supplied before ""BEGIN"".");
500 return;
501 end;
502 end;
503 ifi = ifi + sym_len;
504 lstk (-la_put).symbol = 28 ;
505 lstk (-la_put).symlen = sym_len;
506 return;
507 end;
508 else if (symt="BOOLEAN") then do;
509 ifi = ifi + sym_len;
510 lstk (-la_put).symbol = 56 ;
511 lstk (-la_put).symlen = sym_len;
512 return;
513 end;
514 else if (symt="BOOL") then do;
515 ifi = ifi + sym_len;
516 lstk (-la_put).symbol = 56 ;
517 lstk (-la_put).symlen = sym_len;
518 return;
519 end;
520 else if (symt="BREAK") then do;
521 ifi = ifi + sym_len;
522 lstk (-la_put).symbol = 31 ;
523 lstk (-la_put).symlen = sym_len;
524 return;
525 end;
526 else if (symt="BSP") then do;
527 ifi = ifi + sym_len;
528 lstk (-la_put).symbol = 109;
529 lstk (-la_put).symlen = sym_len;
530 return;
531 end;
532 goto symbol;
533
534 type( 21):
535 if (symt="CENTER") then do;
536 ifi = ifi + sym_len;
537 lstk (-la_put).symbol = 32 ;
538 lstk (-la_put).symlen = sym_len;
539 return;
540 end;
541 else if (symt="CHARACTER") then do;
542 ifi = ifi + sym_len;
543 lstk (-la_put).symbol = 33 ;
544 lstk (-la_put).symlen = sym_len;
545 return;
546 end;
547 else if (symt="CHAR") then do;
548 ifi = ifi + sym_len;
549 lstk (-la_put).symbol = 33 ;
550 lstk (-la_put).symlen = sym_len;
551 return;
552 end;
553 else if (symt="COLUMN") then do;
554 ifi = ifi + sym_len;
555 lstk (-la_put).symbol = 34 ;
556 lstk (-la_put).symlen = sym_len;
557 return;
558 end;
559 else if (symt="COL") then do;
560 ifi = ifi + sym_len;
561 lstk (-la_put).symbol = 34 ;
562 lstk (-la_put).symlen = sym_len;
563 return;
564 end;
565 else if (symt="CONCATENATE") then do;
566 ifi = ifi + sym_len;
567 lstk (-la_put).symbol = 35 ;
568 lstk (-la_put).symlen = sym_len;
569 return;
570 end;
571 else if (symt="CONTAINS") then do;
572 ifi = ifi + sym_len;
573 lstk (-la_put).symbol = 37 ;
574 lstk (-la_put).symlen = sym_len;
575 return;
576 end;
577 else if (symt="CONTAIN") then do;
578 ifi = ifi + sym_len;
579 lstk (-la_put).symbol = 36 ;
580 lstk (-la_put).symlen = sym_len;
581 return;
582 end;
583 goto symbol;
584
585 type( 22):
586 if (symt="DCL")
587 | (symt="DECLARE") then do;
588 hold_ifi = ifi;
589 hold_line = linenumber;
590 hold_symt = symt;
591 hold_sym_len = sym_len;
592 ifi = ifi + sym_len;
593 if skip()
594 then do;
595 call digit_test;
596 if (substr(symt,1,1) = "1")
597 then do;
598 ifi = ifi + 1;
599 lstk (-la_put).symbol = 39 ;
600 lstk (-la_put).symlen = ifi-hold_ifi;
601 return;
602 end;
603 end;
604 ifi = hold_ifi;
605 linenumber = hold_line;
606 symt = hold_symt;
607 sym_len = hold_sym_len;
608 ifi = ifi + sym_len;
609 lstk (-la_put).symbol = 38 ;
610 lstk (-la_put).symlen = sym_len;
611 return;
612 end;
613 else if (symt="DECIMAL")
614 | (symt = "DEC") then do;
615 ifi = ifi + sym_len;
616 lstk (-la_put).symbol = 30 ;
617 lstk (-la_put).symlen = sym_len;
618 return;
619 end;
620 else if (symt="DEFAULT") then do;
621 ifi = ifi + sym_len;
622 lstk (-la_put).symbol = 40 ;
623 lstk (-la_put).symlen = sym_len;
624 return;
625 end;
626 else if (symt="DEFINE") then do;
627 hold_ifi = ifi;
628 hold_line = linenumber;
629 hold_symt = symt;
630 hold_sym_len = sym_len;
631 ifi = ifi + sym_len;
632 if skip()
633 then do;
634 call digit_test;
635 if (substr(symt,1,1) = "1")
636 then do;
637 ifi = ifi + 1;
638 lstk (-la_put).symbol = 41 ;
639 lstk (-la_put).symlen = ifi-hold_ifi;
640 return;
641 end;
642 end;
643 ifi = hold_ifi;
644 linenumber = hold_line;
645 symt = hold_symt;
646 sym_len = hold_sym_len;
647 goto symbol;
648 end;
649 else if (symt="DELIMITED") then do;
650 ifi = ifi + sym_len;
651 lstk (-la_put).symbol = 42 ;
652 lstk (-la_put).symlen = sym_len;
653 return;
654 end;
655 else if (symt="DESCENDING") then do;
656 ifi = ifi + sym_len;
657 lstk (-la_put).symbol = 43 ;
658 lstk (-la_put).symlen = sym_len;
659 return;
660 end;
661 else if (symt="DESC") then do;
662 ifi = ifi + sym_len;
663 lstk (-la_put).symbol = 43 ;
664 lstk (-la_put).symlen = sym_len;
665 return;
666 end;
667 else if (symt="DETAILFOOT") then do;
668 ifi = ifi + sym_len;
669 lstk (-la_put).symbol = 45 ;
670 lstk (-la_put).symlen = sym_len;
671 return;
672 end;
673 else if (symt="DETAILHEAD") then do;
674 ifi = ifi + sym_len;
675 lstk (-la_put).symbol = 46 ;
676 lstk (-la_put).symlen = sym_len;
677 return;
678 end;
679 else if (symt="DETAIL") then do;
680 ifi = ifi + sym_len;
681 lstk (-la_put).symbol = 44 ;
682 lstk (-la_put).symlen = sym_len;
683 return;
684 end;
685 else if (symt="DUPLICATE") then do;
686 ifi = ifi + sym_len;
687 lstk (-la_put).symbol = 47 ;
688 lstk (-la_put).symlen = sym_len;
689 return;
690 end;
691 else if (symt="DUPL") then do;
692 ifi = ifi + sym_len;
693 lstk (-la_put).symbol = 47 ;
694 lstk (-la_put).symlen = sym_len;
695 return;
696 end;
697 goto symbol;
698
699 type( 23):
700 if (symt="EDIT") then do;
701 ifi = ifi + sym_len;
702 lstk (-la_put).symbol = 48 ;
703 lstk (-la_put).symlen = sym_len;
704 return;
705 end;
706 else if (symt="ENDS") then do;
707 ifi = ifi + sym_len;
708 lstk (-la_put).symbol = 50 ;
709 lstk (-la_put).symlen = sym_len;
710 return;
711 end;
712 else if (symt="END") then do;
713 if (not_flag = 0)
714 then do;
715 if (parenct > 0)
716 then do;
717 parenct = parenct - 1;
718 lstk(-la_put).symbol = 15;
719 call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""END"".");
720 return;
721 end;
722 if (if_nest > 0)
723 then do;
724 lstk.symbol(-la_put) = 117;
725 call mrpg_error_(2, lstk.line(-la_put), "Missing ""FI;"" supplied before ""END"".");
726 return;
727 end;
728 end;
729 ifi = ifi + sym_len;
730 lstk (-la_put).symbol = 49 ;
731 lstk (-la_put).symlen = sym_len;
732 return;
733 end;
734 else if (symt="ELSE") then do;
735 if (parenct > 0)
736 then do;
737 parenct = parenct - 1;
738 lstk(-la_put).symbol = 15;
739 call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""ELSE"".");
740 return;
741 end;
742 ifi = ifi + sym_len;
743 lstk (-la_put).symbol = 115 ;
744 lstk (-la_put).symlen = sym_len;
745 return;
746 end;
747 else if (symt="EQ") then do;
748 ifi = ifi + sym_len;
749 lstk (-la_put).symbol = 51 ;
750 lstk (-la_put).symlen = sym_len;
751 return;
752 end;
753 goto symbol;
754
755 type( 24):
756 if (symt="FALSE") then do;
757 ifi = ifi + sym_len;
758 call st_search("""0""b",tptr,"ST",0,0);
759 lstk (-la_put).node_ptr = tptr;
760 lstk (-la_put).symbol = 52 ;
761 lstk (-la_put).symlen = sym_len;
762 return;
763 end;
764 else if (symt="FILE") then do;
765 ifi = ifi + sym_len;
766 lstk (-la_put).symbol = 53 ;
767 lstk (-la_put).symlen = sym_len;
768 return;
769 end;
770 else if (symt="FILL") then do;
771 ifi = ifi + sym_len;
772 lstk (-la_put).symbol = 54 ;
773 lstk (-la_put).symlen = sym_len;
774 return;
775 end;
776
777
778
779
780
781
782 else if (symt="FI") then do;
783 if (parenct > 0)
784 then do;
785 parenct = parenct - 1;
786 lstk(-la_put).symbol = 15;
787 call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""FI"".");
788 return;
789 end;
790 ifi = ifi + sym_len;
791 lstk (-la_put).symbol = 116 ;
792 lstk (-la_put).symlen = sym_len;
793 return;
794 end;
795
796
797
798
799
800
801 goto symbol;
802
803 type( 25):
804 if (symt="GE") then do;
805 ifi = ifi + sym_len;
806 lstk (-la_put).symbol = 59 ;
807 lstk (-la_put).symlen = sym_len;
808 return;
809 end;
810 else if (symt="GT") then do;
811 ifi = ifi + sym_len;
812 lstk (-la_put).symbol = 60 ;
813 lstk (-la_put).symlen = sym_len;
814 return;
815 end;
816 goto symbol;
817
818 type( 26):
819 if (symt="HOLD") then do;
820 ifi = ifi + sym_len;
821 lstk (-la_put).symbol = 61 ;
822 lstk (-la_put).symlen = sym_len;
823 return;
824 end;
825 goto symbol;
826
827 type( 27):
828 if (symt="IF") then do;
829 ifi = ifi + sym_len;
830 lstk (-la_put).symbol = 62 ;
831 lstk (-la_put).symlen = sym_len;
832 return;
833 end;
834 else if (symt="INPUT") then do;
835 ifi = ifi + sym_len;
836 lstk (-la_put).symbol = 64 ;
837 lstk (-la_put).symlen = sym_len;
838 return;
839 end;
840 else if (symt="IN") then do;
841 ifi = ifi + sym_len;
842 lstk (-la_put).symbol = 63 ;
843 lstk (-la_put).symlen = sym_len;
844 return;
845 end;
846 goto symbol;
847
848 type( 28):
849
850 type( 29):
851 if (symt="KEY") then do;
852 ifi = ifi + sym_len;
853 lstk (-la_put).symbol = 66 ;
854 lstk (-la_put).symlen = sym_len;
855 return;
856 end;
857 goto symbol;
858
859 type( 30):
860 if (symt="LEFT") then do;
861 ifi = ifi + sym_len;
862 lstk (-la_put).symbol = 68 ;
863 lstk (-la_put).symlen = sym_len;
864 return;
865 end;
866 else if (symt="LET") then do;
867 ifi = ifi + sym_len;
868 lstk (-la_put).symbol = 69 ;
869 lstk (-la_put).symlen = sym_len;
870 return;
871 end;
872 else if (symt="LE") then do;
873 ifi = ifi + sym_len;
874 lstk (-la_put).symbol = 67 ;
875 lstk (-la_put).symlen = sym_len;
876 return;
877 end;
878 else if (symt="LINE") then do;
879 ifi = ifi + sym_len;
880 lstk (-la_put).symbol = 70 ;
881 lstk (-la_put).symlen = sym_len;
882 return;
883 end;
884 else if (symt="LT") then do;
885 ifi = ifi + sym_len;
886 lstk (-la_put).symbol = 71 ;
887 lstk (-la_put).symlen = sym_len;
888 return;
889 end;
890 goto symbol;
891
892 type( 31):
893 if (symt="MAXLINE") then do;
894 ifi = ifi + sym_len;
895 lstk (-la_put).symbol = 72 ;
896 lstk (-la_put).symlen = sym_len;
897 return;
898 end;
899 else if (symt="MAXL") then do;
900 ifi = ifi + sym_len;
901 lstk (-la_put).symbol = 72 ;
902 lstk (-la_put).symlen = sym_len;
903 return;
904 end;
905 else if (symt="MINLINE") then do;
906 ifi = ifi + sym_len;
907 lstk (-la_put).symbol = 73 ;
908 lstk (-la_put).symlen = sym_len;
909 return;
910 end;
911 else if (symt="MINL") then do;
912 ifi = ifi + sym_len;
913 lstk (-la_put).symbol = 73 ;
914 lstk (-la_put).symlen = sym_len;
915 return;
916 end;
917 goto symbol;
918
919 type( 32):
920 if (symt="NE") then do;
921 ifi = ifi + sym_len;
922 lstk (-la_put).symbol = 74 ;
923 lstk (-la_put).symlen = sym_len;
924 return;
925 end;
926 else if (symt="NOT") then do;
927 not_flag = 2;
928 ifi = ifi + sym_len;
929 lstk (-la_put).symbol = 76 ;
930 lstk (-la_put).symlen = sym_len;
931 return;
932 end;
933 else if (symt="NO") then do;
934 ifi = ifi + sym_len;
935 lstk (-la_put).symbol = 75 ;
936 lstk (-la_put).symlen = sym_len;
937 return;
938 end;
939 else if (symt="NUMBER") then do;
940 ifi = ifi + sym_len;
941 lstk (-la_put).symbol = 77 ;
942 lstk (-la_put).symlen = sym_len;
943 return;
944 end;
945 goto symbol;
946
947 type( 33):
948 if (symt="ON") then do;
949 ifi = ifi + sym_len;
950 lstk (-la_put).symbol = 78 ;
951 lstk (-la_put).symlen = sym_len;
952 return;
953 end;
954 else if (symt="OPTIONAL") then do;
955 ifi = ifi + sym_len;
956 lstk (-la_put).symbol = 79 ;
957 lstk (-la_put).symlen = sym_len;
958 return;
959 end;
960 else if (symt="OR") then do;
961 ifi = ifi + sym_len;
962 lstk (-la_put).symbol = 80 ;
963 lstk (-la_put).symlen = sym_len;
964 return;
965 end;
966 goto symbol;
967
968 type( 34):
969 if (symt="PAGEFOOT") then do;
970 ifi = ifi + sym_len;
971 lstk (-la_put).symbol = 81 ;
972 lstk (-la_put).symlen = sym_len;
973 return;
974 end;
975 else if (symt="PAGEHEAD") then do;
976 ifi = ifi + sym_len;
977 lstk (-la_put).symbol = 82 ;
978 lstk (-la_put).symlen = sym_len;
979 return;
980 end;
981 else if (symt="PAGELENGTH") then do;
982 ifi = ifi + sym_len;
983 lstk (-la_put).symbol = 83 ;
984 lstk (-la_put).symlen = sym_len;
985 return;
986 end;
987 else if (symt="PAGEWIDTH") then do;
988 ifi = ifi + sym_len;
989 lstk (-la_put).symbol = 84 ;
990 lstk (-la_put).symlen = sym_len;
991 return;
992 end;
993 else if (symt="PARAMETER") then do;
994 ifi = ifi + sym_len;
995 lstk (-la_put).symbol = 85 ;
996 lstk (-la_put).symlen = sym_len;
997 return;
998 end;
999 else if (symt="PARM") then do;
1000 ifi = ifi + sym_len;
1001 lstk (-la_put).symbol = 85 ;
1002 lstk (-la_put).symlen = sym_len;
1003 return;
1004 end;
1005 else if (symt="PAUSE") then do;
1006 ifi = ifi + sym_len;
1007 lstk (-la_put).symbol = 65 ;
1008 lstk (-la_put).symlen = sym_len;
1009 return;
1010 end;
1011 else if (symt="PGL") then do;
1012 ifi = ifi + sym_len;
1013 lstk (-la_put).symbol = 83 ;
1014 lstk (-la_put).symlen = sym_len;
1015 return;
1016 end;
1017 else if (symt="PGW") then do;
1018 ifi = ifi + sym_len;
1019 lstk (-la_put).symbol = 84 ;
1020 lstk (-la_put).symlen = sym_len;
1021 return;
1022 end;
1023 else if (symt="PICTURE") then do;
1024 ifi = ifi + sym_len;
1025 lstk (-la_put).symbol = 86 ;
1026 lstk (-la_put).symlen = sym_len;
1027 return;
1028 end;
1029 else if (symt="PIC") then do;
1030 ifi = ifi + sym_len;
1031 lstk (-la_put).symbol = 86 ;
1032 lstk (-la_put).symlen = sym_len;
1033 return;
1034 end;
1035 else if (symt="POSITION") then do;
1036 ifi = ifi + sym_len;
1037 lstk (-la_put).symbol = 87 ;
1038 lstk (-la_put).symlen = sym_len;
1039 return;
1040 end;
1041 else if (symt="PRINT") then do;
1042 ifi = ifi + sym_len;
1043 lstk (-la_put).symbol = 88 ;
1044 lstk (-la_put).symlen = sym_len;
1045 return;
1046 end;
1047 goto symbol;
1048
1049 type( 35):
1050 if (symt="RECORD") then do;
1051 ifi = ifi + sym_len;
1052 lstk (-la_put).symbol = 89 ;
1053 lstk (-la_put).symlen = sym_len;
1054 return;
1055 end;
1056 else if (symt="REPORTFOOT") then do;
1057 ifi = ifi + sym_len;
1058 lstk (-la_put).symbol = 91 ;
1059 lstk (-la_put).symlen = sym_len;
1060 return;
1061 end;
1062 else if (symt="REPORTHEAD") then do;
1063 ifi = ifi + sym_len;
1064 lstk (-la_put).symbol = 92 ;
1065 lstk (-la_put).symlen = sym_len;
1066 return;
1067 end;
1068 else if (symt="REPORT") then do;
1069 ifi = ifi + sym_len;
1070 lstk (-la_put).symbol = 90 ;
1071 lstk (-la_put).symlen = sym_len;
1072 return;
1073 end;
1074 else if (symt="RETURNS") then do;
1075 ifi = ifi + sym_len;
1076 lstk (-la_put).symbol = 93 ;
1077 lstk (-la_put).symlen = sym_len;
1078 return;
1079 end;
1080 else if (symt="RIGHT") then do;
1081 ifi = ifi + sym_len;
1082 lstk (-la_put).symbol = 94 ;
1083 lstk (-la_put).symlen = sym_len;
1084 return;
1085 end;
1086 goto symbol;
1087
1088 type( 36):
1089 if (symt="SORT") then do;
1090 ifi = ifi + sym_len;
1091 lstk (-la_put).symbol = 95 ;
1092 lstk (-la_put).symlen = sym_len;
1093 return;
1094 end;
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107 else if (symt="SET") then do;
1108 ifi = ifi + sym_len;
1109 lstk (-la_put).symbol = 113;
1110 lstk (-la_put).symlen =sym_len;
1111 return;
1112 end;
1113 else if (symt="SPECIAL")
1114 | (symt="SPEC") then do;
1115 ifi = ifi + sym_len;
1116 lstk (-la_put).symbol = 110 ;
1117 lstk (-la_put).symlen = sym_len;
1118 return;
1119 end;
1120 else if (symt="STREAM") then do;
1121 ifi = ifi + sym_len;
1122 lstk (-la_put).symbol = 96 ;
1123 lstk (-la_put).symlen = sym_len;
1124 return;
1125 end;
1126 else if (symt="SWITCH") then do;
1127 ifi = ifi + sym_len;
1128 lstk (-la_put).symbol = 97 ;
1129 lstk (-la_put).symlen = sym_len;
1130 return;
1131 end;
1132 goto symbol;
1133
1134 type( 37):
1135 if (symt="TABLE") then do;
1136 ifi = ifi + sym_len;
1137 lstk (-la_put).symbol = 98 ;
1138 lstk (-la_put).symlen = sym_len;
1139 return;
1140 end;
1141 else if (symt="TRANSFORM") then do;
1142 ifi = ifi + sym_len;
1143 lstk (-la_put).symbol = 99 ;
1144 lstk (-la_put).symlen = sym_len;
1145 return;
1146 end;
1147 else if (symt="TRAN") then do;
1148 ifi = ifi + sym_len;
1149 lstk (-la_put).symbol = 99 ;
1150 lstk (-la_put).symlen = sym_len;
1151 return;
1152 end;
1153 else if (symt="TRUE") then do;
1154 ifi = ifi + sym_len;
1155 call st_search("""1""b",tptr,"ST",0,0);
1156 lstk (-la_put).node_ptr = tptr;
1157 lstk (-la_put).symbol = 100 ;
1158 lstk (-la_put).symlen = sym_len;
1159 return;
1160 end;
1161 else if (symt="THEN") then do;
1162 if (parenct > 0)
1163 then do;
1164 parenct = parenct - 1;
1165 lstk(-la_put).symbol = 15;
1166 call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""THEN"".");
1167 return;
1168 end;
1169 ifi = ifi + sym_len;
1170 lstk (-la_put).symbol = 114 ;
1171 lstk (-la_put).symlen = sym_len;
1172 return;
1173 end;
1174 goto symbol;
1175
1176 type( 38):
1177 if (symt="VARYING") then do;
1178 ifi = ifi + sym_len;
1179 lstk (-la_put).symbol = 101 ;
1180 lstk (-la_put).symlen = sym_len;
1181 return;
1182 end;
1183 else if (symt="VAR") then do;
1184 ifi = ifi + sym_len;
1185 lstk (-la_put).symbol = 101 ;
1186 lstk (-la_put).symlen = sym_len;
1187 return;
1188 end;
1189 goto symbol;
1190
1191 type( 39):
1192 if (symt="WORD") then do;
1193 ifi = ifi + sym_len;
1194 lstk (-la_put).symbol = 102 ;
1195 lstk (-la_put).symlen = sym_len;
1196 return;
1197 end;
1198 goto symbol;
1199
1200 type( 40):
1201 if (substr(ifile,ifi,2)="^=") then do;
1202 ifi = ifi + 2;
1203 lstk (-la_put).symlen = 2;
1204 lstk (-la_put).symbol = 74 ;
1205 return;
1206 end;
1207 else do;
1208 ifi = ifi + 1;
1209 lstk (-la_put).symbol = 76 ;
1210 return;
1211 end;
1212 goto error;
1213
1214 type( 41):
1215 if (substr(ifile,ifi,2)="||") then do;
1216 ifi = ifi + 2;
1217 lstk (-la_put).symlen = 2;
1218 lstk (-la_put).symbol = 35 ;
1219 return;
1220 end;
1221 else do;
1222 ifi = ifi + 1;
1223 lstk (-la_put).symbol = 80 ;
1224 return;
1225 end;
1226
1227 error:
1228 call mrpg_error_(2,linenumber,"Unrecognized token ""^a"".",substr(ifile,ifi,max(1,sym_len)));
1229 ifi = ifi + max(1,sym_len);
1230 goto get_more;
1231 end;
1232
1233
1234 digit_test: proc;
1235
1236 if (index("1234",substr(symt,1,1))^=0)
1237 then do;
1238 if (substr(symt,2) ^= "")
1239 then call mrpg_error_(2,linenumber,"Invalid number ""^a"". Initial digit will be assumed as a number.",
1240 symt);
1241 end;
1242 end;
1243
1244 get_line: proc;
1245
1246 linenumber=linenumber+1;
1247 if (lino(1) ^= 0)
1248 then do;
1249 if (linenumber > lino(2))
1250 then db_sw = "0"b;
1251 else if (linenumber >= lino(1))
1252 then db_sw = "1"b;
1253 end;
1254 i = index(substr(ifile,ifi,ife-ifi+1),NL);
1255 if (i=0)
1256 then i=ife-ifi+1;
1257 else i=i-1;
1258 ifl=ifi+i;
1259 if pr_sw then call ioa_("^4i^-^a",linenumber,substr(ifile,ifi,i));
1260
1261 end;
1262 ^K
1263 comment: proc;
1264
1265 dcl sbl fixed bin(24);
1266 dcl bln fixed bin;
1267
1268 bln = linenumber;
1269 sbl, ifi = ifi + 2;
1270 loop:
1271 jj = index(substr(ifile,ifi,ifl-ifi+1),"*/");
1272 if (jj = 0)
1273 then do;
1274 ifi = ifl + 1;
1275 if (ifi > ife)
1276 then call mrpg_error_(3,lstk.line(-la_put),"Unterminated comment.");
1277 call get_line;
1278 goto loop;
1279 end;
1280 ifi = ifi + jj+1;
1281 if (index(substr(ifile,sbl,ifi-sbl+1),"
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325 1, 1, 1, 1, 1, 1, 1, 1,
1326
1327
1328 1, 1, 1, 1, 1, 1, 1, 1,
1329
1330
1331 1, 1, 1, 1, 1, 1, 1, 1,
1332
1333
1334 1, 1, 1, 1, 1, 1, 1, 1,
1335
1336
1337 1, 0, 4, 0, 0, 5, 6, 0,
1338
1339
1340 7, 8, 9, 10, 11, 12, 3, 13,
1341
1342
1343 3, 3, 3, 3, 3, 3, 3, 3,
1344
1345
1346 3, 3, 14, 15, 16, 17, 18, 0,
1347
1348
1349 0, 19, 20, 21, 22, 23, 24, 25,
1350
1351
1352 26, 27, 2, 29, 30, 31, 32, 33,
1353
1354
1355 34, 2, 35, 36, 37, 2, 38, 39,
1356
1357
1358 2, 2, 2, 0, 0, 0, 40, 0,
1359
1360
1361 0, 2, 2, 2, 2, 2, 2, 2,
1362
1363
1364 2, 2, 2, 2, 2, 2, 2, 2,
1365
1366
1367 2, 2, 2, 2, 2, 2, 2, 2,
1368
1369
1370 2, 2, 2, 0, 41, 0, 0, 1);
1371 end;
1372 st_search: proc(c, p, id, t, l);
1373
1374 dcl c char(*),
1375 p ptr,
1376 id char(2),
1377 t fixed bin,
1378 l fixed bin;
1379
1380 dcl tptr ptr;
1381
1382 symbol_leng = length(c);
1383 do symtabptr = table.b
1384 repeat (symtab.next)
1385 while(symtabptr ^= null());
1386 if (symtab.data = c)
1387 then goto found;
1388 end;
1389 allocate symtab in (space);
1390 symtab.type = id;
1391 symtab.use.b, symtab.use.e = null();
1392 symtab.data = c;
1393 call link(tree.table,symtabptr);
1394 found:
1395 allocate symref in (space);
1396 symref.type = "SY";
1397 symref.line = lstk (-la_put).line;
1398 symref.bchar = lstk (-la_put).bchar;
1399 symref.echar = lstk (-la_put).echar;
1400 symref.next = null();
1401 symref.usage = null();
1402 symref.sym = symtabptr;
1403 p = srefptr;
1404 if (t = 0)
1405 then return;
1406 tptr = p->symref.sym->symtab.use.b;
1407 if (tptr = null())
1408 then goto doit;
1409 if (tptr->symref.type ^= "DC")
1410 then do;
1411 doit:
1412 allocate datum in (space) set (tptr);
1413 tptr->datum.type = "DC";
1414 tptr->datum.sym = p;
1415 tptr->datum.kind = t;
1416 tptr->datum.leng = l;
1417 tptr->datum.datal.b, tptr->datum.datal.e = null();
1418 tptr->datum.check.b, tptr->datum.check.e = null();
1419 call use_def(tptr);
1420 call link(tree.local,tptr);
1421 end;
1422 p->symref.kind = tptr->datum.kind;
1423
1424 end;
1425