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 ted_vtab_: proc(rule_number,alternative_number);
79 goto rule( rule_number);
80
81 alloc: proc;
82
83 allocate catv in (cata);
84 catv.link = val.temp;
85 val.temp = cat_p;
86 sr.pt = addr(catv.text);
87 sr.loc = 1;
88 sr.num = cat_l;
89 sr.type = CAT;
90
91 end;
92
93
94
95
96 rule(0002):
97 ex_sw = "1"b;
98 return;
99
100 dcl comp bit(3);
101 dcl i fixed bin(21);
102 dcl j fixed bin(21);
103 dcl mc char(1);
104 dcl cv char(24) var;
105
106 ;
107 rule(0003):
108
109 ;
110 rule(0004):
111
112 ;
113 rule(0005):
114
115
116 rule(0006):
117 dcl tp ptr;
118 do while (val.temp ^= null());
119 tp = val.temp;
120 val.temp = tp->catv.link;
121 free tp->catv;
122 end;
123 goto finish;
124
125 ;
126
127
128
129
130 ;
131 rule(0009):
132
133
134 ;
135 rule(0010):
136 dcl NL char(1)int static init("
137 ");
138 call make(CAT,lst-1);
139 call iox_$put_chars(iox_$user_output,addr(ls.pt(lst-1)->ic(ls.loc(lst-1))),ls.num(lst-1),0);
140 if (rule_number = 0010)
141 then call iox_$put_chars(iox_$user_output,addr(NL),1,0);
142 lgnc = nc;
143 return;
144
145
146 ;
147 rule(0011):
148 call make(CAT, lst);
149 result = substr(ls.pt(lst)->is,ls.loc(lst),ls.num(lst));
150 return;
151
152 ;
153 rule(0012):
154 lgnc = nc;
155 return;
156
157 ;
158 rule(0013):
159 ns_string = "a";
160 call vdump;
161 lgnc = nc;
162 return;
163
164 ;
165 rule(0014):
166 ns_string = "k";
167 call vdump;
168 lgnc = nc;
169 return;
170
171 ;
172 rule(0015):
173 ns_string = "K";
174 call vdump;
175 lgnc = nc;
176 return;
177
178
179 rule(0016):
180 s1_ptr = addr(ls(lst-2));
181 ns_string = substr (s1.pt->is,s1.loc,s1.num);
182 call vdump;
183 lgnc = nc;
184 return;
185 vdump: proc;
186 do ii = 1 to length(ns_string);
187 ch2 = substr (ns_string, ii, 1);
188 if (ch2 = "a")
189 then do i = alb to aub;
190 if (av(i) ^= 0)
191 then call ioa_("a[^4d] = ^d",i,av(i));
192 end;
193 else if (ch2 = "k")
194 then do i = klb to kub;
195 if (k(i) ^= "")
196 then call ioa_("k[^4d] = ""^va""",i,length(k(i)),k(i));
197 end;
198 else if (ch2 = "K")
199 then do i = Klb to Kub;
200 if (K(i) ^= "")
201 then call ioa_("K[^4d] = ""^va""",i,length(K(i)),K(i));
202 end;
203 else if (ch2 = "v")
204 then do;
205 next_avar = val.avar;
206 do avar_ptr = pointer (lval_ptr, next_avar)
207 repeat (pointer (lval_ptr, next_avar))
208 while (next_avar ^= "0"b);
209 next_avar = avar.next;
210 if (avar.type = AEXP)
211 then call ioa_ ("^a = ^i", avar.name, avar.num);
212 else if (avar.type = LEXP)
213 then call ioa_ ("^a = ^[true^;false^]",
214 avar.name, (avar.num^=0));
215 else if (avar.type = CAT)
216 then do;
217 cat_p = pointer (lval_ptr, avar.txt_r);
218 call ioa_ ("^a = ""^va""", avar.name,
219 length (catv.text), catv.text);
220 end;
221 end;
222 end;
223 else do;
224 msg = "Vds) Invalid dump specifier ";
225 goto err_text;
226 end;
227 end;
228 end;
229
230
231
232
233 ;
234 rule(0018):
235 call make(AEXP,lst-3);
236 call make(AEXP,lst);
237 av(cka(ls.num(lst-3))) = ls.num(lst);
238 ls(lst-4) = ls(lst);
239 return;
240
241 ;
242 rule(0019):
243 call make(AEXP,lst-3);
244 call make(CAT,lst);
245 k(ckk(ls.num(lst-3))) = substr(ls.pt(lst)->is,ls.loc(lst),ls.num(lst));
246 ls(lst-4) = ls(lst);
247 return;
248
249 ;
250 rule(0020):
251 call make(AEXP,lst-3);
252 call make(CAT,lst);
253 K(ckK(ls.num(lst-3))) = substr(ls.pt(lst)->is,ls.loc(lst),ls.num(lst));
254 ls(lst-4) = ls(lst);
255 return;
256
257
258 rule(0021):
259 call make(CAT,lst);
260 ls.type(lst) = ABREV;
261
262
263 rule(0022):
264 avar_ptr = ls.pt (lst-1);
265 avar.type = ls.type (lst);
266 if (ls.type (lst) = AEXP)
267 | (ls.type (lst) = LEXP)
268 then do;
269 if (avar.txt_r ^= "0"b)
270 then do;
271 cat_p = pointer (lval_ptr, avar.txt_r);
272 free catv in (cata);
273 avar.txt_r = "0"b;
274 end;
275 avar.num = ls.num (lst);
276 ls(lst-1) = ls(lst);
277 return;
278 end;
279 avar_len, cat_l = ls.num (lst);
280 if (avar.txt_r = "0"b)
281 then do;
282 allocate catv in (cata);
283 avar.txt_r = rel (cat_p);
284 end;
285 else cat_p = pointer (lval_ptr, avar.txt_r);
286 if (catv.len ^= avar_len)
287 then do;
288 free catv in (cata);
289 allocate catv in (cata);
290 avar.txt_r = rel (cat_p);
291 end;
292 catv.text = substr(ls.pt(lst)->is,ls.loc(lst),avar_len);
293 ls(lst-1) = ls(lst);
294 return;
295
296 dcl azAZ09 char(62) int static init("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");
297
298
299 rule(0023):
300 if (ls.pt (lst-1) ^= null())
301 then return;
302 ns_string = substr (ls.symptr(lst-1) ->is, 1, ls.symlen(lst-1));
303 ls.type (lst-1) = AEXP;
304 goto setup_avar;
305
306
307 rule(0024):
308 if (length(ns_string)>16)
309 | (length(ns_string)=0)
310 then do;
311 msg = "Vnl) Abbrev-name length not 1-16 ";
312 goto err_text;
313 end;
314 if (verify(ns_string,azAZ09) ^= 0)
315 | (substr(ns_string,1,1) < "A")
316 then do;
317 msg = "Vin) Illegal abbrev name ";
318 goto err_text;
319 end;
320 ls.type (lst-1) = ABREV;
321 dcl next_avar bit (18);
322 next_avar = val.avar;
323 do avar_ptr = pointer (lval_ptr, next_avar)
324 repeat (pointer (lval_ptr, next_avar))
325 while (next_avar ^= "0"b);
326 next_avar = avar.next;
327 if (avar.name = ns_string)
328 then do;
329 ls.pt (lst-1) = avar_ptr;
330 return;
331 end;
332 end;
333 setup_avar:
334 allocate avar in (cata);
335 avar.name = ns_string;
336
337 avar.txt_r = "0"b;
338 avar.type = ls.type (lst-1);
339 ls.pt (lst-1) = avar_ptr;
340 avar.next = val.avar;
341 val.avar = rel (avar_ptr);
342 return;
343
344
345 ;
346 rule(0025):
347 sr_ptr = addr(ls(lst-2));
348 i = ls.num(lst-1);
349 sr.pt = addrel(addr(k(ckk(i))),1);
350 sr.loc = 1;
351 sr.num = length(k(i));
352 goto kexp_return;
353
354 ;
355 rule(0026):
356 sr_ptr = addr(ls(lst-2));
357 i = ls.num(lst-1);
358 sr.pt = addrel(addr(K(ckK(i))),1);
359 sr.loc = 1;
360 sr.num = length(K(i));
361 goto kexp_return;
362
363
364 rule(0027):
365 i = ls.num(lst-1);
366 sr_ptr = addr(ls(lst-2));
367 sv_p = dbase.stk_info.top;
368 if (sv_p = null())
369 then do;
370 maybe_null_str:
371 if (i = 0)
372 then do;
373 sr.pt = addr(dbase.err_go);
374 sr.loc = 1;
375 sr.num = 0;
376 goto kexp_return;
377 end;
378 end;
379 else if (sv.pn = 0)
380 then goto maybe_null_str;
381 if (i < 0)
382 | (i > sv.pn)
383 then do;
384 msg = "Vsp) Subscript not in range p[0:pn] ";
385 goto err_text;
386 end;
387 sr.pt = sv.pp(i);
388 sr.loc = 1;
389 sr.num = sv.pl(i);
390 goto kexp_return;
391
392 ;
393 rule(0028):
394 lsbe = "Ks";
395 sr_ptr = addr(ls(lst));
396 if (ams_p ^= null())
397 then do;
398 sr.pt = ams_p;
399 sr.loc = 1;
400 sr.num = ams_l;
401 goto kexp_return;
402 end;
403 sr.pt = b.cur.sp;
404 sr.loc = valid(b.a_.l.re(1),"Ks ");
405 sr.num = b.a_.r.le(2);
406 goto check_split;
407
408 ;
409 rule(0029):
410 lsbe = "Kl";
411 sr_ptr = addr(ls(lst));
412 sr.pt = b.cur.sp;
413 sr.loc = valid(b.a_.l.le(1),"Kl ");
414 sr.num = b.a_.r.re(2);
415 goto check_split;
416
417 ;
418 rule(0030):
419 lsbe = "Kb";
420 sr_ptr = addr(ls(lst));
421 sr.pt = b.cur.sp;
422 sr.loc = b.b_.l.le;
423 if (b.b_.l.re < b.b_.l.le)
424 then sr.loc = b.b_.r.le;
425 sr.num = b.b_.r.re;
426 if (b.b_.r.le > b.b_.r.re)
427 then sr.num = b.b_.l.re;
428 check_split:
429 tsb = sr.loc;
430 tse = sr.num;
431 dcl (tsb, tse) fixed bin (21);
432 if (sr.loc <= b.b_.l.re) & (sr.num >= b.b_.r.le)
433 then do;
434
435 ti = sr.loc;
436 j = b.b_.l.re - sr.loc + 1;
437 i = sr.num - b.b_.r.le + 1;
438 cat_l = j + i;
439 call alloc;
440
441 substr (catv.text, 1, j) = substr (b_s, ti, j);
442 substr (catv.text, j+1, i) = substr (b_s, b.b_.r.le, i);
443 end;
444 if db_eval | db_sw then call ioa_$ioa_switch (db_output,
445 "^a^4(,^i^) ^5i:^5i->^5i:^5i",
446 lsbe, b.b_.l.le, b.b_.l.re, b.b_.r.le, b.b_.r.re,
447 tsb, tse, sr.loc, sr.num);
448 sr.num = sr.num - sr.loc + 1;
449 goto kexp_return;
450
451 ;
452 rule(0031):
453 ascii = collate9();
454 sr_ptr = addr(ls(lst));
455 sr.pt = addr(ascii);
456 sr.loc = 1;
457 sr.num = 512;
458 goto kexp_return;
459
460 dcl ascii char(512);
461 ;
462 rule(0032):
463 sr_ptr = addr(ls(lst));
464 cat_l = length(ns_string);
465 call alloc;
466 catv.text = ns_string;
467 goto kexp_return;
468
469 ;
470 rule(0033):
471 call make(CAT,lst-1);
472 call make(CAT,lst-3);
473 sr_ptr = addr(ls(lst-5));
474 ns_string = substr(ls.pt(lst-1)->is,ls.loc(lst-1),ls.num(lst-1));
475 cv = substr(ls.pt(lst-3)->is,ls.loc(lst-3),ls.num(lst-3));
476 if (length(ns_string) = 0)
477 then sr = ls (lst-3);
478 else do;
479 dcl (sign,fill) char(1);
480 dcl (units,z_sup) bit(1);
481 dcl (hexd,ti,nibble) fixed bin(21);
482 dcl hexdigits char(16)int static init("0123456789ABCDEF");
483 j = length(cv);
484 if (substr(cv,1,1) = "-") then do;
485 sign = "-";
486 cv = substr(cv,2,j-1);
487 j = j - 1;
488 end;
489 else
490 sign = " ";
491 units = "1"b;
492 z_sup = "0"b;
493 fill = " ";
494 do i = length(ns_string) to 1 by -1;
495 mc = substr(ns_string,i,1);
496 if (mc = " ") then do;
497 z_sup = "1"b;
498 if units then do;
499 if (cv = "0") then
500 j = 0;
501 end;
502 end;
503 if units then
504 if (mc = "*")
505 | (mc = "$") then do;
506 fill = mc;
507 mc = " ";
508 end;
509 else
510 if (mc = "-") then do;
511 fill = sign;
512 mc = " ";
513 end;
514 else do;
515 hexd = index("XxOo",mc);
516 if (hexd ^= 0)
517 then do;
518 if (hexd > 2)
519 then nibble = 3;
520 else nibble = 4;
521 j = fixed(cv,35);
522 dcl jb bit(36)based(addr(j));
523 cv = "";
524 do ti = 1 to 36 by nibble;
525 hexd = fixed(substr(jb,ti,nibble),17);
526 if (cv ^= "") | (hexd ^= 0)
527 then cv = cv || substr(hexdigits,hexd+1,1);
528 end;
529 if (cv = "")
530 then cv = "0";
531 j = length(cv);
532 mc = " ";
533 end;
534 end;
535 if (mc = " ")
536 | (mc = "0") then do;
537 if (j > 0) then do;
538 substr(ns_string,i,1) = substr(cv,j,1);
539 j = j - 1;
540 end;
541 else
542 if (mc = " ") then
543 if ^units then do;
544 mc = ".";
545 end;
546 units = "0"b;
547 end;
548 if (mc = ",")
549 | (mc = ".") then do;
550 if z_sup & (j < 1) then do;
551 substr(ns_string,i,1) = fill;
552 if (fill ^= "*") then
553 fill = " ";
554 end;
555 end;
556 if (mc = "~") then
557 substr(ns_string,i,1) = " ";
558 end;
559 if (substr(ns_string,1,1) = "-") then
560 substr(ns_string,1,1) = sign;
561 cat_l = length(ns_string);
562 call alloc;
563 catv.text = ns_string;
564 end;
565 goto kexp_return;
566
567
568
569 ;
570 rule(0034):
571 begin;
572
573 dcl (i, ifr, ito) fixed bin (21);
574
575 call make(AEXP,lst-1);
576 if (alternative_number = 1)
577 then do;
578 call make(CAT,lst-3);
579 s1_ptr = addr(ls(lst-3));
580 sr_ptr = addr(ls(lst-5));
581 ito, ifr = ls.num(lst-1);
582 if (ifr > 0)
583 then ito = s1.num - ito + 1;
584 end;
585 else do;
586 call make(AEXP, lst-3);
587 call make(CAT,lst-5);
588 s1_ptr = addr(ls(lst-5));
589 sr_ptr = addr(ls(lst-7));
590 ifr = ls.num(lst-3);
591 ito = ls.num(lst -1);
592 if (alternative_number = 3)
593 then do;
594 if (ito < 0)
595 then ito = s1.num + ito + 1;
596 if (ifr > ito)
597 then ifr = 0;
598 ito = ito - ifr + 1;
599 end;
600 end;
601 if (ifr < 0)
602 then ifr = max (1, s1.num + ifr + 1);
603 if (ifr > s1.num) | (ifr = 0)
604 then do;
605 msg = "Vfs) substr from outside string ";
606 goto err_text;
607 end;
608 cat_l = abs(ito);
609 call alloc;
610 sr.num = 0;
611 if (ifr < 0)
612 then do;
613 ifr = -ifr;
614 if (ito > 0)
615 then do;
616 ifr = min(ifr + 1,ito);
617 ito = max(0,ito - ifr);
618 end;
619 else do;
620 ifr = min(ifr,-ito);
621 ito = min(ito + ifr,0);
622 end;
623 substr(catv.text,1,ifr) = " ";
624 sr.num = ifr;
625 ifr = 1;
626 end;
627 if (ito < 0) then do;
628 ito = -ito;
629 i = s1.num - ifr + 1;
630 if (i < ito) then do;
631 i = ito - i;
632 substr (catv.text, sr.num+1, i) = " ";
633 sr.num = sr.num + i;
634 ito = ito - i;
635 end;
636 end;
637 substr (catv.text, sr.num+1, ito)
638 = substr (s1.pt->is, ifr + s1.loc - 1, min ((s1.num-ifr+1), ito));
639 sr.num = sr.num + ito;
640 end;
641 goto kexp_return;
642
643 ;
644 dcl XXloc(4) ptr;
645 dcl XXnum(4) fixed bin(21);
646 rule(0035):
647 call make(CAT,lst-1);
648 call make(CAT,lst-3);
649 call make(CAT,lst-5);
650 s1_ptr = addr(ls(lst-5));
651 s2_ptr = addr(ls(lst-3));
652 XXloc(4) = addr(s2.pt->ic(s2.loc));
653 XXnum(4) = s2.num;
654 i = index(substr(s1.pt->is,s1.loc,s1.num),substr(s2.pt->is,s2.loc,s2.num));
655 if (i = 0)
656 then do;
657 XXloc(1), XXloc(2), XXloc(3) = addr(s1.pt->ic(s1.loc));
658 XXnum(1) = s1.num;
659 XXnum(2), XXnum(3) = 0;
660 end;
661 else do;
662 XXloc(1) = addr(s1.pt->ic(s1.loc));
663 XXnum(1) = i-1;
664 XXloc(2) = addr(XXloc(1)->ic(i));
665 XXnum(2) = s2.num;
666 XXloc(3) = addr(XXloc(2)->ic(s2.num+1));
667 XXnum(3) = s1.num - XXnum(1) - XXnum(2);
668 end;
669 s2_ptr = addr(ls(lst-1));
670 cat_l = 0;
671 do i = 1 to s2.num;
672 ii = index("bmas",substr(s2.pt->is,i,1));
673 if (ii = 0)
674 then do;
675 msg = "Vrs) Improper control string. ";
676 goto err_text;
677 end;
678 cat_l = cat_l + XXnum(ii);
679 end;
680 sr_ptr = addr(ls(lst-7));
681 call alloc;
682 sr.num = 0;
683 do i = 1 to s2.num;
684 ii = index("bmas",substr(s2.pt->is,i,1));
685 substr(catv.text,sr.num+1,XXnum(ii))
686 = substr(XXloc(ii)->is,1,XXnum(ii));
687 sr.num = sr.num + XXnum(ii);
688 end;
689 goto kexp_return;
690
691 ;
692 rule(0036):
693 sr_ptr = addr( ls(lst-5));
694 call make(LEXP,lst-3);
695 sr.pt = ls.pt(lst-1);
696 sr.type = ls.type(lst-1);
697 sr.loc = ls.loc(lst-1);
698 sr.num = ls.num(lst-1);
699 if (ls.num(lst-3) = 0)
700 then do;
701 sr.type = CAT;
702 sr.num = 0;
703 end;
704 goto kexp_return;
705
706 ;
707 rule(0037):
708 sr_ptr = addr( ls(lst-7));
709 call make(LEXP,lst-5);
710 if (ls.num(lst-5) ^= 0)
711 then do;
712 sr.pt = ls.pt(lst-3);
713 sr.type = ls.type(lst-3);
714 sr.loc = ls.loc(lst-3);
715 sr.num = ls.num(lst-3);
716 end;
717 else do;
718 sr.pt = ls.pt(lst-1);
719 sr.type = ls.type(lst-1);
720 sr.loc = ls.loc(lst-1);
721 sr.num = ls.num(lst-1);
722 end;
723 return;
724
725 ;
726 rule(0038):
727 avar_ptr = ls.pt (lst);
728 if (avar_ptr = null())
729 then do;
730 msg = "Vnd) Variable not defined";
731 goto err_text;
732 end;
733 ls.type (lst) = avar.type;
734 if (avar.type ^= CAT)
735 then ls.num(lst) = avar.num;
736 else do;
737 cat_p = pointer (lval_ptr, avar.txt_r);
738 ls.pt (lst) =addr (catv.text);
739 ls.loc (lst) = 1;
740 ls.num (lst) = catv.len;
741 end;
742 return;
743
744 ;
745 rule(0039):
746 sr_ptr = addr(ls(lst));
747 i = index(b.name," ")-1;
748 if (i = -1) then
749 i = 16;
750 sr.pt = addr(b.name);
751 sr.loc = 1;
752 sr.num = i;
753 goto kexp_return;
754
755 ;
756 rule(0040):
757 sr_ptr = addr(ls(lst));
758 i = index(b.dname," ")-1;
759 if (i = -1) then
760 i = 168;
761 sr.pt = addr(b.dname);
762 goto kexp_path;
763
764 ;
765 rule(0041):
766 sr_ptr = addr(ls(lst));
767 i = index(b.ename," ")-1;
768 if (i = -1) then
769 i = 32;
770 sr.pt = addr(b.ename);
771 goto kexp_path;
772
773 ;
774 rule(0042):
775 sr_ptr = addr(ls(lst));
776 i = index(b.cname," ")-1;
777 if (i = -1) then
778 i = 32;
779 sr.pt = addr(b.cname);
780 goto kexp_path;
781
782 ;
783 rule(0043):
784 sr_ptr = addr(ls(lst));
785 i = 1;
786 sr.pt = addr(b.kind);
787 kexp_path:
788 sr.loc = 1;
789 if b.file_sw
790 then sr.num = i;
791 else sr.num = 0;
792 goto kexp_return;
793
794
795
796 rule(0044):
797 sr_ptr = addr(ls(lst));
798 sr.pt = addrel(addr(err_msg),1);
799 sr.loc = 1;
800 sr.num = length(err_msg);
801 goto kexp_return;
802
803
804 rule(0045):
805 sr_ptr = addr(ls(lst-2));
806 sr.pt = addrel(addr(err_msg),1);
807 sr.loc = 6;
808 sr.num = max (0, length(err_msg)-5);
809 goto kexp_return;
810
811
812 rule(0046):
813 sr_ptr = addr(ls(lst-2));
814 sr.pt = addrel(addr(err_msg),1);
815 sr.loc = 1;
816 sr.num = 3;
817 goto kexp_return;
818
819 ;
820
821 rule(0048):
822 call make (CAT, lst);
823 call make (CAT, lst-2);
824 sr_ptr, s1_ptr = addr(ls(lst-2));
825 s2_ptr = addr(ls(lst));
826 goto concatenate;
827
828
829 rule(0049):
830 call make (CAT, lst);
831 call make (CAT, lst-1);
832 sr_ptr, s1_ptr = addr(ls(lst-1));
833 s2_ptr = addr(ls(lst));
834 if ^conc_sw
835 then do;
836 conc_sw = "1"b;
837 call ioa_$nnl("Warning: || operator missing. ");
838 call tedwhere_ (dbase_p);
839 end;
840 concatenate:
841 sx_ptr = addr( ls(lst+1));
842 sx = s1;
843 cat_l = sx.num + s2.num;
844 dcl 1 sx like ls based(sx_ptr);
845 dcl sx_ptr ptr;
846 call alloc;
847 substr(catv.text,1,s1.num) = substr(sx.pt->is,sx.loc,sx.num);
848 substr(catv.text,sx.num+1,s2.num) = substr(s2.pt->is,s2.loc,s2.num);
849 kexp_return:
850 sr.type = CAT;
851 return;
852
853
854 rule(0050):
855 call make(CAT,lst-1);
856 if (ls.num(lst-1) > 0)
857 then call ns_alt(ls.pt(lst-1),ls.loc(lst-1),ls.num(lst-1));
858 return;
859
860
861 ;
862 rule(0051):
863 i = max (ls.type (lst), ls.type (lst-2));
864 call make (i, lst);
865 call make (i, lst-2);
866 ls.type(lst-2) = LEXP;
867 s1_ptr = addr(ls(lst-2));
868 s2_ptr = addr(ls(lst));
869 if (i = CAT)
870 then do;
871 if (substr(s1.pt->is,s1.loc,s1.num) < substr(s2.pt->is,s2.loc,s2.num))
872 then comp = "100"b;
873 else if (substr(s1.pt->is,s1.loc,s1.num) > substr(s2.pt->is,s2.loc,s2.num))
874 then comp = "001"b;
875 else comp = "010"b;
876 end;
877 else do;
878 if (s1.num < s2.num)
879 then comp = "100"b;
880 else if (s1.num > s2.num)
881 then comp = "001"b;
882 else comp = "010"b;
883 end;
884 if ls.mask(lst-1)&comp
885 then ls.num(lst-2) = 1;
886 else ls.num(lst-2) = 0;
887 ls.type (lst-2) = LEXP;
888 return;
889
890
891 rule(0052):
892 dcl R(1:4) fixed bin(21);
893
894 call make (CAT,lst);
895 call make (CAT,lst-3);
896 ls.type(lst-3) = LEXP;
897 s1_ptr = addr(ls(lst-3));
898 s2_ptr = addr(ls(lst));
899 cat_l = s1.num + s2.num;
900 allocate catv in (cata);
901 R(1) = 1;
902 substr(catv.text,R(1),s1.num) = substr(s1.pt->is,s1.loc,s1.num);
903 R(2), R(3) = R(1) + s1.num;
904 substr(catv.text,R(3),s2.num) = substr(s2.pt->is,s2.loc,s2.num);
905 R(4) = R(3) + s2.num;
906 dcl tedsort_$compare entry(ptr,ptr,bit(3));
907 call tedsort_$compare (addr(catv.text),addr(R),comp);
908 free catv;
909 if ls.mask(lst-1)&comp
910 then ls.num(lst-3) = 1;
911 else ls.num(lst-3) = 0;
912 ls.type (lst-3) = LEXP;
913 return;
914
915
916 rule(0053):
917 dcl relmask(1:6) bit(36)int static init("010"b, "101"b, "011"b, "110"b, "100"b, "001"b );
918 ls.mask(lst) = relmask(alternative_number);
919 return;
920
921 ;
922 rule(0054):
923 call make (AEXP,lst);
924 call make (AEXP,lst-2);
925 ls.type(lst-2) = AEXP;
926 ls.num(lst-2) = ls.num(lst-2) + ls.num(lst);
927 return;
928
929 ;
930 rule(0055):
931 call make (AEXP,lst);
932 call make (AEXP,lst-2);
933 ls.type(lst-2) = AEXP;
934 ls.num(lst-2) = ls.num(lst-2) - ls.num(lst);
935 return;
936
937
938
939
940 ;
941 rule(0057):
942 call make (AEXP,lst);
943 call make (AEXP,lst-2);
944 ls.type(lst-2) = AEXP;
945 ls.num(lst-2) = ls.num(lst-2) * ls.num(lst);
946 return;
947
948 ;
949 rule(0058):
950 call make (AEXP,lst);
951 call make (AEXP,lst-2);
952 ls.type(lst-2) = AEXP;
953 ls.num(lst-2) = divide(ls.num(lst-2),ls.num(lst),17,0);
954 return;
955
956 ;
957 rule(0059):
958 call make (AEXP,lst);
959 call make (AEXP,lst-2);
960 ls.type(lst-2) = AEXP;
961 ls.num(lst-2) = mod(ls.num(lst-2),ls.num(lst));
962 return;
963
964
965
966 ;
967
968 ;
969 rule(0062):
970 call make(AEXP, lst);
971 ls(lst-1) = ls(lst);
972 return;
973
974
975 rule(0063):
976 call make(AEXP, lst);
977 ls(lst-1) = ls(lst);
978 ls.num(lst-1) = - ls.num(lst-1);
979 return;
980
981 ;
982
983
984 rule(0065):
985 ls(lst-2) = ls(lst-1);
986 return;
987
988 ;
989 rule(0066):
990 ls.num(lst-2) = av((cka(ls.num(lst-1))));
991 ls.type(lst-2) = AEXP;
992 return;
993
994 ;
995 rule(0067):
996 call make(AEXP,lst-1);
997 ls(lst-3) = ls(lst-1);
998 return;
999
1000 ;
1001 rule(0068):
1002 ls.type(lst) = AEXP;
1003 return;
1004
1005
1006 rule(0069):
1007 sv_p = dbase.stk_info.top;
1008 if (sv_p = null())
1009 then ls.num (lst) = 0;
1010 else ls.num(lst) = sv.pn;
1011 ls.type(lst) = AEXP;
1012 return;
1013
1014
1015 rule(0070):
1016 ls.num(lst) = argct;
1017 ls.type(lst) = AEXP;
1018 return;
1019
1020
1021
1022 rule(0071):
1023 ls.num(lst-2) = S_count;
1024 ls.type(lst-2) = AEXP;
1025 return;
1026
1027
1028 dcl lsbe char (4);
1029 ;
1030 rule(0072):
1031 lsbe = "lb";
1032 if (b.cur.sn > 0)
1033 then ls.num(lst) = valid(b.a_.l.le(1),"lb ");
1034 else ls.num(lst) = 0;
1035 goto check_offset;
1036
1037 ;
1038 rule(0073):
1039 lsbe = "sb";
1040 if (ams_p ^= null())
1041 then ls.num(lst) = 1;
1042 else if (b.cur.sn > 0)
1043 then ls.num(lst) = valid(b.a_.l.re(1),"sb ");
1044 else ls.num(lst) = 0;
1045 goto check_offset;
1046
1047 ;
1048 rule(0074):
1049 lsbe = "se";
1050 if (ams_p ^= null())
1051 then ls.num(lst) = ams_l;
1052 else if (b.cur.sn > 0)
1053 then ls.num(lst) = valid(b.a_.r.le(2),"se ");
1054 else ls.num(lst) = 0;
1055 goto check_offset;
1056
1057 ;
1058 rule(0075):
1059 lsbe = "le";
1060 if (b.cur.sn > 0)
1061 then ls.num(lst) = valid(b.a_.r.re(2),"le ");
1062 else ls.num(lst) = 0;
1063 goto check_offset;
1064
1065 ;
1066 rule(0076):
1067 lsbe = "be";
1068
1069
1070 ls.num(lst) = b.b_.r.re;
1071 check_offset:
1072 ls.type(lst) = AEXP;
1073 if (ams_p ^= null())
1074 then do;
1075 if db_eval | db_sw then call ioa_$ioa_switch (db_output,
1076 "^a \g{ ^i", lsbe, i);
1077 return;
1078 end;
1079 tsb = ls.num (lst);
1080 if (ls.num(lst) > b.b_.l.re)
1081 then do;
1082 ls.num(lst) = ls.num(lst) - (b.b_.r.le - b.b_.l.re - 1);
1083 end;
1084 if db_eval | db_sw then call ioa_$ioa_switch (db_output,
1085 "^a^4(,^i^) ^5i->^5i", lsbe,
1086 b.b_.l.le, b.b_.l.re, b.b_.r.le, b.b_.r.re, tsb, ls.num(lst));
1087 return;
1088
1089 ;
1090 rule(0077):
1091 ls.num(lst) = 2;
1092 return;
1093
1094 ;
1095 rule(0078):
1096 ls.num(lst) = 1;
1097 return;
1098
1099
1100 rule(0079):
1101
1102 rule(0080):
1103 ls(lst-3) = ls(lst-1);
1104 return;
1105
1106 ;
1107
1108
1109
1110 rule(0082):
1111 call make(AEXP,lst);
1112 call make(AEXP,lst-2);
1113 if (ls.num(lst-4) = 1)
1114 then ls.num(lst-2) = min(ls.num(lst-2),ls.num(lst));
1115 else ls.num(lst-2) = max(ls.num(lst-2),ls.num(lst));
1116 ls.type (lst-2) = AEXP;
1117 return;
1118
1119 ;
1120 rule(0083):
1121 call make (CAT,lst-1);
1122 ls.num(lst-3) = ls.num(lst-1);
1123 ls.type (lst-3) = AEXP;
1124 return;
1125
1126 ;
1127 rule(0084):
1128 call make (CAT,lst-1);
1129 call make (CAT,lst-3);
1130 s1_ptr = addr(ls(lst-3));
1131 s2_ptr = addr(ls(lst-1));
1132 ls.num(lst -5) = search (
1133 substr(s1.pt->is,s1.loc,s1.num),
1134 substr(s2.pt->is,s2.loc,s2.num));
1135 ls.type (lst-5) = AEXP;
1136 return;
1137 ;
1138 rule(0085):
1139 call make (CAT,lst-1);
1140 call make (CAT,lst-3);
1141 s1_ptr = addr(ls(lst-3));
1142 s2_ptr = addr(ls(lst-1));
1143 ls.num(lst -5) = search(reverse(substr(s1.pt->is,s1.loc,s1.num)),
1144 substr(s2.pt->is,s2.loc,s2.num));
1145 ls.type (lst-5) = AEXP;
1146 return;
1147
1148 ;
1149 rule(0086):
1150 call make (CAT,lst-1);
1151 call make (CAT,lst-3);
1152 s1_ptr = addr(ls(lst-3));
1153 s2_ptr = addr(ls(lst-1));
1154 ls.num(lst -5) = index (
1155 substr(s1.pt->is,s1.loc,s1.num),
1156 substr(s2.pt->is,s2.loc,s2.num));
1157 ls.type (lst-5) = AEXP;
1158 return;
1159
1160 ;
1161 rule(0087):
1162 call make (CAT,lst-1);
1163 call make (CAT,lst-3);
1164 s1_ptr = addr(ls(lst-3));
1165 s2_ptr = addr(ls(lst-1));
1166 if (s2.num = 1)
1167
1168 then ls.num(lst -5)
1169 = index (reverse( substr(s1.pt->is,s1.loc,s1.num)),
1170 substr(s2.pt->is,s2.loc,s2.num));
1171 else ls.num(lst -5)
1172 = index (reverse( substr(s1.pt->is,s1.loc,s1.num)),
1173 reverse (substr(s2.pt->is,s2.loc,s2.num)));
1174 ls.type (lst-5) = AEXP;
1175 return;
1176
1177 ;
1178 rule(0088):
1179 call make (CAT,lst-1);
1180 call make (CAT,lst-3);
1181 s1_ptr = addr(ls(lst-3));
1182 s2_ptr = addr(ls(lst-1));
1183 ls.num(lst -5) = verify(substr(s1.pt->is,s1.loc,s1.num),substr(s2.pt->is,s2.loc,s2.num));
1184 ls.type (lst-5) = AEXP;
1185 return;
1186 ;
1187 rule(0089):
1188 call make (CAT,lst-1);
1189 call make (CAT,lst-3);
1190 s1_ptr = addr(ls(lst-3));
1191 s2_ptr = addr(ls(lst-1));
1192 ls.num(lst -5) = verify(reverse(substr(s1.pt->is,s1.loc,s1.num)),
1193 substr(s2.pt->is,s2.loc,s2.num));
1194 ls.type (lst-5) = AEXP;
1195 return;
1196 ;
1197 rule(0090):
1198 call make (CAT,lst-3);
1199 s1_ptr = addr(ls(lst-3));
1200 s2_ptr = addr(ls(lst-1));
1201 ii = 0;
1202 do i = s1.loc to s1.loc+s1.num-1;
1203 ii = ii + 1;
1204 j = fixed(unspec(substr(s1.pt->is,i,1)));
1205 if set(j) & s2.mask
1206 then do;
1207 ls.num(lst-5) = ii;
1208 ls.type (lst-5) = AEXP;
1209 return;
1210 end;
1211 end;
1212 ls.num(lst-5) = 0;
1213 ls.type (lst-5) = AEXP;
1214 return;
1215
1216
1217 ;
1218 rule(0091):
1219 call make (CAT,lst-3);
1220 s1_ptr = addr(ls(lst-3));
1221 s2_ptr = addr(ls(lst-1));
1222 ii = 0;
1223 do i = s1.loc+s1.num-1 to s1.loc by -1;
1224 ii = ii + 1;
1225 j = fixed(unspec(substr(s1.pt->is,i,1)));
1226 if set(j) & s2.mask
1227 then do;
1228 ls.num(lst-5) = ii;
1229 ls.type (lst-5) = AEXP;
1230 return;
1231 end;
1232 end;
1233 ls.num(lst-5) = 0;
1234 ls.type (lst-5) = AEXP;
1235 return;
1236
1237
1238 ;
1239 rule(0092):
1240 call make (CAT,lst-3);
1241 s1_ptr = addr(ls(lst-3));
1242 s2_ptr = addr(ls(lst-1));
1243 ii = 0;
1244 do i = s1.loc to s1.loc+s1.num-1;
1245 ii = ii + 1;
1246 j = fixed(unspec(substr(s1.pt->is,i,1)));
1247 if set(j) & s2.mask
1248 then;
1249 else do;
1250 ls.num(lst-5) = ii;
1251 ls.type (lst-5) = AEXP;
1252 return;
1253 end;
1254 end;
1255 ls.num(lst-5) = 0;
1256 ls.type (lst-5) = AEXP;
1257 return;
1258
1259
1260 ;
1261 rule(0093):
1262 call make (CAT,lst-3);
1263 s1_ptr = addr(ls(lst-3));
1264 s2_ptr = addr(ls(lst-1));
1265 ii = 0;
1266 do i = s1.loc+s1.num-1 to s1.loc by -1;
1267 ii = ii + 1;
1268 j = fixed(unspec(substr(s1.pt->is,i,1)));
1269 if set(j) & s2.mask
1270 then;
1271 else do;
1272 ls.num(lst-5) = ii;
1273 ls.type (lst-5) = AEXP;
1274 return;
1275 end;
1276 end;
1277 ls.num(lst-5) = 0;
1278 ls.type (lst-5) = AEXP;
1279 return;
1280
1281
1282
1283
1284
1285 rule(0094):
1286 begin;
1287 dcl leng fixed bin(21);
1288 dcl lc fixed bin(21);
1289 dcl i fixed bin(21);
1290 dcl ii fixed bin(21);
1291 dcl NL char(1)int static init("
1292 ");
1293
1294 leng = b.b_.r.re;
1295 if (alternative_number = 1)
1296 then leng = valid(b.a_.l.le(1),"lb ");
1297 if (alternative_number = 2)
1298 then leng = valid(b.a_.r.re(2),"le ");
1299 call tedcount_lines_ (bp, b.b_.l.le, leng, ls.num (lst-3));
1300
1301 ls.type (lst-3) = AEXP;
1302 end;
1303 return;
1304
1305 make: proc(typ,at);
1306
1307 dcl typ fixed bin (21);
1308 dcl at fixed bin (21);
1309
1310 (subscriptrange): goto fn(ls.type(at)*3+typ);
1311 fn(0):
1312 fn(8):
1313 fn(4):
1314 return;
1315
1316 dcl fb35 fixed bin (35);
1317 fn(1):
1318 fb35 = ls.num(at);
1319 cv = ltrim(char(fb35));
1320 set_string:
1321 sr_ptr = addr(ls(at));
1322 cat_l = length (cv);
1323 call alloc;
1324 catv.text = cv;
1325 ls.type (at) = CAT;
1326 return;
1327
1328 fn(2):
1329 if (ls.num(at) ^= 0)
1330 then ls.num(at) = 1;
1331 ls.type (at) = LEXP;
1332 return;
1333
1334 fn(3):
1335 ns_string = substr(ls.pt(at)->is,ls.loc(at),ls.num(at));
1336 if (verify(ns_string," 0123456789") ^= 0)
1337 then do;
1338 if (index ("+-", substr (ns_string,1,1)) = 0)
1339 | (verify( substr (ns_string, 2)," 0123456789") ^= 0)
1340 then do;
1341 msg = "Vbd) Bad decimal digit. """;
1342 msg = msg || ns_string;
1343 msg = msg || """";
1344 goto err_ret;
1345 end;
1346 end;
1347 ls.num(at) = fixed(ns_string,35);
1348 ls.type(at) = AEXP;
1349 return;
1350
1351 fn(5):
1352 ns_string = "-";
1353 ns_string = ns_string
1354 || substr(ls.pt(at)->is,ls.loc(at),ls.num(at));
1355 ns_string = ns_string || "-";
1356 if (index ("-false-no-f-n-",ns_string) ^= 0)
1357 then ls.num(at) = 0;
1358 else ls.num(at) = 1;
1359 ls.type(at) = LEXP;
1360 return;
1361
1362 fn(6):
1363 ls.type(at) = AEXP;
1364 return;
1365
1366 fn(7):
1367 if (ls.num(at) = 0)
1368 then cv = "false";
1369 else cv = "true";
1370 goto set_string;
1371
1372 end;
1373
1374
1375 valid$match: proc (val,str)returns(fixed bin (21));
1376
1377
1378
1379 valid: entry(val,str)returns(fixed bin(21));
1380
1381 dcl val fixed bin(21);
1382 dcl str char(3);
1383
1384 if (ams_p ^= null())
1385 then msg = "Vng) Value undefined in \g{} usage- ";
1386 else if ^b.present(1)
1387 then do;
1388 if (ams_l < 0)
1389 then msg = "Vni) Value undefined in input function- ";
1390 else msg = "Vna) Value undefined when no addr- ";
1391 msg = msg || str;
1392 goto err_text;
1393 end;
1394 return(val);
1395
1396 end;
1397
1398 dcl ( rule_number,
1399 alternative_number ) fixed bin(21) parm;
1400
1401 dcl ii fixed bin(21);
1402 dcl bits(2000) bit(9)based(s1.pt);
1403 dcl set(0:511) bit(9)int static init(
1404 "00000000"b
1405
1406 ,"00000000"b
1407 ,"00000000"b
1408 ,"00000000"b
1409 ,"00000000"b
1410 ,"00000000"b
1411 ,"00000000"b
1412 ,"00001000"b
1413 ,"00001000"b
1414
1415 ,"00001000"b
1416 ,"00001000"b
1417 ,"00001000"b
1418 ,"00001000"b
1419 ,"00000000"b
1420 ,"00000000"b
1421 ,"00000000"b
1422 ,"00000000"b
1423
1424 ,"00000000"b
1425 ,"00000000"b
1426 ,"00000000"b
1427 ,"00000000"b
1428 ,"00000000"b
1429 ,"00000000"b
1430 ,"00000000"b
1431 ,"00000000"b
1432
1433 ,"00000000"b
1434 ,"00000000"b
1435 ,"00000000"b
1436 ,"00000000"b
1437 ,"00000000"b
1438 ,"00000000"b
1439 ,"000000010"b
1440 ,"00001000"b
1441
1442 ,"00000001"b
1443 ,"00000001"b
1444 ,"00000001"b
1445 ,"00000001"b
1446 ,"00000001"b
1447 ,"00000001"b
1448 ,"00000001"b
1449 ,"00000001"b
1450
1451 ,"00000001"b
1452 ,"00000001"b
1453 ,"00000001"b
1454 ,"00000001"b
1455 ,"00000001"b
1456 ,"00000001"b
1457 ,"00000001"b
1458 ,"01000111"b
1459
1460 ,"01000111"b
1461 ,"01000111"b
1462 ,"01000111"b
1463 ,"01000111"b
1464 ,"01000111"b
1465 ,"01000111"b
1466 ,"01000111"b
1467 ,"01000011"b
1468
1469 ,"01000011"b
1470 ,"00000001"b
1471 ,"00000001"b
1472 ,"00000001"b
1473 ,"00000001"b
1474 ,"00000001"b
1475 ,"00000001"b
1476 ,"00000001"b
1477
1478 ,"10100011"b
1479 ,"10100011"b
1480 ,"10100011"b
1481 ,"10100011"b
1482 ,"10100011"b
1483 ,"10100011"b
1484 ,"10100001"b
1485 ,"10100001"b
1486
1487 ,"10100001"b
1488 ,"10100001"b
1489 ,"10100001"b
1490 ,"10100001"b
1491 ,"10100001"b
1492 ,"10100001"b
1493 ,"10100001"b
1494 ,"10100001"b
1495
1496 ,"10100001"b
1497 ,"10100001"b
1498 ,"10100001"b
1499 ,"10100001"b
1500 ,"10100001"b
1501 ,"10100001"b
1502 ,"10100001"b
1503 ,"10100001"b
1504
1505 ,"10100001"b
1506 ,"10100001"b
1507 ,"00000001"b
1508 ,"00000001"b
1509 ,"00000001"b
1510 ,"00000001"b
1511 ,"10000001"b
1512 ,"00000001"b
1513
1514 ,"10010011"b
1515 ,"10010011"b
1516 ,"10010011"b
1517 ,"10010011"b
1518 ,"10010011"b
1519 ,"10010011"b
1520 ,"10010001"b
1521 ,"10010001"b
1522
1523 ,"10010001"b
1524 ,"10010001"b
1525 ,"10010001"b
1526 ,"10010001"b
1527 ,"10010001"b
1528 ,"10010001"b
1529 ,"10010001"b
1530 ,"10010001"b
1531
1532 ,"10010001"b
1533 ,"10010001"b
1534 ,"10010001"b
1535 ,"10010001"b
1536 ,"10010001"b
1537 ,"10010001"b
1538 ,"10010001"b
1539 ,"10010001"b
1540
1541 ,"10010001"b
1542 ,"10010001"b
1543 ,"00000001"b
1544 ,"00000001"b
1545 ,"00000001"b
1546 ,"00000001"b
1547 ,"00000000"b
1548 ,(384)(9)"0"b
1549 );
1550
1551 end ted_vtab_;