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 tedeval_:
26 proc (adb_p, ain_p, ain_l, buf_ptr, ams_p, ams_l, result, msg, code);
27 dcl (
28 adb_p ptr,
29 ain_p ptr,
30 ain_l fixed bin (21),
31
32 buf_ptr ptr,
33 ams_p ptr,
34
35 ams_l fixed bin (21),
36
37 result char (500) var,
38 msg char (168) var,
39 code fixed bin (35)
40 ) parm;
41
42
43
44
45 dcl 1 s1 like ls based (s1_ptr);
46 dcl 1 s2 like ls based (s2_ptr);
47 dcl 1 sr like ls based (sr_ptr);
48 dcl (s1_ptr, s2_ptr, sr_ptr) ptr;
49
50 dcl ex_sw bit (1);
51 dcl ch2 char (1);
52
53 dcl ind fixed bin (21);
54 dcl cat_p ptr;
55 dcl cat_l fixed bin (21);
56 dcl 1 catv based (cat_p),
57 2 link ptr,
58 2 len fixed bin (21),
59 2 text char (cat_l refer (catv.len));
60 dcl ii fixed bin (21);
61 dcl lval_ptr ptr;
62 dcl 1 val based (lval_ptr),
63 2 temp ptr,
64 2 version fixed bin,
65 2 avar bit (18) aligned,
66 2 spare (123) bit (36) aligned,
67 2 av (-200:200) fixed bin (24),
68 2 k (-200:200) char (32) var,
69 2 K (-10:30) char (500) var,
70 2 cata area;
71 dcl nextab bit (18);
72 dcl avar_len fixed bin (21);
73 dcl avar_ptr ptr;
74 dcl unary bit (1);
75 dcl char16 char (16) var;
76 dcl 1 avar based (avar_ptr),
77 2 next bit (18) aligned,
78 2 name char (16),
79 2 type fixed bin,
80 2 num fixed bin (35),
81 2 txt_r bit (18);
82
83 dcl alb fixed bin static internal init (-200),
84 aub fixed bin static internal init (200),
85 klb fixed bin static internal init (-200),
86 kub fixed bin static internal init (200),
87 Klb fixed bin static internal init (-10),
88 Kub fixed bin static internal init (30),
89 ns_string char (256) var,
90 ns_num fixed bin;
91 dcl define_area_ entry (ptr, fixed bin(35));
92 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
93 dcl tedwhere_ entry (ptr);
94 dcl conc_sw bit (1);
95
96 code = 1;
97 dbase_p = adb_p;
98 bp = dbase.eval_p;
99 lval_ptr = b.cur.sp;
100 if (lval_ptr = null())
101 then do;
102 call tedget_segment_ (dbase_p, b.cur.sp, b.cur.sn);
103 lval_ptr = b.cur.sp;
104 val.version = 1;
105 val.temp = null ();
106 val.avar = "0"b;
107 ai.version = area_info_version_1;
108 ai.extend = "0"b;
109 ai.zero_on_alloc = "1"b;
110 ai.zero_on_free = "0"b;
111 ai.dont_free = "0"b;
112 ai.no_freeing = "0"b;
113 ai.owner = dbase.tedname;
114 ai.size = sys_info$max_seg_size - 8901;
115 ai.areap = addr (cata);
116 call define_area_ (addr (ai), code);
117 if (code ^= 0)
118 then do;
119 msg = "Error defining eval area.";
120 return;
121 end;
122 dcl 1 ai like area_info;
123 %include area_info;
124 dcl sys_info$max_seg_size fixed bin ext static;
125 end;
126
127
128 bp = buf_ptr;
129 conc_sw = "1"b;
130
131
132
133
134 do l = lbound (ls, 1) to hbound (ls, 1);
135 ls.pt (l) = null ();
136 end;
137 ex_sw = "0"b;
138 level = -1;
139 lnl = 0;
140 call ns_alt (ain_p, 1, ain_l);
141 ind = 0;
142 result = "";
143 code = 0;
144 unary = "0"b;
145 if (substr (is, 1, 3) = "{?}")
146 then do;
147 ain_l = 3;
148 call ioa_ ("Type ""help <eval>"" for more help");
149 return;
150 end;
151
152 %include ted_eval_p_;
153 %page;
154 scanner: proc returns (fixed bin (21));
155
156 dcl ret_val fixed bin;
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235 MORE:
236 ls.symptr (-la_put) = addr (ib (nc));
237 ls.symlen (-la_put) = 0;
238 ls.symbol (-la_put) = 0;
239 ls.type (-la_put) = 0;
240 ls.num (-la_put) = 0;
241 ls.loc (-la_put) = 0;
242 if (nc > te)
243 then do;
244 if (level = 0)
245 then do;
246 test_symbol = 0;
247 goto error;
248 end;
249 level = level - 1;
250 IP = input.pt (level);
251 lgnc = input.loc0 (level);
252 nc = input.loc1 (level);
253 te = input.loc2 (level);
254 goto MORE;
255 end;
256 fc = nc;
257 ret_val = val_mad (fixed (ib (nc), 9));
258 nc = nc + 1;
259 if (nc <= te)
260 then ch2 = ic (nc);
261 else ch2 = " ";
262 i = verify (substr (is, nc - 1), azAZ09);
263 char16 = substr (is, nc - 1, i - 1);
264 (subscriptrange): goto LS (ret_val);
265
266 LS (0):
267 if ic (fc) > " " then goto error;
268 goto MORE;
269 LS (1):
270 k = nc - 1;
271 ns_num = index ("0123456789", ic (nc - 1)) - 1;
272 do nc = nc to te while (val_mad (fixed (ib (nc), 9)) = 1);
273 ns_num = (10 * ns_num) + index ("0123456789", ic (nc)) - 1;
274 end;
275 ls.num (-la_put) = ns_num;
276 ls.symlen (-la_put) = nc - k;
277 return (1);
278
279 LS (2):
280 j = te - nc + 1;
281 ns_string = "";
282 do while (j > 0);
283 k = index (substr (is, nc, j), """");
284 if k < 1 then j = 0;
285 else do;
286 if k > 1 then ns_string = ns_string || substr (is, nc, (k - 1));
287 ls.symlen (-la_put) = k;
288 nc = nc + k;
289 if nc > te then return ((STRING_TYPE ()));
290 if ic (nc) = """"
291 then do;
292 ns_string = ns_string || """";
293 nc = nc + 1;
294 j = te - nc + 1;
295 end;
296 else return ((STRING_TYPE ()));
297 end;
298 end;
299 msg = "Vmq) Missing "".";
300 goto err_ret;
301
302 LS (3): return (3);
303
304 LS (4):
305 LS (5):
306 LS (7):
307 LS (10):
308 LS (19):
309 unary_check:
310 do nc = nc to te while (ic (nc) < "!");
311 end;
312 if (ic (nc) = "+") | (ic (nc) = "-")
313 then unary = "1"b;
314 return (ret_val);
315
316 LS (6): return (6);
317 LS (8): return (8);
318
319 LS (9):
320 if (ch2 = "=") then do; nc = nc + 1; ret_val = 11; end;
321 goto unary_check;
322
323 LS (11):
324 if (char16 = "pn") then do; nc = nc + 1; return (60); end;
325 ret_val = 61;
326 goto LS (24);
327
328
329 LS (12): return (12);
330 LS (13): return (13);
331
332 LS (14):
333 if ch2 = "|" then do; nc = nc + 1; return (65); end;
334 return (14);
335
336 LS (15):
337 LS (16):
338 if unary
339 then do;
340 unary = "0"b;
341 ret_val = ret_val + 56;
342 end;
343 return (ret_val);
344
345 LS (17):
346 if ch2 = "=" then do; nc = nc + 1; ret_val = 20; end;
347 goto unary_check;
348
349 LS (18):
350 if ch2 = "=" then do; nc = nc + 1; ret_val = 21; end;
351 goto unary_check;
352
353 LS (21):
354 alpha:
355 nc = nc + length (char16) - 1;
356 ls.symlen (-la_put) = length (char16);
357 nextab = val.avar;
358 do avar_ptr = pointer (lval_ptr, nextab)
359 repeat (pointer (lval_ptr, nextab))
360 while (nextab ^= "0"b);
361 if (avar.txt_r = "0"b)
362 then cat_p = null ();
363 else cat_p = pointer (lval_ptr, avar.txt_r);
364 if (char16 = "abbreviations") & (avar.type = ABREV)
365 then call ioa_ ("^8a ^a", avar.name, catv.text);
366 else if (char16 = avar.name)
367 then do;
368 if (avar.type = ABREV)
369 then do;
370 call ns_alt (addr (catv.text), 1, catv.len);
371 goto MORE;
372 end;
373 ls.pt (-la_put) = avar_ptr;
374 return (66);
375 end;
376 nextab = avar.next;
377 end;
378 if (char16 = "abbreviations")
379 then goto MORE;
380 ls.pt (-la_put) = null ();
381 return (66);
382
383 LS (22):
384 if ch2 = "=" then do; nc = nc + 1; goto unary_check; end;
385 goto error;
386
387 LS (25):
388 if (char16 = "Kt") then do; nc = nc + 1; return (26); end;
389 if (char16 = "Ks") then do; nc = nc + 1; return (26); end;
390 if (char16 = "Kl") then do; nc = nc + 1; return (53); end;
391 if (char16 = "Kb") then do; nc = nc + 1; return (54); end;
392 if ("0"b) then do;
393 LS (23):
394 if (char16 = "ag") then do; nc = nc + 1; return (57); end;
395 end;
396 LS (24):
397 do nc = nc to te while (ic (nc) < "!");
398 end;
399 if nc <= te then if ic (nc) = "["
400 then do;
401 nc = nc + 1;
402 goto unary_check;
403 end;
404 goto alpha;
405
406 LS (27):
407 if (char16 = "be") then do; nc = nc + 1; return (27); end;
408 if (char16 = "bn") then do; nc = nc + 1; return (28); end;
409 goto alpha;
410
411 LS (28):
412 if (char16 = "cs") then do; nc = nc + 1; return (58); end;
413 goto alpha;
414
415 dcl fxx (14) char (03) int static init (
416 "fl ", "fs ", "fak", "fka", "fi ", "fir", "fv ", "fvr",
417 "ff ", "ffr", "fln", "fmx", "fmn", "frs");
418 dcl fvv (14) fixed bin int static init (
419 00029, 00030, 00041, 00042, 00044, 00045, 00046, 00047,
420 00048, 00049, 00050, 00062, 00063, 00064);
421 LS (29):
422 do i = 1 to 14;
423 if (char16 = fxx (i))
424 then do;
425 k = fvv (i);
426 test_for_paren:
427 ii = nc + length (char16) - 1;
428 if (ic (ii) ^= "(")
429 then goto alpha;
430 nc = ii;
431 return (k);
432 end;
433 end;
434 goto alpha;
435
436 LS (31):
437 if (char16 = "lb") then do; nc = nc + 1; return (31); end;
438 if (char16 = "le") then do; nc = nc + 1; return (32); end;
439 goto alpha;
440
441 LS (33):
442 if (char16 = "sb") then do; nc = nc + 1; return (33); end;
443 if (char16 = "se") then do; nc = nc + 1; return (34); end;
444 if (char16 = "sn") then do; nc = nc + 1; return (40); end;
445 if (char16 = "sk") then do; nc = nc + 1; return (51); end;
446 goto alpha;
447
448 LS (35):
449 if (char16 = "da") then do; nc = nc + 1; return (35); end;
450 if (char16 = "dk") then do; nc = nc + 1; return (36); end;
451 if (char16 = "dK") then do; nc = nc + 1; return (37); end;
452 if (char16 = "dn") then do; nc = nc + 1; return (38); end;
453 k = 67;
454 goto test_for_paren;
455
456 LS (36):
457 if (char16 = "en") then do; nc = nc + 1; return (39); end;
458 if (char16 = "em") then do; nc = nc + 1; return (43); end;
459
460 if (char16 = "emt") then do; k = 69; goto test_for_paren; end;
461 if (char16 = "emc") then do; k = 70; goto test_for_paren; end;
462 goto alpha;
463
464 LS (37):
465 if (char16 = "J") then return (52);
466 goto alpha;
467
468 LS (38):
469 if (char16 = "if") then do; nc = nc + 1; return (55); end;
470 goto alpha;
471
472 LS (39):
473 if (ch2 ^= "(") then goto alpha;
474 ls.mask (-la_put) = "0"b;
475 ls.symlen (-la_put) = index (substr (is, nc - 1, te - nc), ")");
476 nc = nc + 1;
477 do while ("1"b);
478
479
480
481
482
483
484
485
486
487
488 k = index ("ANULMOXGA)anulmoxga)", ic (nc));
489 if (k = 0)
490 then goto error;
491 if (k > 10)
492 then k = k - 10;
493 nc = nc + 1;
494 if (k = 10)
495 then return (59);
496 substr (ls.mask (-la_put), k, 1) = "1"b;
497 end;
498
499
500
501 LS (40):
502 if (char16 = "mct") then do; k = 68; goto test_for_paren; end;
503 goto alpha;
504
505
506 dcl azAZ09 char (63) int static init (
507 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz");
508 dcl (k, j) fixed bin (21);
509 dcl val_mad (0:511) fixed bin (8) unaligned static internal init (
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551 (34) 0, 2, (5) 0, 7, 8, 12, 15, 4, 16, 0, 13, (10) 1, 9,
552 10, 17, 19, 18, (2) 0, (9) 21, 37, 25, (7) 21, 39, (7) 21,
553 (2) 0, 3, 22, (2) 0, 23, 27, 28, 35, 36, 29, (2) 21, 38,
554 21, 24, 31, 40, (2) 21, 11, 21, 21, 33, (7) 21, 5, 14, 6,
555 (386) 0);
556 ns_alt: entry (ipt, ilc, iln);
557
558 dcl ipt ptr,
559 ilc fixed bin (21),
560 iln fixed bin (21);
561
562 if (level = 5)
563 then do;
564 ain_l = input.loc1 (1);
565 msg = "Vlv) Evaluation depth > 5.";
566 goto err_ret;
567 end;
568 if (level >= 0)
569 then do;
570 input.pt (level) = IP;
571 input.loc0 (level) = lgnc;
572 input.loc1 (level) = nc;
573 input.loc2 (level) = te;
574 end;
575 level = level + 1;
576 input.pt (level), IP = ipt;
577 input.loc0 (level), lgnc,
578 input.loc1 (level), nc = ilc;
579 input.loc2 (level), te = ilc + iln - 1;
580 return;
581 end scanner;
582 dcl level fixed bin (21);
583 dcl 1 input (0:5),
584 2 pt ptr,
585 2 loc0 fixed bin (21),
586 2 loc1 fixed bin (21),
587 2 loc2 fixed bin (21);
588
589
590
591 %include ted_eval_;
592 %include ted_eval_t_;
593 %page;
594
595 cka: proc (i) returns (fixed bin (21));
596
597
598 if (i < alb) | (i > aub)
599 then do;
600 msg = "Vsa) Subscript not in a[-200:200].";
601 goto err_ret;
602 end;
603 return (i);
604 dcl i fixed bin (21) parm;
605 end cka;
606
607
608
609 ckk: proc (i) returns (fixed bin (21));
610
611
612 if (i < klb) | (i > kub)
613 then do;
614 msg = "VSk) Subscript not in k[-200:200].";
615 goto err_ret;
616 end;
617 return (i);
618 dcl i fixed bin (21) parm;
619 end ckk;
620
621
622
623 ckK: proc (i) returns (fixed bin (21));
624
625
626 if (i < Klb) | (i > Kub)
627 then do;
628 msg = "VsK) Subscript not in K[-10:10].";
629 goto err_ret;
630 end;
631 return (i);
632 dcl i fixed bin (21) parm;
633 end ckK;
634 %page;
635
636 STRING_TYPE: proc returns (fixed bin);
637
638 dcl hold_string char (20);
639
640 hold_string = ns_string;
641
642 if nc > te then return (2);
643 goto typ (index ("xXoO", substr (is, nc, 1)));
644 typ (0): return (2);
645 typ (1):
646 typ (2):
647 nc = nc + 1;
648 rn = 9;
649 ns_num = 0;
650
651 if length (ns_string) > 0
652 then if substr (hold_string, 1, 1) > "7"
653 then unspec (ns_num) = (36)"1"b;
654 do i = length (ns_string) to 1 by -1;
655 j = index ("0123456789ABCDEFabcdef", substr (hold_string, i, 1));
656 if j < 1
657 then do;
658 msg = "Vbx) Bad hex digit, """;
659 msg = msg || ns_string;
660 msg = msg || """";
661 goto err_ret;
662 end;
663 if j > 16
664 then j = j - 6;
665 addr (ns_num) -> hex (rn) = hexv (j);
666 rn = rn - 1;
667 end;
668 ls.num (-la_put) = ns_num;
669 return (1);
670 typ (3):
671 typ (4):
672 nc = nc + 1;
673 rn = 12;
674 ns_num = 0;
675
676 if length (ns_string) > 0
677 then if substr (hold_string, 1, 1) > "3"
678 then unspec (ns_num) = (36)"1"b;
679 do i = length (ns_string) to 1 by -1;
680 j = index ("01234567", substr (hold_string, i, 1));
681 if j < 1
682 then do;
683 msg = "Vbo) Bad octal digit. """;
684 msg = msg || ns_string;
685 msg = msg || """";
686 goto err_ret;
687 end;
688 addr (ns_num) -> oct (rn) = octv (j);
689 rn = rn - 1;
690 end;
691 ls.num (-la_put) = ns_num;
692 return (1);
693
694 dcl (i, j,
695 rn) fixed bin (21),
696 hex (9) bit (4) based,
697 hexv (16) bit (4) static internal init (
698 "0000"b, "0001"b, "0010"b, "0011"b,
699 "0100"b, "0101"b, "0110"b, "0111"b,
700 "1000"b, "1001"b, "1010"b, "1011"b,
701 "1100"b, "1101"b, "1110"b, "1111"b),
702 oct (12) bit (3) based,
703 octv (8) bit (3) static internal init (
704 "000"b, "001"b, "010"b, "011"b,
705 "100"b, "101"b, "110"b, "111"b);
706 end STRING_TYPE;
707 %page;
708
709 dcl
710 (ioa_$ioa_switch,
711 ioa_$nnl) entry options (variable),
712
713
714 IP ptr,
715 te fixed bin (24),
716 is char (te) aligned based (IP),
717 1 CHAR_ARRAY aligned based (IP),
718 2 ic (te) char (1) unaligned,
719 1 BIT_ARRAY aligned based (IP),
720 2 ib (te) bit (9) unaligned;
721
722 dcl (abs, addrel, char, collate9, divide, hbound, index, lbound, length,
723 ltrim, max, min, null, pointer, rel, reverse, search, string, substr,
724 unspec, verify
725 ) builtin;
726
727
728 dcl fc fixed bin (21);
729 dcl l fixed bin (21);
730 dcl lgnc fixed bin (21);
731 dcl lnl fixed bin (21);
732 dcl nc fixed bin (21);
733
734 %include tedcommon_;
735 %include tedbase;
736 %include tedbcb;
737 %include tedstk;
738 dcl tedget_segment_ entry (
739 ptr,
740 ptr,
741 fixed bin,
742
743
744
745 );
746
747
748 dcl tedcount_lines_ entry (
749 ptr,
750 fixed bin (21),
751 fixed bin (21),
752 fixed bin (21)
753 );
754
755
756 dcl db_sw bit (1) int static init ("0"b);
757 dbn: entry; db_sw = "1"b; return;
758 dbf: entry; db_sw = "0"b; return;
759 end tedeval_;