1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16 macro_: proc (sl_name, segname, macname, out_ptr, out_len, arglp, argct, msg,
17 refseg, ecode);
18
19 segtype = "MACRO";
20 if (sl_name = "macro")
21 then who_am_i = "MACRO";
22 else who_am_i = "EXPANSION";
23 mac_sw = "1"b;
24 segptr = null ();
25 refp = refseg;
26 goto start;
27
28 expand: entry (sl_name, segname, macname, out_ptr, out_len, arglp, argct, msg,
29 strptr, strlen, ecode);
30
31 if (segname = "")
32 then segtype = "STRING";
33 else segtype = "SEGMENT";
34 myname = "source ";
35 myname = myname || segtype;
36 mac_sw = "0"b;
37 refp = null ();
38 segptr = strptr;
39 segi = 1;
40 sege = strlen;
41 goto start;
42
43 dcl sl_name char (32) var,
44 segname char (32) var,
45
46 macname char (32) var,
47
48 out_ptr ptr,
49 out_len fixed bin (24),
50 arglp ptr,
51 argct fixed bin,
52 msg char (1000) var,
53 refseg ptr,
54 strptr ptr,
55 strlen fixed bin (24),
56
57 ecode fixed bin (35);
58
59 dcl 1 argl (24) based (arglp),
60 2 p ptr,
61 2 l fixed bin (24);
62 dcl arg char (argl.l (num)) based (argl.p (num));
63 dcl num fixed bin (24);
64 dcl refp ptr;
65
66 start:
67 if free_area_p = null ()
68 then call get_area;
69 local_var_ptr, int_var_ptr = null ();
70 msg_etc = "";
71
72 do num = 1 to argct;
73 if (argl.l (num) < 0)
74 then signal condition (argleng_less_than_zero);
75 if (argl.l (num) > 500)
76 then do;
77 msg = "ARG ";
78 msg = msg || ltrim (char (num));
79 msg = msg || " >500 characters.";
80 ecode = -1;
81 return;
82 end;
83 end;
84 msg = "";
85 ecode = 0;
86 macro_nest = macro_nest + 1;
87
88 save_db = db_sw;
89 if (segtype = "STRING") | (segptr ^= null ())
90 then goto doit;
91
92
93 if mac_sw
94 then do;
95 c32 = segname;
96 if (c32 = "")
97 then do;
98 if db_sw
99 then call ioa_ (""""" ^a", macname);
100 myname = macname;
101 do maclp = macro_list_p
102 repeat (macro_list.next)
103 while (maclp ^= null ());
104 if macro_list.int_mac
105 then do;
106 if db_sw
107 then call ioa_ (" ^a/^a", substr (macro_list.dname, 1, 1),
108 macro_list.name);
109 if (macro_list.name = macname)
110 then do;
111 segptr = macro_list.ref;
112 segi = macro_list.from;
113 sege = macro_list.to;
114 goto doit;
115 end;
116 end;
117 end;
118 c32 = macname;
119 end;
120 if db_sw
121 then call ioa_ ("^a$^a", c32, macname);
122 myname = c32;
123 myname = myname || "$";
124 myname = myname || macname;
125 do maclp = macro_list_p
126 repeat (macro_list.next)
127 while (maclp ^= null ());
128 if ^macro_list.int_mac
129 then do;
130 if db_sw
131 then call ioa_ (" ^a/^a", macro_list.ename, macro_list.name);
132 if (macro_list.ename = c32) & (macro_list.name = macname)
133 then do;
134 segptr = macro_list.ref;
135 segi = macro_list.from;
136 sege = macro_list.to;
137 goto doit;
138 end;
139 end;
140 end;
141 end;
142
143 call find_macro (refp, segname, sl_name, macname);
144
145 doit:
146 tr_sw = "0"b;
147 if (substr (segment, segi, 7) = "&trace
148 ")
149 then do;
150 segi = segi + 7;
151 tr_sw = "1"b;
152 end;
153 if (substr (segment, segi, 7) = "&debug
154 ")
155 then do;
156 segi = segi + 7;
157 db_sw = "1"b;
158 end;
159 if db_sw | pc_sw | tr_sw | al_sw
160 then do;
161 call ioa_ ("^[EXPAND^s^;^a^](^i) ^a", (who_am_i = "EXPANSION"),
162 segtype, macro_nest, macname);
163 do num = 1 to argct;
164 call ioa_ ("ARG^2i: ""^va""", num, argl.l (num), arg);
165 end;
166 if (argct = 0)
167 then call ioa_ ("ARGs: none");
168 end;
169 construct_nest = 1;
170 call_err = "0"b;
171 call expand (segptr, segi, sege, out_ptr, out_len, "11"b);
172 quit:
173 if db_sw | pc_sw | tr_sw | al_sw
174 then call ioa_ (" ^[MEND^;EXPEND^](^i) ^a", (who_am_i = "MACRO"),
175 macro_nest, macname);
176
177 if (segi < sege)
178 then do;
179 misplaced:
180 msg = "Misplaced """;
181 msg = msg || c32;
182 msg = msg || """. ";
183
184 add_identification:
185 ecode = error_table_$badsyntax;
186 add_id:
187 if call_err
188 then msg = msg || "
189 from";
190 if segtype = "MACRO"
191 then do;
192 msg = msg || " ";
193 msg = msg || who_am_i;
194 end;
195 msg = msg || " """;
196 msg = msg || myname;
197 msg = msg || """, line ";
198 msg = msg || lineno (segi);
199 if ^call_err
200 then do;
201 msg = "
202 ERROR SEVERITY 4. " || msg;
203 if (msg_etc ^= "")
204 then do;
205 msg = msg || NL;
206 msg = msg || msg_etc;
207 end;
208 end;
209 end;
210 exit:
211 macro_nest = macro_nest - 1;
212 tptr = local_var_ptr;
213 call free_um ("loc");
214 if (err_ct (3) ^= 0) & (err_ct (4) = 0)
215 then ecode = error_table_$translation_failed;
216 db_sw = save_db;
217 return;
218
219
220 syntax_err:
221 msg = "Syntax error in " || msg;
222 msg = msg || ". ";
223 goto add_identification; %page;
224
225
226
227
228 addmacro: proc (dname, segname, macname, int_mac, segp, segi, sege);
229
230 dcl dname char (168),
231 segname char (32) var,
232 macname char (32) var,
233 int_mac bit (1),
234 segp ptr,
235 segi fixed bin (24),
236 sege fixed bin (24);
237
238 if db_sw
239 then call ioa_ ("addmacro ^a > ^a (^p) ^a^[ INTERNAL^]",
240 dname, segname, segp, macname, int_mac);
241 do maclp = macro_list_p
242 repeat (macro_list.next)
243 while (maclp ^= null ());
244 if (macro_list.ename = segname) & (macro_list.name = macname)
245 & (macro_list.int_mac = int_mac)
246 then do;
247 if (segptr = macro_list.ref)
248 & (segi = macro_list.from)
249 & (sege = macro_list.to)
250 then do;
251 if db_sw
252 then call ioa_ (" already there");
253 return;
254 end;
255 msg = who_am_i;
256 msg = msg || " already defined.";
257 goto add_identification;
258 end;
259 end;
260 allocate macro_list in (free_area);
261 if al_sw
262 then call ioa_ ("A macro_list ^i ^p", size (macro_list), maclp);
263 macro_list.name = macname;
264 macro_list.ref = segp;
265 macro_list.dname = dname;
266 macro_list.ename = segname;
267 macro_list.from = segi;
268 macro_list.to = sege;
269 macro_list.int_mac = int_mac;
270 macro_list.next = macro_list_p;
271 macro_list_p = maclp;
272 if db_sw then call ioa_ ("addmac ^16a ^p ^i:^i^/^-^a > ^a",
273 macro_list.name, macro_list.ref, macro_list.from, macro_list.to,
274 macro_list.dname, macro_list.ename);
275
276 end addmacro; %page;
277
278
279
280
281 ampersand: proc (ifp, ifi, ife, ofp, ofe, TF, err_sw) recursive;
282
283 dcl ifp ptr,
284 ifi fixed bin (24),
285 ife fixed bin (24),
286 ofp ptr,
287 ofe fixed bin (24),
288 TF bit (2),
289 err_sw bit (1);
290
291 dcl begl fixed bin (24);
292 dcl inputa (ife) char (1) based (ifp);
293 dcl input char (ife) based (ifp);
294 dcl output char (ofe) based (ofp);
295 dcl (i, j, ii, jj) fixed bin (24);
296
297
298 begl = ifi;
299 if db_sw then call dumper ("ampr", ifp, ifi, ife, ofp, ofe, TF);
300 if (ifi >= ife)
301 then do;
302 msg = "Orphan &.";
303 goto add_identification;
304 end;
305 i = index ("0123456789", inputa (ifi + 1));
306 if (i ^= 0)
307 then do;
308 num = i - 1;
309 i = index ("0123456789", inputa (ifi + 2));
310 if (i ^= 0)
311 then do;
312 num = num * 10 + i - 1;
313 ifi = ifi + 1;
314 end;
315 ifi = ifi + 2;
316 if (num <= argct)
317 then call putout(ofp, ofe, arg);
318 end;
319 else do;
320 ch_2nd = inputa (ifi + 1);
321 if (ch_2nd = "{")
322 then call arg_range (ifp, ifi, ife, ofp, ofe, TF);
323
324 else if (ch_2nd = "*")
325 then do;
326 ifi = ifi + 2;
327 call putout (ofp, ofe, ltrim (char (argct)));
328 end;
329
330 else if (ch_2nd = ".")
331 then ifi = ifi + 2;
332
333 else if (ch_2nd = "+")
334 then call strip2 (ifp, ifi, ife);
335
336 else if (ch_2nd = "[")
337 then call macro_af (ifp, ifi, ife, ofp, ofe, TF);
338
339 else if (ch_2nd = "(")
340 then call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
341
342 else if (ch_2nd = """")
343 then call protected (ifp, ifi, ife, ofp, ofe);
344
345 else if (ch_2nd = ";")
346 then do;
347 c32 = "&;";
348 return;
349 end;
350
351 else if (ch_2nd = "&")
352 then do;
353 ifi = ifi + 2;
354 call putout (ofp, out_len, "&");
355 end;
356 else do;
357 variable:
358 i = verify (substr (input, ifi + 1), token_chars);
359
360 if (i = 0)
361 then i = ife - ifi + 1;
362 if (i > 1)
363 then do;
364 if (i > 26)
365 then do;
366 msg = who_am_i;
367 msg = msg || " name > 26 chars.";
368 goto add_identification;
369 end;
370 c32 = substr (input, ifi + 1, i - 1);
371 c32x = "";
372
373 if (inputa (ifi + i) = "$")
374 then do;
375 ifi = ifi + i;
376 ii = verify (substr (input, ifi + 1), token_chars);
377 if (ii = 0)
378 then i = 0;
379 else if (inputa (ifi + ii) = "(")
380 then do;
381 i = ii;
382 c32x = c32;
383 c32 = substr (input, ifi + 1, i - 1);
384 end;
385 end;
386
387 if (inputa (ifi + i) = "(") & (ife > ifi + i)
388 then do;
389 ifi = ifi + i + 1;
390 call macro_call (ifp, ifi, ife, ofp, ofe, TF);
391 end;
392
393 else if (inputa (ifi + i) = "{") & (ife > ifi + i)
394 then do;
395 ifi = ifi + i + 1;
396 call var_range (ifp, ifi, ife, ofp, ofe, TF);
397 end;
398
399
400 else if (c32 = "lbound")
401 then call var_bound (ifp, ifi, ife, ofp, ofe, TF);
402 else if (c32 = "hbound")
403 then call var_bound (ifp, ifi, ife, ofp, ofe, TF);
404
405 else if (c32 = "empty")
406 then call macro_empty (ifp, ifi, ife, ofp, ofe, TF);
407
408 else if (c32 = "error")
409 then call macro_error (ifp, ifi, ife, ofp, ofe, TF);
410
411 else if (c32 = "comment")
412 then do;
413 i = index (substr (input, ifi), "&;");
414 if (i = 0)
415 then do;
416 msg = "&;";
417 call error_missing ("comment", begl, ife);
418 end;
419 ifi = ifi + i + 1;
420 return;
421 end;
422
423 else if (c32 = "usage")
424 then call macro_usage (ifp, ifi, ife, ofp, ofe, TF);
425
426 else if (c32 = "quote")
427 then call macro_quote (ifp, ifi, ife, ofp, ofe, TF);
428
429 else if (c32 = "unquote")
430 then call macro_unquote (ifp, ifi, ife, ofp, ofe, TF);
431
432 else if (c32 = "return")
433 then do;
434 segi = sege + 1;
435 goto quit;
436 end;
437
438 else if (c32 = "scan")
439 then call macro_scan (ifp, ifi, ife, ofp, ofe, TF);
440
441 else if (c32 = "define")
442 then call macro_define (ifp, ifi, ife, ofp, ofe, TF);
443
444 else if (c32 = "substr")
445 then call macro_substr (ifp, ifi, ife, ofp, ofe, TF);
446
447 else if (c32 = "length")
448 then call macro_length (ifp, ifi, ife, ofp, ofe, TF);
449
450 else if (c32 = "let")
451 then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 0);
452
453 else if (c32 = "ext")
454 then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 1);
455
456 else if (c32 = "int")
457 then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 2);
458
459 else if (c32 = "loc")
460 then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 3);
461
462 else if (c32 = "do")
463 then call macro_do (ifp, ifi, ife, ofp, ofe, TF);
464
465 else if (c32 = "if")
466 then call macro_if (ifp, ifi, ife, ofp, ofe, TF);
467
468 else if (c32 = "od")
469 | (c32 = "fi")
470 | (c32 = "then")
471 | (c32 = "else")
472 | (c32 = "elseif")
473 | (c32 = "while")
474 then do;
475 c32 = "&" || c32;
476 if ^err_sw
477 then goto misplaced;
478 return;
479 end;
480
481 else if (c32 = "expand")
482 then do;
483 start_sym = "expand";
484 end_sym = "expend";
485 goto macdef;
486 end;
487 else if (c32 = "macro")
488 then do;
489 start_sym = "macro";
490 end_sym = "mend";
491 macdef:
492 if construct_nest > 1
493 then do;
494 macnest_err:
495 msg = "&";
496 msg = msg || start_sym;
497 msg = msg || " may not be nested in any other construct.";
498 goto add_id;
499 end;
500 ifi = ifi + i;
501 if (substr (input, ifi, 1) ^= " ")
502 then do;
503 macdef_err:
504 call error_syntax ((start_sym), begl, ifi);
505 end;
506 ifi = ifi + 1;
507 i = verify (substr (input, ifi),
508 "abcdefghijklmnopqrstuvwxyz" ||
509 "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
510 if (i = 0)
511 then goto macdef_err;
512 if (i < 2)
513 then do;
514 msg = "name";
515 call error_missing ((start_sym), begl, ifi);
516 end;
517 i = i - 1;
518 c32 = substr (input, ifi, i);
519 ifi = ifi + i;
520 if (inputa (ifi) ^= NL)
521 then goto macdef_err;
522 ifi = ifi + 1;
523 i = index (substr (input, ifi), "&" || end_sym || NL);
524 if (i = 0)
525 then do;
526 no_mend:
527 msg = "&";
528 msg = msg || end_sym;
529 msg = msg || "<NL>";
530 call error_missing ((start_sym), begl, ife);
531 end;
532 if (index (substr (input, ifi, i - 1), "¯o ") ^= 0)
533 | (index (substr (input, ifi, i - 1), "&expand ") ^= 0)
534 then goto no_mend;
535 call hcs_$fs_get_path_name (ifp, dname, 0, ename, 0);
536 call addmacro (" &" || start_sym || " in " || myname, "",
537 c32, "1"b, ifp, ifi, ifi + i - 2);
538 ifi = ifi + i + length (end_sym) + 1;
539 end;
540 else do;
541 call var_ref (ifp, ifi, ife, ofp, ofe, TF);
542 ifi = ifi + i;
543 end;
544 end;
545 else do;
546 msg = "Unrecognized &control """;
547 msg = msg || c32;
548 msg = msg || """. ";
549 goto add_identification;
550 end;
551 end;
552 end;
553 end ampersand; %page;
554
555
556
557
558 arg_range: proc (ifp, ifi, ife, ofp, ofe, TF);
559
560 dcl ifp ptr,
561 ifi fixed bin (24),
562 ife fixed bin (24),
563 ofp ptr,
564 ofe fixed bin (24),
565 TF bit (2);
566 dcl begl fixed bin (24);
567 dcl inputa (ife) char (1) based (ifp);
568 dcl input char (ife) based (ifp);
569 dcl output char (ofe) based (ofp);
570 dcl (i, j, ii, jj) fixed bin (24);
571 dcl separator char (150) var;
572
573
574
575
576
577
578
579 begl = ifi;
580 ii = ofe;
581 i = 1;
582 j = argct;
583 call get_range (ifp, ifi, ife, ofp, ofe, TF, i, j);
584 separator = " ";
585 if (inputa (ifi) = ",")
586 then do;
587 ifi = ifi + 1;
588 do while ("1"b);
589 jj = search (substr (input, ifi), "&}");
590 if (jj = 0)
591 then do;
592 msg = "}";
593 call error_missing ("{", begl, ife);
594 end;
595 if (jj > 1)
596 then do;
597 jj = jj - 1;
598 call putout (ofp, ofe, substr (input, ifi, jj));
599 ifi = ifi + jj;
600 end;
601 if (inputa (ifi) = "}")
602 then do;
603 separator = substr (output, ii + 1, ofe - ii);
604 ofe = ii;
605 goto end_range;
606 end;
607 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
608 end;
609 end;
610 if (inputa (ifi) = "}")
611 then do;
612 end_range:
613 ifi = ifi + 1;
614 if (TF = "00"b)
615 then return;
616 j = min (j, argct);
617 do num = i to j;
618 call putout (ofp, ofe, arg);
619 if (num ^= j)
620 then call putout (ofp, ofe, (separator));
621 end;
622 end;
623 else do;
624 call error_syntax ("{", begl, ifi);
625 end;
626 end arg_range; %page;
627
628
629
630
631 arithmetic: proc (ifp, ifi, ife, ofp, ofe, TF);
632
633 dcl ifp ptr,
634 ifi fixed bin (24),
635 ife fixed bin (24),
636 ofp ptr,
637 ofe fixed bin (24),
638 TF bit (2);
639 dcl begl fixed bin (24);
640 dcl inputa (ife) char (1) based (ifp);
641 dcl input char (ife) based (ifp);
642 dcl output char (ofe) based (ofp);
643 dcl (i, j, ii, jj) fixed bin (24);
644 dcl level fixed bin (24);
645 dcl (vl, sl) fixed bin (24);
646 dcl val (20) fixed dec (59, 9);
647 dcl stk (20) fixed bin (24);
648 dcl pic60 pic "(49)-9v.(9)9";
649 dcl v fixed dec (59, 9);
650
651 ifi, begl = ifi + 2;
652 if db_sw then call dumper ("arth", ifp, ifi, ife, ofp, ofe, TF);
653 ii = ofe;
654 call putout (ofp, ofe, "(");
655 level = 1;
656 construct_nest = construct_nest + 1;
657 loop:
658 i = search (substr (input, ifi), "&(),:}");
659 if (i = 0)
660 then do;
661 msg = "Missing arithmetic terminator. ";
662 goto add_identification;
663 end;
664 if (i > 1)
665 then do;
666 i = i - 1;
667 call putout (ofp, ofe, substr (input, ifi, i));
668 ifi = ifi + i;
669 end;
670 goto type (index ("&(),:}", inputa (ifi)));
671
672 type (1):
673 if (substr (input, ifi, 2) = "&;")
674 then goto type (4);
675 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
676 goto loop;
677
678 type (2):
679 call putout (ofp, ofe, "(");
680 level = level + 1;
681 ifi = ifi + 1;
682 goto loop;
683
684 type (4):
685 type (5):
686 type (6):
687 if (level > 1)
688 then goto arith_err;
689 ifi = ifi - 1;
690 type (3):
691 call putout (ofp, ofe, ")");
692 ifi = ifi + 1;
693 level = level - 1;
694 if (level > 0)
695 then goto loop;
696 construct_nest = construct_nest - 1;
697
698 if (TF = "00"b)
699 then do;
700 ofe = ii;
701 return;
702 end;
703
704 sl = 1;
705 vl = 0;
706 stk (1) = 16;
707
708 if db_sw | tr_sw
709 then do;
710 call ioa_$nnl ("#^a:^a^-arith ", lineno (begl), lineno (ifi - 1));
711 call show_string (substr (output, ii + 1), NL);
712 end;
713 do i = ii + 1 to ofe;
714
715
716
717 dcl arithchar char (28) int static init ("0123456789(=^=<=>=+-*/) .""
718 ");
719 j = index (arithchar, substr (output, i, 1));
720 if (j = 0)
721 then do;
722 jj = verify (substr (output, i),
723 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
724 if (jj = 0)
725 then jj = ife - ifi + 1;
726 if (jj = 1)
727 then goto arith_err;
728 goto arith_err;
729 end;
730 retry:
731 if lg_sw
732 then if db_sw
733 then do;
734 call ioa_ ("^3i :^1a:", i, substr (output, i, 1));
735 do jj = 1 to sl;
736 call ioa_$nnl (" ^1a",
737 substr (arithchar, stk (jj), 1));
738 end;
739 call ioa_ (".");
740 do jj = 1 to vl;
741 call ioa_$nnl (" ^f", val (jj));
742 end;
743 call ioa_ ("#");
744 end;
745 if (j > 10)
746 then goto type (j);
747
748 type (26):
749 jj = verify (substr (output, i), ".0123456789") - 1;
750 if (jj < 0)
751 then jj = ofe - i + 1;
752 vl = vl + 1;
753 val (vl) = convert (val (1), substr (output, i, jj));
754 sl = sl + 1;
755 stk (sl) = 10;
756 i = i + jj - 1;
757 goto endloop;
758
759 type (23):
760 if (stk (sl) ^= 10)
761 then goto arith_err;
762 goto calc (stk (sl - 1));
763
764 type (13):
765 type (15):
766 type (17):
767 if (substr (output, i + 1, 1) = "=")
768 then do;
769 i = i + 1;
770 j = j + 1;
771 end;
772 if (j = 13)
773 then goto type (11);
774 type (14):
775 type (16):
776 type (18):
777 type (12):
778 type (21):
779 type (22):
780 if (stk (sl) ^= 10)
781 then do;
782 type (27):
783 arith_err:
784 msg = "Arithmetic syntax error. ";
785 msg = msg || substr (arithchar, stk (sl), 1);
786 msg = msg || substr (arithchar, j, 1);
787 msg = msg || " """;
788 msg = msg || substr (output, ii + 1, i - ii);
789 msg = msg || """ ";
790 goto add_identification;
791 end;
792
793 type (19):
794 type (20):
795 if (stk (sl) = 21)
796 then goto arith_err;
797 if (stk (sl) = 22)
798 then goto arith_err;
799 if (stk (sl) > 10)
800 then do;
801 vl = vl + 1;
802 val (vl) = 0;
803 sl = sl + 1;
804 stk (sl) = 10;
805 end;
806 if (stk (sl - 1) >= j)
807 then goto calc (stk (sl - 1));
808 sl = sl + 1;
809 stk (sl) = j;
810 goto endloop;
811
812 type (11):
813 if (stk (sl) = 10)
814 then goto arith_err;
815 sl = sl + 1;
816 stk (sl) = j;
817 goto endloop;
818
819 calc (12):
820 if (val (vl - 1) = val (vl))
821 then v = 1;
822 else v = 0;
823 goto calc_common;
824
825
826 calc (13):
827 if (val (vl) = 0)
828 then val (vl) = 1;
829 else val (vl) = 0;
830 sl = sl - 1;
831 stk (sl) = 10;
832 goto retry;
833
834
835 calc (14):
836 if (val (vl - 1) ^= val (vl))
837 then v = 1;
838 else v = 0;
839 goto calc_common;
840
841
842 calc (15):
843 if (val (vl - 1) < val (vl))
844 then v = 1;
845 else v = 0;
846 goto calc_common;
847
848
849 calc (16):
850 if (val (vl - 1) <= val (vl))
851 then v = 1;
852 else v = 0;
853 goto calc_common;
854
855
856 calc (17):
857 if (val (vl - 1) > val (vl))
858 then v = 1;
859 else v = 0;
860 goto calc_common;
861
862
863 calc (18):
864 if (val (vl - 1) >= val (vl))
865 then v = 1;
866 else v = 0;
867 goto calc_common;
868
869
870
871 calc (19):
872 v = val (vl - 1) + val (vl);
873 goto calc_common;
874
875 calc (20):
876 v = val (vl - 1) - val (vl);
877 goto calc_common;
878
879 calc (21):
880 v = val (vl - 1) * val (vl);
881 goto calc_common;
882
883 calc (22):
884 v = val (vl - 1) / val (vl);
885 calc_common:
886 vl = vl - 1;
887 val (vl) = v;
888 sl = sl - 2;
889 stk (sl) = 10;
890 goto retry;
891
892
893 calc (11):
894 if (j = 23)
895 then do;
896 sl = sl - 1;
897 stk (sl) = 10;
898 goto endloop;
899 end;
900 goto arith_err;
901
902 type (24):
903 type (25):
904 type (28):
905 endloop:
906 end;
907 ofe = ii;
908 call putout (ofp, ofe,
909 ltrim (rtrim (rtrim (convert (pic60, val (1)), "0"), ".")));
910 end arithmetic; %page;
911
912
913 debug
914
915 cvt: proc (ifp, ifi, ife) returns (char (32) var);
916
917 dcl res char (32) var;
918 dcl ifp ptr;
919 dcl (ifi, ife) fixed bin (24);
920 dcl i fixed bin (24);
921 dcl begl fixed bin (24);
922 dcl inputa (ife) char (1) based (ifp);
923 dcl ch char (1);
924
925 res = """";
926 do i = ifi to min (ifi + 15, ife);
927 ch = inputa (i);
928 if (ch < " ")
929 then ch = "~";
930 res = res || ch;
931 end;
932 res = res || """";
933 return (res);
934
935 end cvt; %page;
936
937
938
939
940 dumper: proc (text, ifp, ifi, ife, ofp, ofe, TF);
941
942 dcl text char (4),
943 ifp ptr,
944 (ifi, ife) fixed bin (24),
945 ofp ptr,
946 ofe fixed bin (24),
947 TF bit (2);
948
949 call ioa_ ("^2i.^2i ^4a TF^.1b ^i:^i ^i^-^a - ^a", macro_nest,
950 construct_nest, text, TF, ifi, ife, ofe,
951 cvt (ifp, ifi, ife), cvt (ofp, max (1, ofe - 15), ofe));
952
953 end dumper; %page;
954
955
956
957
958 error_missing: proc (who, begl, endl);
959
960 dcl who char (*),
961 begl fixed bin (24),
962 endl fixed bin (24);
963
964 dcl hold char (1000) var;
965 dcl (cline, eline) char (6) var;
966
967 hold = "Missing ";
968 hold = hold || msg;
969 goto common;
970
971 error_syntax: entry (who, begl, endl);
972
973 hold = "Syntax error";
974 goto common;
975
976 error_misplaced: entry (who, begl, endl);
977
978 hold = "Misplaced ";
979 hold = hold || msg;
980 goto common;
981
982 error_gen: entry (who, begl, endl);
983
984 hold = msg;
985 goto common;
986
987 error_attempt: entry (who, begl, endl);
988
989 hold = "Attempt to ";
990 hold = hold || msg;
991 goto common;
992
993 common:
994 hold = hold || " in """;
995 cline = lineno (begl);
996 eline = lineno (endl);
997
998 msg = "
999 ERROR SEVERITY 4. ";
1000 msg = msg || who_am_i;
1001 msg = msg || " """;
1002 msg = msg || myname;
1003 msg = msg || """, line ";
1004 msg = msg || eline;
1005 msg = msg || ".
1006 ";
1007 msg = msg || hold;
1008 msg = msg || "&";
1009 msg = msg || who;
1010 msg = msg || """";
1011 if (eline ^= cline)
1012 then do;
1013 msg = msg || " (on line ";
1014 msg = msg || cline;
1015 msg = msg || ")";
1016 end;
1017 msg = msg || ".";
1018 ecode = error_table_$badsyntax;
1019 goto exit;
1020
1021 end error_missing; %page;
1022
1023
1024
1025
1026 expand: proc (ifp, ifi, ife, ofp, ofe, tf);
1027
1028 dcl ifp ptr,
1029 ifi fixed bin (24),
1030 ife fixed bin (24),
1031 ofp ptr,
1032 ofe fixed bin (24),
1033 tf bit (2);
1034 dcl begl fixed bin (24);
1035 dcl inputa (ife) char (1) based (ifp);
1036 dcl input char (ife) based (ifp);
1037 dcl output char (ofe) based (ofp);
1038 dcl (i, j, ii, jj) fixed bin (24);
1039
1040
1041 if db_sw then call dumper ("expn", ifp, ifi, ife, ofp, ofe, tf);
1042 do while (ifi <= ife);
1043 i = index (substr (input, ifi), "&");
1044 if (i = 0)
1045 then i = ife - ifi + 1;
1046 else i = i - 1;
1047 if (i > 0)
1048 then do;
1049 call putout (ofp, out_len, substr (input, ifi, i));
1050 ifi = ifi + i;
1051 end;
1052 if (ifi > ife)
1053 then return;
1054 ii = ifi;
1055 call ampersand (ifp, ifi, ife, ofp, ofe, tf, "1"b);
1056 if (ii = ifi)
1057 then return;
1058 end;
1059 end expand; %page;
1060
1061
1062
1063
1064 find_macro: proc (refp, segname, suffix, macname);
1065 dcl refp ptr,
1066 segname char (32) var,
1067 suffix char (32) var,
1068 macname char (32) var;
1069
1070 dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24),
1071 fixed bin(35));
1072 dcl search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*),
1073 fixed bin (35));
1074 dcl search_for char (35) var;
1075
1076 if (segname = "")
1077 then search_for = macname;
1078 else search_for = segname;
1079 search_for = search_for || "." || suffix;
1080
1081 if (refp = null ())
1082 then ref_path = "";
1083 else call hcs_$fs_get_path_name (refp, ref_path, 0, "", 0);
1084 if db_sw
1085 then call ioa_ ("find_macro ^a ^a (^a)", search_for, macname, ref_path);
1086 call search_paths_$find_dir ((suffix), null (), (search_for), ref_path,
1087 dname, ecode);
1088 if (ecode = error_table_$no_search_list)
1089 then do;
1090 dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
1091 here: call hcs_$make_ptr (codeptr (here), suffix || ".search",
1092 suffix || ".search", segptr, ecode);
1093 if (segptr = null ())
1094 then call com_err_ (0, (suffix),
1095 "Default search segment not in same directory as object segment.");
1096 else call search_paths_$find_dir ((suffix), null (), (search_for),
1097 ref_path, dname, ecode);
1098 end;
1099 if (ecode = 0)
1100 then call initiate_file_ (dname, (search_for), "100"b, segptr, bc,
1101 ecode);
1102 if (ecode ^= 0)
1103 then do;
1104 msg = "No definition segment found. ";
1105 msg = msg || search_for;
1106 msg = msg || "$";
1107 msg = msg || macname;
1108 ecode = -1;
1109 goto exit;
1110 end;
1111 segi = 1;
1112 sege = divide (bc, 9, 24, 0);
1113 if mac_sw
1114 then do;
1115 if (suffix = "macro")
1116 then i = index (seg, "¯o " || macname || NL);
1117 else i = index (seg, "&expand " || macname || NL);
1118 if (i = 0)
1119 then do;
1120 msg = "No definition found for """;
1121 bad_mac:
1122 msg = msg || macname;
1123 msg = msg || """ ";
1124 msg = msg || "in ";
1125 msg = msg || rtrim (dname);
1126 msg = msg || ">";
1127 msg = msg || search_for;
1128 ecode = -1;
1129 goto exit;
1130 end;
1131 segi = i + length (macname) + 8;
1132 if (suffix = "macro")
1133 then i = index (substr (seg, segi), "&mend
1134 ");
1135 else do;
1136 segi = segi + 1;
1137 i = index (substr (seg, segi), "&expend
1138 ");
1139 end;
1140 if (i = 0)
1141 then do;
1142 if (suffix = "macro")
1143 then msg = "&mend";
1144 else msg = "&expand";
1145 msg = msg || " missing on """;
1146 goto bad_mac;
1147 end;
1148
1149 sege = segi + i - 2;
1150 call addmacro (dname, before (search_for, "."), (macname), "0"b,
1151 segptr, segi, sege);
1152 if (segname = "")
1153 then do;
1154
1155
1156
1157
1158
1159
1160
1161 call addmacro ("", before (search_for, "."), (macname), "1"b,
1162 segptr, segi, sege);
1163 end;
1164 end;
1165
1166 end find_macro; %page;
1167
1168
1169
1170
1171 free_um: proc (which);
1172
1173 dcl which char (3);
1174
1175 do while (tptr ^= null ());
1176 var_ptr = tptr;
1177 tptr = var.next;
1178 if (var.type = 0)
1179 then do;
1180 if db_sw
1181 then do;
1182 call ioa_ ("^p ^a ^a", var_ptr, which, var.name);
1183 if var.ref ^= null ()
1184 then call ioa_ (" ^p ""^a""", var.ref,
1185 vartext);
1186 end;
1187 if (var.ref ^= null ())
1188 then do;
1189 if al_sw then call ioa_ ("F ^p ""^a""", var.ref,
1190 vartext);
1191 free vartext in (free_area);
1192 end;
1193 end;
1194 if (var.type >= 1) & (var.type <= 5)
1195 then do;
1196 arr_ptr = var.ref;
1197 if db_sw
1198 then call ioa_ ("^p ^a ^a{^i:^i}", var_ptr, which,
1199 var.name, array.lower, array.lower + var.len - 1);
1200 do arr_elem = 1 to var.len;
1201 if (array.ref (arr_elem) ^= null ())
1202 then do;
1203 if al_sw
1204 then call ioa_ ("^p {^i} ""^a""",
1205 array.ref (arr_elem),
1206 -array.lower + arr_elem - 1, arrtext);
1207 free arrtext in (free_area);
1208 end;
1209 end;
1210 end;
1211 if al_sw then call ioa_ ("F var-^a ^p", var.name, var_ptr);
1212 free var in (free_area);
1213 end;
1214
1215 end free_um; %page;
1216
1217
1218
1219
1220 get_area: proc;
1221
1222 ai.version = area_info_version_1;
1223 string (ai.control) = "0"b;
1224 ai.extend = "1"b;
1225 ai.owner = sl_name;
1226 ai.size = 2000;
1227 ai.areap = null ();
1228 call define_area_ (addr (ai), ecode);
1229 free_area_p = ai.areap;
1230
1231 %include area_info;
1232 dcl 1 ai like area_info;
1233
1234 end get_area; %page;
1235
1236
1237
1238
1239 get_range: proc (ifp, ifi, ife, ofp, ofe, TF, i, j);
1240
1241 dcl ifp ptr,
1242 ifi fixed bin (24),
1243 ife fixed bin (24),
1244 ofp ptr,
1245 ofe fixed bin (24),
1246 TF bit (2);
1247 dcl begl fixed bin (24);
1248 dcl inputa (ife) char (1) based (ifp);
1249 dcl input char (ife) based (ifp);
1250 dcl output char (ofe) based (ofp);
1251 dcl (i, j, ii, jj) fixed bin (24);
1252
1253 if (inputa (ifi + 2) = "}")
1254 | (inputa (ifi + 2) = ",")
1255 then do;
1256 ifi = ifi + 2;
1257 return;
1258 end;
1259 ii = ofe;
1260 call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
1261 i, j = fixed (substr (output, ii + 1, ofe - ii));
1262 ofe = ii;
1263 if (inputa (ifi) = ":")
1264 then do;
1265 ifi = ifi - 1;
1266 call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
1267 j = fixed (substr (output, ii + 1, ofe - ii));
1268 ofe = ii;
1269 end;
1270
1271 end get_range; %page;
1272
1273
1274
1275
1276 get_token: proc (ifp, ifi, ife);
1277
1278 dcl ifp ptr,
1279 ifi fixed bin (24),
1280 ife fixed bin (24);
1281 dcl input char (ife) based (ifp);
1282
1283 call strip (ifp, ifi, ife);
1284 if (substr (input, ifi, 1) ^= "&")
1285 then do;
1286 c32 = "";
1287 return;
1288 end;
1289 i = verify (substr (input, ifi + 1), "abcdefghijklmnopqrstuvwxyz");
1290 if (i = 0)
1291 then i = ife - ifi + 1;
1292 else if (i = 1)
1293 then i = 2;
1294 c32 = substr (input, ifi, i);
1295
1296 end get_token; %page;
1297
1298
1299
1300
1301 lineno: proc (segi) returns (char (6) var);
1302
1303 dcl segi fixed bin (24);
1304
1305 dcl c6 pic "zzzzz9";
1306 dcl cv6 char (6) var;
1307 dcl j fixed bin (24);
1308 dcl line fixed bin (24);
1309 dcl e fixed bin (24);
1310
1311 line = 0;
1312 i = 1;
1313 e = min (segi, sege);
1314 do while (i <= segi);
1315 line = line + 1;
1316 j = index (substr (seg, i), NL);
1317 if (j = 0)
1318 then i = sege + 1;
1319 else i = i + j;
1320 end;
1321 cv6 = ltrim (char (line));
1322 return (cv6);
1323
1324 end lineno; %page;
1325
1326
1327
1328
1329 logical: proc (ifp, ifi, ife, ofp, ofe, TF);
1330
1331 dcl ifp ptr,
1332 ifi fixed bin (24),
1333 ife fixed bin (24),
1334 ofp ptr,
1335 ofe fixed bin (24),
1336 TF bit (2);
1337 dcl begl fixed bin (24);
1338 dcl inputa (ife) char (1) based (ifp);
1339 dcl input char (ife) based (ifp);
1340 dcl output char (ofe) based (ofp);
1341 dcl (i, j, ii, jj, kk) fixed bin (24);
1342 dcl loc (24) fixed bin (24);
1343 dcl sep_ct fixed bin (24);
1344 dcl argstrl fixed bin (24);
1345 dcl rel fixed bin (24);
1346
1347 jj = ofe;
1348 construct_nest = construct_nest + 1;
1349 call strip (ifp, ifi, ife);
1350 begl = ifi;
1351 loop:
1352 i = search (substr (input, ifi), "&=^<>");
1353 if (i = 0)
1354 then do;
1355 log_err:
1356 msg = "Missing termination of logical expression. ";
1357 goto add_identification;
1358 end;
1359 if (i > 1)
1360 then do;
1361 i = i - 1;
1362 call putout (ofp, ofe, substr (input, ifi, i));
1363 ifi = ifi + i;
1364 end;
1365 rel = index ("&=^=<^>=", inputa (ifi));
1366 goto type (rel);
1367
1368 type (1):
1369 if (substr (input, ifi, 5) = "&then")
1370 | (substr (input, ifi, 2) = "&;")
1371 then do;
1372 kk = ofe;
1373 if db_sw | tr_sw
1374 then do;
1375 call ioa_$nnl ("#^a:^a^-log-^.1b (", lineno (begl), lineno (ifi - 1),
1376 TF);
1377 call show_string (substr (output, jj + 1, kk - jj), ")
1378 ");
1379 end;
1380 ofe = jj;
1381 if (TF = "00"b)
1382 then return;
1383 c32 = translate (substr (output, jj + 1, kk - jj),
1384 " ABCDEFGHIJKLMNOPQRSTUVWXYZ", "
1385 abcdefghijklmnopqrstuvwxyz");
1386 if (c32 = "0")
1387 | (c32 = "FALSE")
1388 | (c32 = "F")
1389 | (c32 = "NO")
1390 then TF = "01"b;
1391 else TF = "10"b;
1392 return;
1393 end;
1394 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
1395 goto loop;
1396 type (3):
1397 type (5):
1398 type (7):
1399 if (inputa (ifi + 1) = "=")
1400 then do;
1401 rel = rel + 1;
1402 ifi = ifi + 1;
1403 end;
1404 else if (rel = 3)
1405 then do;
1406 ifi = ifi + 1;
1407 call putout (ofp, ofe, "^");
1408 goto loop;
1409 end;
1410 type (2):
1411
1412
1413
1414 ifi = ifi + 1;
1415 ii = ofe;
1416 loop1:
1417 call strip (ifp, ifi, ife);
1418 j = index (substr (input, ifi), "&") -1;
1419 if (j < 0)
1420 then goto log_err;
1421 if (j > 0)
1422 then do;
1423 call putout (ofp, ofe, substr (input, ifi, j));
1424 ifi = ifi + j;
1425 end;
1426 if (substr (input, ifi, 5) = "&then")
1427 | (substr (input, ifi, 2) = "&;")
1428 then do;
1429 construct_nest = construct_nest - 1;
1430 kk = ofe;
1431 if db_sw | tr_sw
1432 then do;
1433 call ioa_$nnl ("#^a:^a^-log-^.1b (", lineno (begl),
1434 lineno (ifi - 1), TF);
1435 call show_string (substr (output, jj + 1, ii - jj), "");
1436 call ioa_$nnl (")^a(", relat (rel));
1437 call show_string (substr (output, ii + 1, kk - ii), ")
1438 ");
1439 end;
1440 ofe = jj;
1441 if (TF = "00"b)
1442 then return;
1443 dcl relat (2:8) char (2) int static
1444 init ("=", "!!", "^=", "<", "<=", ">", ">=");
1445 goto comp (rel);
1446 end;
1447 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
1448 goto loop1;
1449
1450 comp (2):
1451 if (substr (output, jj + 1, ii - jj) = substr (output, ii + 1, kk - ii))
1452 then TF = "10"b;
1453 else TF = "01"b;
1454 return;
1455
1456 comp (4):
1457 if (substr (output, jj + 1, ii - jj) ^= substr (output, ii + 1, kk - ii))
1458 then TF = "10"b;
1459 else TF = "01"b;
1460 return;
1461
1462 comp (5):
1463 if (substr (output, jj + 1, ii - jj) < substr (output, ii + 1, kk - ii))
1464 then TF = "10"b;
1465 else TF = "01"b;
1466 return;
1467
1468 comp (6):
1469 if (substr (output, jj + 1, ii - jj) <= substr (output, ii + 1, kk - ii))
1470 then TF = "10"b;
1471 else TF = "01"b;
1472 return;
1473
1474 comp (7):
1475 if (substr (output, jj + 1, ii - jj) > substr (output, ii + 1, kk - ii))
1476 then TF = "10"b;
1477 else TF = "01"b;
1478 return;
1479
1480 comp (8):
1481 if (substr (output, jj + 1, ii - jj) >= substr (output, ii + 1, kk - ii))
1482 then TF = "10"b;
1483 else TF = "01"b;
1484 return;
1485
1486 end logical; %page;
1487
1488
1489
1490
1491 lookup: proc (vname) returns (fixed bin) recursive;
1492
1493 dcl vname char (32) var;
1494
1495
1496
1497 var_ptr = local_var_ptr;
1498 do while (var_ptr ^= null ());
1499 if (var.name = vname)
1500 then return (3);
1501 var_ptr = var.next;
1502 end;
1503
1504
1505
1506 if (int_var_ptr = null ())
1507 then do;
1508 int_var_ptr = int_vars_base;
1509 do while (int_var_ptr ^= null ());
1510 if (macname = int_vars.macro)
1511 then goto found;
1512 else int_var_ptr = int_vars.next;
1513 end;
1514 allocate int_vars in (free_area);
1515 if al_sw
1516 then call ioa_ ("A int_vars ^a^i ^p", macname, size (int_vars),
1517 int_var_ptr);
1518 int_vars.next = int_vars_base;
1519 int_vars.ref = null ();
1520 int_vars.macro = macname;
1521 int_vars_base = int_var_ptr;
1522 end;
1523
1524 found:
1525 var_ptr = int_vars.ref;
1526 do while (var_ptr ^= null ());
1527 if (var.name = vname)
1528 then return (2);
1529 var_ptr = var.next;
1530 end;
1531
1532
1533
1534 var_ptr = ext_var_ptr;
1535 do while (var_ptr ^= null ());
1536 if (var.name = vname)
1537 then return (1);
1538 var_ptr = var.next;
1539 end;
1540
1541 return (0);
1542 end lookup; %page;
1543
1544
1545
1546
1547 macro_af: proc (ifp, ifi, ife, ofp, ofe, TF);
1548
1549 dcl ifp ptr,
1550 ifi fixed bin (24),
1551 ife fixed bin (24),
1552 ofp ptr,
1553 ofe fixed bin (24),
1554 TF bit (2);
1555 dcl begl fixed bin (24);
1556 dcl inputa (ife) char (1) based (ifp);
1557 dcl input char (ife) based (ifp);
1558 dcl output char (ofe) based (ofp);
1559 dcl (i, j, ii, jj) fixed bin (24);
1560 dcl level fixed bin (24);
1561
1562
1563
1564 begl = ifi;
1565 ifi = ifi + 2;
1566 call strip (ifp, ifi, ife);
1567 if db_sw then call dumper ("af..", ifp, ifi, ife, ofp, ofe, TF);
1568 ii = ofe;
1569 level = 1;
1570 construct_nest = construct_nest + 1;
1571 loop:
1572 i = search (substr (input, ifi), "&[]");
1573 if (i = 0)
1574 then do;
1575 msg = "]";
1576 call error_missing ("[", begl, ife);
1577 end;
1578 if (i > 1)
1579 then do;
1580 i = i - 1;
1581 call putout (ofp, ofe, substr (input, ifi, i));
1582 ifi = ifi + i;
1583 end;
1584 goto type (index ("&[]", inputa (ifi)));
1585
1586 type (1):
1587 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
1588 if (c32 = "&;")
1589 then goto misplaced;
1590 goto loop;
1591
1592 type (2):
1593 call putout (ofp, ofe, "[");
1594 ifi = ifi + 1;
1595 level = level + 1;
1596 goto loop;
1597
1598 type (3):
1599 call putout (ofp, ofe, "]");
1600 ifi = ifi + 1;
1601 level = level - 1;
1602 if (level > 0)
1603 then goto loop;
1604
1605 construct_nest = construct_nest - 1;
1606 ofe = ofe - 1;
1607 if (TF = "00"b)
1608 then do;
1609 ofe = ii;
1610 return;
1611 end;
1612 varlen = 500;
1613 dcl varlen fixed bin;
1614 begin;
1615 dcl rval char (varlen) var;
1616 rval = "";
1617 dcl cu_$evaluate_active_string entry (ptr, char(*), fixed bin, char(*) var,
1618 fixed bin(35));
1619 %include cp_active_string_types;
1620 call cu_$evaluate_active_string (null (),
1621 substr (output, ii + 1, ofe - ii),
1622 ATOMIC_ACTIVE_STRING, rval, ecode);
1623 if (ecode ^= 0)
1624 then do;
1625 err_ct = 0;
1626 msg = "Processing active functtion. ";
1627 msg_etc = substr (output, ii + 1, ofe - ii);
1628 goto add_id;
1629 end;
1630 ofe = ii;
1631 call putout (ofp, ofe, (rval));
1632 end;
1633 return;
1634
1635 end macro_af; %page;
1636
1637
1638
1639
1640 macro_call: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;
1641
1642 dcl ifp ptr,
1643 ifi fixed bin (24),
1644 ife fixed bin (24),
1645 ofp ptr,
1646 ofe fixed bin (24),
1647 TF bit (2);
1648 dcl begl fixed bin (24);
1649 dcl inputa (ife) char (1) based (ifp);
1650 dcl input char (ife) based (ifp);
1651 dcl output char (ofe) based (ofp);
1652 dcl (i, j, ii, jj) fixed bin (24);
1653 dcl loc (100) fixed bin (24);
1654 dcl (sep_ct, level) fixed bin (24);
1655 dcl argstrl fixed bin (24);
1656 dcl callseg char (32) var;
1657 dcl callmac char (32) var;
1658
1659 xxx
1660 xxx
1661
1662 begl = ifi;
1663 callseg = c32x;
1664 callmac = c32;
1665 call strip (ifp, ifi, ife);
1666 if db_sw then call dumper ("call", ifp, ifi, ife, ofp, ofe, TF);
1667 ii = ofe;
1668 call putout (ofp, ofe, "(");
1669 loc (1) = ofe;
1670 sep_ct = 1;
1671 level = 1;
1672 construct_nest = construct_nest + 1;
1673 loop:
1674 i = search (substr (input, ifi), "&(),");
1675 if (i = 0)
1676 then do;
1677 msg = ")";
1678 call error_missing (callmac || "(", begl, ife);
1679 end;
1680 if (i > 1)
1681 then do;
1682 i = i - 1;
1683 call putout (ofp, ofe, substr (input, ifi, i));
1684 ifi = ifi + i;
1685 end;
1686 goto type (index ("&(),", inputa (ifi)));
1687
1688 type (1):
1689 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
1690 if (c32 = "&;")
1691 then do;
1692 msg = "&;";
1693 call error_misplaced ("call", begl, ife);
1694 end;
1695 goto loop;
1696
1697 type (2):
1698 call putout (ofp, ofe, "(");
1699 ifi = ifi + 1;
1700 level = level + 1;
1701 goto loop;
1702
1703 type (3):
1704 call putout (ofp, ofe, ")");
1705 ifi = ifi + 1;
1706 level = level - 1;
1707 if (level > 0)
1708 then goto loop;
1709
1710 construct_nest = construct_nest - 1;
1711 loc (sep_ct + 1) = ofe;
1712 argstrl = ofe - loc (1) + 1;
1713 if (argstrl > 16384)
1714 then do;
1715 msg = "&call arg-string > 16384 chrs.";
1716 goto add_identification;
1717 end;
1718 begin;
1719 dcl 1 args (sep_ct) like argl;
1720 dcl argstr (argstrl) char (1) unal;
1721 if db_sw | tr_sw
1722 then do;
1723 call ioa_$nnl ("#^a:^a^-call ^a$^a ", lineno (begl),
1724 lineno (ifi - 1), callseg, callmac);
1725 call show_string (substr (output, loc (1), argstrl), NL);
1726 end;
1727 string (argstr) = substr (output, loc (1), argstrl);
1728 ofe = loc (1) - 1;
1729 if (argstrl = 2)
1730 then sep_ct = 0;
1731 do i = 1 to sep_ct;
1732 args.l (i) = loc (i + 1) - loc (i) - 1;
1733 j = loc (i) - ofe + 1;
1734 args.p (i) = addr (argstr (j));
1735 end;
1736 call macro_ (sl_name, callseg, callmac,
1737 ofp, ofe, addr (args), (sep_ct), msg, ifp, ecode);
1738 if (ecode = -1)
1739 then call error_gen ("call", begl, ifi);
1740 if (ecode ^= 0)
1741 then do;
1742 ifi = begl;
1743 call_err = "1"b;
1744 goto add_id;
1745 end;
1746 end;
1747 return;
1748
1749 type (4):
1750 call putout (ofp, ofe, ",");
1751 ifi = ifi + 1;
1752 if (level = 1)
1753 then do;
1754 if (sep_ct >= 100)
1755 then do;
1756 msg = "Cannot handle over 100 ";
1757 msg = msg || who_am_i;
1758 msg = msg || " arguments.";
1759 goto add_identification;
1760 end;
1761 sep_ct = sep_ct + 1;
1762 loc (sep_ct) = ofe;
1763 call strip (ifp, ifi, ife);
1764 end;
1765 goto loop;
1766 end macro_call; %page;
1767
1768
1769
1770
1771 macro_define: proc (ifp, ifi, ife, ofp, ofe, TF);
1772
1773 dcl ifp ptr,
1774 ifi fixed bin (24),
1775 ife fixed bin (24),
1776 ofp ptr,
1777 ofe fixed bin (24),
1778 TF bit (2);
1779 dcl begl fixed bin (24);
1780 dcl inputa (ife) char (1) based (ifp);
1781 dcl input char (ife) based (ifp);
1782 dcl output char (ofe) based (ofp);
1783 dcl (i, j, ii, jj) fixed bin (24);
1784 dcl loc (24) fixed bin (24);
1785 dcl sep_ct fixed bin (24);
1786 dcl argstrl fixed bin (24);
1787
1788
1789
1790 begl = ifi;
1791 ifi = ifi + 7;
1792 call strip (ifp, ifi, ife);
1793 if db_sw then call dumper ("defi", ifp, ifi, ife, ofp, ofe, TF);
1794 ii = ofe;
1795 construct_nest = construct_nest + 1;
1796 loop:
1797 i = index (substr (input, ifi), "&");
1798 if (i = 0)
1799 then do;
1800 msg = "&dend";
1801 call error_missing ("define", begl, ife);
1802 end;
1803 if (i > 1)
1804 then do;
1805 i = i - 1;
1806 call putout (ofp, ofe, substr (input, ifi, i));
1807 ifi = ifi + i;
1808 end;
1809 if (substr (input, ifi, 5) = "&dend")
1810 then do;
1811 ifi = ifi + 5;
1812 call strip (ifp, ifi, ife);
1813 if (TF & "10"b)
1814 then do;
1815 i = ii + 1;
1816 i = i + verify (substr (output, i, ofe - i + 1), space) - 1;
1817 j = verify (substr (output, i, ofe - i + 1),
1818 "abcdefghijklmnopqrstuvwxyz" ||
1819 "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
1820 if (j = 0)
1821 then do;
1822 def_err:
1823 call error_syntax ("define", begl, ifi);
1824 end;
1825 if (j < 2)
1826 then do;
1827 msg = "macroname";
1828 call error_missing ("define", begl, ifi);
1829 end;
1830 j = j - 1;
1831 c32 = substr (output, i, j);
1832 i = i + j;
1833 if (substr (output, i, 1) ^= NL)
1834 then goto def_err;
1835 macro_holder_l = ofe - i;
1836 allocate macro_holder in (free_area);
1837 macro_holder = substr (output, i + 1, macro_holder_l);
1838 if db_sw | tr_sw
1839 then do;
1840 call ioa_$nnl ("#^a:^a^-&define ^a^/^-", lineno (begl),
1841 lineno (ifi - 1), c32);
1842 call show_string (macro_holder, "&dend
1843 ");
1844 end;
1845 call addmacro (" &define'ed in " || myname || " ", "", c32, "1"b,
1846 macro_holder_p, 1, macro_holder_l);
1847 end;
1848 ofe = ii;
1849 construct_nest = construct_nest - 1;
1850 return;
1851 end;
1852 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
1853 goto loop;
1854 end macro_define; %page;
1855
1856
1857
1858
1859 macro_do: proc (ifp, ifi, ife, ofp, ofe, TF);
1860
1861 dcl ifp ptr,
1862 ifi fixed bin (24),
1863 ife fixed bin (24),
1864 ofp ptr,
1865 ofe fixed bin (24),
1866 TF bit (2);
1867 dcl begl fixed bin (24);
1868 dcl inputa (ife) char (1) based (ifp);
1869 dcl input char (ife) based (ifp);
1870 dcl output char (ofe) based (ofp);
1871 dcl (i, j, ii, jj) fixed bin (24);
1872 dcl tf bit (2);
1873
1874
1875
1876
1877 begl = ifi;
1878 ifi = ifi + 3;
1879 call strip (ifp, ifi, ife);
1880 if db_sw then call dumper ("do..", ifp, ifi, ife, ofp, ofe, TF);
1881 if (TF = "00"b)
1882 then goto skip;
1883 ii = ifi;
1884 jj = 0;
1885 construct_nest = construct_nest + 1;
1886 loop:
1887 call expand (ifp, ifi, ife, ofp, ofe, (TF));
1888 if (c32 = "&while")
1889 then do;
1890 ifi = ifi + length (c32);
1891 jj = 1;
1892 tf = TF;
1893 call logical (ifp, ifi, ife, ofp, ofe, tf);
1894 call get_token (ifp, ifi, ife);
1895 if (c32 ^= "&;")
1896 then do;
1897 msg = "&;";
1898 call error_missing ("while", begl, ifi);
1899 end;
1900 ifi = ifi + length (c32);
1901 call strip (ifp, ifi, ife);
1902 if (tf = "01"b)
1903 then do;
1904 skip:
1905 i = index (substr (input, ifi), "&");
1906 if (i = 0)
1907 then do;
1908 msg = "&od";
1909 call error_missing ("do", begl, ife);
1910 end;
1911 ifi = ifi + i - 1;
1912 call get_token (ifp, ifi, ife);
1913 if (c32 = "&do")
1914 then call macro_do (ifp, ifi, ife, ofp, ofe, "00"b);
1915 else if (c32 = "&""")
1916 then call protected (ifp, ifi, ife, ofp, (ofe));
1917 else if (c32 = "&od")
1918 then do;
1919 jj = 0;
1920 goto od;
1921 end;
1922 else ifi = ifi + 1;
1923 goto skip;
1924 end;
1925 goto loop;
1926 end;
1927 if (c32 = "&od")
1928 then do;
1929 od:
1930 ifi = ifi + length (c32);
1931 call strip (ifp, ifi, ife);
1932 if (jj = 0)
1933 then do;
1934 construct_nest = construct_nest - 1;
1935 return;
1936 end;
1937 ifi = ii;
1938 goto loop;
1939 end;
1940 msg = c32;
1941 call error_misplaced ("do", begl, ifi);
1942 end macro_do; %page;
1943
1944
1945
1946
1947 macro_empty: proc (ifp, ifi, ife, ofp, ofe, TF);
1948 dcl ifp ptr,
1949 ifi fixed bin (24),
1950 ife fixed bin (24),
1951 ofp ptr,
1952 ofe fixed bin (24),
1953 TF bit (2);
1954 dcl begl fixed bin (24);
1955 dcl inputa (ife) char (1) based (ifp);
1956 dcl input char (ife) based (ifp);
1957 dcl output char (ofe) based (ofp);
1958 dcl (i, j, ii, jj) fixed bin (24);
1959 dcl tf bit (2);
1960 dcl vname char (32) var;
1961
1962
1963
1964 begl = ifi;
1965 ifi = ifi + 6;
1966 call strip (ifp, ifi, ife);
1967 if db_sw then call dumper ("empt", ifp, ifi, ife, ofp, ofe, TF);
1968 i = verify (substr (input, ifi),
1969 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
1970 if (i = 0)
1971 then i = ife - ifi + 1;
1972 if (i = 1)
1973 then do;
1974 msg = "array name";
1975 call error_missing ("empty", begl, ifi);
1976 end;
1977 vname = substr (input, ifi, i - 1);
1978 if (length (vname) > 16)
1979 then do;
1980 msg = """";
1981 msg = msg || vname;
1982 msg = msg || """ > 16 characters.";
1983 call error_gen ("empty", begl, ifi);
1984 end;
1985 ifi = ifi + length (vname);
1986 call strip (ifp, ifi, ife);
1987 if (substr (input, ifi, 2) ^= "&;")
1988 then do;
1989 msg = "&;";
1990 call error_missing ("empty", begl, ifi);
1991 end;
1992 call strip2 (ifp, ifi, ife);
1993 i = lookup (vname);
1994 if (i = 0)
1995 then do;
1996 msg = """";
1997 msg = msg || vname;
1998 msg = msg || """ undefined.";
1999 call error_gen ("empty", begl, ifi);
2000 end;
2001 if (var.type = 0)
2002 then do;
2003 msg = """";
2004 msg = msg || vname;
2005 msg = msg || """ is a scalar.";
2006 call error_gen ("empty", begl, ifi);
2007 end;
2008 arr_ptr = var.ref;
2009
2010 if (var.type = 2)
2011 then do;
2012 array.h_bound = array.lower - 1;
2013 array.l_bound = array.lower + var.len;
2014 end;
2015 if (var.type = 3)
2016 then do;
2017 array.l_bound = 1;
2018 array.h_bound = 0;
2019 end;
2020 end macro_empty; %page;
2021
2022
2023
2024
2025 macro_error: proc (ifp, ifi, ife, ofp, ofe, TF);
2026
2027 dcl ifp ptr,
2028 ifi fixed bin (24),
2029 ife fixed bin (24),
2030 ofp ptr,
2031 ofe fixed bin (24),
2032 TF bit (2);
2033 dcl begl fixed bin (24);
2034 dcl inputa (ife) char (1) based (ifp);
2035 dcl input char (ife) based (ifp);
2036 dcl output char (ofe) based (ofp);
2037 dcl (i, j, ii, jj) fixed bin (24);
2038 dcl loc (24) fixed bin (24);
2039 dcl sep_ct fixed bin (24);
2040 dcl argstrl fixed bin (24);
2041 dcl ch8 pic "
2042
2043
2044
2045 begl = ifi;
2046 ifi = ifi + 6;
2047 call strip (ifp, ifi, ife);
2048 if db_sw then call dumper ("err.", ifp, ifi, ife, ofp, ofe, TF);
2049 ii = ofe;
2050 msg = "";
2051 construct_nest = construct_nest + 1;
2052 ifi = ifi - 2;
2053 call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
2054
2055 if (ofe ^= ii + 1)
2056 | (substr (output, ofe, 1) < "0")
2057 | (substr (output, ofe, 1) > "4")
2058 then do;
2059 ofe = ii;
2060 call putout (ofp, ofe, "4(Invalid &error severity, 4 assumed.) ");
2061 end;
2062 call strip (ifp, ifi, ife);
2063 if (inputa (ifi) ^= ",")
2064 then call putout (ofp, ofe, "(Missing comma after &error severity.) ");
2065 else ifi = ifi + 1;
2066 loop:
2067 i = index (substr (input, ifi), "&") -1;
2068 if (i < 0)
2069 then do;
2070 msg = "&;";
2071 call error_missing ("error", begl, ife);
2072 end;
2073 if (i > 0)
2074 then do;
2075 call putout (ofp, ofe, substr (input, ifi, i));
2076 ifi = ifi + i;
2077 end;
2078 if (substr (input, ifi, 2) = "&;")
2079 then do;
2080 call strip2 (ifp, ifi, ife);
2081 i = index ("01234", substr (output, ii + 1, 1)) - 1;
2082 err_ct (i) = err_ct (i) + 1;
2083 msg = NL;
2084 if (i = 0)
2085 then msg = msg || "NOTE: ";
2086 else if (i = 1)
2087 then msg = msg || "WARNING. ";
2088 else do;
2089 msg = msg || "ERROR SEVERITY ";
2090 msg = msg || substr (output, ii + 1, 1);
2091 msg = msg || ". ";
2092 end;
2093 msg = msg || who_am_i;
2094 msg = msg || " """;
2095 msg = msg || macname;
2096 msg = msg || """, line ";
2097 msg = msg || lineno (ifi);
2098 msg = msg || NL;
2099 call iox_$put_chars (iox_$error_output, addrel (addr (msg), 1),
2100 length (msg), 0);
2101 msg = "";
2102 substr (output, ofe + 1, 1) = NL;
2103 call iox_$put_chars (iox_$error_output,
2104 addr (substr (output, ii + 2, 1)), ofe - ii, 0);
2105 if (i = 4)
2106 then do;
2107 msg = "Error detected by ";
2108 msg = msg || who_am_i;
2109 msg = msg || " """;
2110 msg = msg || macname;
2111 msg = msg || """.";
2112 ecode = error_table_$translation_aborted;
2113 goto exit;
2114 end;
2115 ofe = ii;
2116 construct_nest = construct_nest - 1;
2117 return;
2118 end;
2119 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
2120 goto loop;
2121
2122 dcl iox_$error_output ptr ext static;
2123 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
2124 end macro_error; %page;
2125
2126
2127
2128
2129 macro_if: proc (ifp, ifi, ife, ofp, ofe, tf);
2130
2131 dcl ifp ptr,
2132 ifi fixed bin (24),
2133 ife fixed bin (24),
2134 ofp ptr,
2135 ofe fixed bin (24),
2136 tf bit (2);
2137
2138
2139 dcl begl fixed bin (24);
2140 dcl beglt fixed bin (24);
2141 dcl skip_sw bit (1);
2142 dcl inputa (ife) char (1) based (ifp);
2143 dcl input char (ife) based (ifp);
2144 dcl output char (ofe) based (ofp);
2145 dcl (i, j, ii, jj) fixed bin (24);
2146 dcl TF bit (2);
2147 dcl if_lineno char (6) var;
2148 dcl elseif bit (1);
2149
2150
2151
2152
2153 begl, beglt = ifi;
2154 ifi = ifi + 3;
2155 call strip (ifp, ifi, ife);
2156 TF = tf;
2157 if db_sw then call dumper ("if..", ifp, ifi, ife, ofp, ofe, TF);
2158 elseif = "0"b;
2159 if_lineno = lineno (begl);
2160
2161 nother_logical:
2162 call logical (ifp, ifi, ife, ofp, ofe, TF);
2163 if (tf = "00"b)
2164 then TF = "00"b;
2165 if db_sw | tr_sw
2166 then call ioa_ ("#^a:^a^-&^[else^]if (^a) ^[skip^;F^;T^;TF^]",
2167 lineno (beglt), lineno (ifi - 1), elseif, if_lineno,
2168 fixed (TF) + 1);
2169 call get_token (ifp, ifi, ife);
2170 if (c32 ^= "&then")
2171 then do;
2172 msg = "&then";
2173 call error_missing ("if", begl, ifi);
2174 end;
2175 beglt = ifi;
2176 ifi = ifi + length (c32);
2177 call strip (ifp, ifi, ife);
2178 construct_nest = construct_nest + 1;
2179 if (TF & "10"b)
2180 then call expand (ifp, ifi, ife, ofp, ofe, (TF));
2181 else call skipper;
2182 if db_sw | tr_sw
2183 then call ioa_ ("#^a:^a^-&then (^a) ^[done^;skip^]", lineno (beglt),
2184 lineno (ifi - 1), if_lineno, (TF & "10"b));
2185 skip_again:
2186 beglt = ifi;
2187 if (c32 = "&elseif")
2188 then do;
2189 ifi = ifi + length (c32);
2190 call strip (ifp, ifi, ife);
2191 if (TF & "01"b)
2192 then do;
2193 construct_nest = construct_nest - 1;
2194 elseif = "1"b;
2195 goto nother_logical;
2196 end;
2197 call skipper;
2198 if db_sw | tr_sw
2199 then call ioa_ ("#^a:^a^-&elseif (^a) skip",
2200 lineno (beglt), lineno (ifi - 1), if_lineno);
2201 goto skip_again;
2202 end;
2203 if (c32 = "&else")
2204 then do;
2205 ifi = ifi + length (c32);
2206 call strip (ifp, ifi, ife);
2207 if (TF & "01"b)
2208 then call expand (ifp, ifi, ife, ofp, ofe, (TF));
2209 else call skipper;
2210 if db_sw | tr_sw
2211 then call ioa_ ("#^a:^a^-&else (^a) ^[done^;skip^]",
2212 lineno (beglt), lineno (ifi - 1), if_lineno, TF & "01"b);
2213 beglt = ifi;
2214 end;
2215 if (c32 ^= "&fi")
2216 then do;
2217 msg = "&fi";
2218 call error_missing ("if", begl, ifi);
2219 end;
2220 construct_nest = construct_nest - 1;
2221 ifi = ifi + length (c32);
2222 call strip (ifp, ifi, ife);
2223 if db_sw | tr_sw
2224 then call ioa_ ("#^a:^a^-&fi (^a)",
2225 lineno (beglt), lineno (ifi - 1), if_lineno);
2226 return;
2227
2228 skipper: proc;
2229
2230 do while ("1"b);
2231 i = index (substr (input, ifi), "&");
2232 if (i = 0)
2233 then do;
2234 c32 = "";
2235 return;
2236 end;
2237 ifi = ifi + i - 1;
2238 call get_token (ifp, ifi, ife);
2239 if (c32 = "&if")
2240 then call macro_if (ifp, ifi, ife, ofp, ofe, "00"b);
2241 else if (c32 = "&fi")
2242 then return;
2243 else if (c32 = "&else")
2244 then return;
2245 else if (c32 = "&elseif")
2246 then return;
2247 else if (c32 = "&""")
2248 then call protected (ifp, ifi, ife, ofp, (ofe));
2249 else ifi = ifi + 1;
2250 end;
2251
2252 end;
2253
2254 end macro_if; %page;
2255
2256
2257
2258
2259 macro_length: proc (ifp, ifi, ife, ofp, ofe, TF);
2260
2261 dcl ifp ptr,
2262 ifi fixed bin (24),
2263 ife fixed bin (24),
2264 ofp ptr,
2265 ofe fixed bin (24),
2266 TF bit (2);
2267 dcl begl fixed bin (24);
2268 dcl inputa (ife) char (1) based (ifp);
2269 dcl input char (ife) based (ifp);
2270 dcl output char (ofe) based (ofp);
2271 dcl (i, j, ii, jj) fixed bin (24);
2272 dcl loc (24) fixed bin (24);
2273 dcl sep_ct fixed bin (24);
2274 dcl argstrl fixed bin (24);
2275
2276
2277
2278 begl = ifi;
2279 ifi = ifi + 7;
2280 call strip (ifp, ifi, ife);
2281 if db_sw then call dumper ("leng", ifp, ifi, ife, ofp, ofe, TF);
2282 ii = ofe;
2283 construct_nest = construct_nest + 1;
2284 loop:
2285 i = index (substr (input, ifi), "&") -1;
2286 if (i < 0)
2287 then do;
2288 msg = "&;";
2289 call error_missing ("length", begl, ife);
2290 end;
2291 if (i > 0)
2292 then do;
2293 call putout (ofp, ofe, substr (input, ifi, i));
2294 ifi = ifi + i;
2295 end;
2296 if (substr (input, ifi, 2) = "&;")
2297 then do;
2298 call strip2 (ifp, ifi, ife);
2299 i = ofe - ii;
2300 ofe = ii;
2301 call putout (ofp, ofe, ltrim (char (i)));
2302 construct_nest = construct_nest - 1;
2303 return;
2304 end;
2305 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
2306 goto loop;
2307 end macro_length; %page;
2308
2309
2310
2311
2312 macro_let: proc (ifp, ifi, ife, ofp, ofe, TF, which) recursive;
2313
2314 dcl ifp ptr,
2315 ifi fixed bin (24),
2316 ife fixed bin (24),
2317 ofp ptr,
2318 ofe fixed bin (24),
2319 TF bit (2),
2320 which fixed bin (24);
2321 dcl begl fixed bin (24);
2322 dcl inputa (ife) char (1) based (ifp);
2323 dcl input char (ife) based (ifp);
2324 dcl output char (ofe) based (ofp);
2325 dcl (i, j, ii, jj) fixed bin (24);
2326 dcl vname char (32) var;
2327 dcl vptr ptr;
2328 dcl found fixed bin (24);
2329 dcl (lower, higher) fixed bin (24);
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340 begl = ifi;
2341 ifi = ifi + 4;
2342 call strip (ifp, ifi, ife);
2343 if db_sw then call dumper (cmd (which), ifp, ifi, ife, ofp, ofe, TF);
2344 i = verify (substr (input, ifi, 1),
2345 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ");
2346 if (i ^= 0)
2347 then do;
2348 msg = "Variable name must begin with alphabetic char. ";
2349 call error_gen (cmd (which), begl, ifi);
2350 end;
2351 i = verify (substr (input, ifi),
2352 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
2353 if (i = 0)
2354 then i = ife - ifi + 1;
2355 else i = i - 1;
2356 vname = substr (input, ifi, i);
2357 if (i > 16)
2358 then do;
2359 msg = "Data name > 16 characters. ";
2360 goto add_identification;
2361 end;
2362 ifi = ifi + i;
2363 dcl reserved (29) char (8) int static init (
2364 "arg",
2365 "comment",
2366 "define",
2367 "dend",
2368 "do",
2369 "else",
2370 "elseif",
2371 "empty",
2372 "error",
2373 "expand",
2374 "expend",
2375 "ext",
2376 "fi",
2377 "hbound",
2378 "if",
2379 "int",
2380 "let",
2381 "lbound",
2382 "length",
2383 "loc",
2384 "macro",
2385 "mend",
2386 "quote",
2387 "return",
2388 "scan",
2389 "substr",
2390 "unquote",
2391 "usage",
2392 "while");
2393 do i = 1 to hbound (reserved, 1);
2394 if (vname = reserved (i))
2395 then do;
2396 msg = "Attempt to use reserved word """;
2397 msg = msg || vname;
2398 msg = msg || """ as variable. ";
2399 goto add_identification;
2400 end;
2401 end;
2402 found = lookup (vname);
2403 if (found < which)
2404 then do;
2405 allocate var in (free_area) set (var_ptr);
2406 if al_sw
2407 then call ioa_ ("A var-^a ^i ^p", vname, size (var), var_ptr);
2408 var.name = vname;
2409 var.ref = null ();
2410 var.type = 0;
2411 var.len = 0;
2412 if (which = 1)
2413 then do;
2414 var.next = ext_var_ptr;
2415 ext_var_ptr = var_ptr;
2416 if db_sw
2417 then call ioa_ ("^p ext ""^a""", var_ptr, var.name);
2418 end;
2419 else if (which = 2)
2420 then do;
2421 var.next = int_vars.ref;
2422 int_vars.ref = var_ptr;
2423 if db_sw
2424 then call ioa_ ("^p int.^a ""^a""", var_ptr, macname,
2425 var.name);
2426 end;
2427 else do;
2428 var.next = local_var_ptr;
2429 local_var_ptr = var_ptr;
2430 if db_sw
2431 then call ioa_ ("^p loc ""^a""", var_ptr, var.name);
2432 end;
2433 end;
2434 else if (found = 0)
2435 then do;
2436 msg = "Attempt to set undeclared variable """;
2437 msg = msg || vname;
2438 msg = msg || """. ";
2439 goto add_identification;
2440 end;
2441 vptr = var_ptr;
2442 call strip (ifp, ifi, ife);
2443 if (which > 0)
2444 then if (substr (input, ifi, 2) = "&;")
2445 then do;
2446 call strip2 (ifp, ifi, ife);
2447 return;
2448 end;
2449 if (inputa (ifi) = "{")
2450 then do;
2451 ifi = ifi - 1;
2452 if (var.type = 0)
2453 then do;
2454 lower, higher = -9999;
2455 end;
2456 else do;
2457 arr_ptr = var.ref;
2458 lower = array.l_bound;
2459 higher = array.h_bound;
2460 end;
2461 call get_range (ifp, ifi, ife, ofp, ofe, TF, lower, higher);
2462 if (inputa (ifi) ^= "}")
2463 then do;
2464 msg = "}";
2465 call error_missing (cmd (which), begl, ifi);
2466 end;
2467 ifi = ifi + 1;
2468 call strip (ifp, ifi, ife);
2469 var_ptr = vptr;
2470 if (which > 0)
2471 then do;
2472 if (lower = higher)
2473 then do;
2474 if (lower < 1)
2475 then do;
2476 msg = "Improper dimension. ";
2477 goto add_identification;
2478 end;
2479 lower = 1;
2480 end;
2481 if (found ^= which)
2482 then do;
2483 var.type = 1;
2484 var.len = higher - lower + 1;
2485 allocate array in (free_area) set (arr_ptr);
2486 var.ref = arr_ptr;
2487 if al_sw
2488 then call ioa_ ("A^a{^i:^i} ^i ^p", vname, lower,
2489 higher, size (array), var.ref);
2490 do arr_elem = 1 to var.len;
2491 array.ref (arr_elem) = null ();
2492 array.len (arr_elem) = 0;
2493 end;
2494 array.lower = lower;
2495 end;
2496 if (substr (input, ifi, 3) = "var")
2497 then do;
2498 ifi = ifi + 3;
2499 if (found = which)
2500 then do;
2501 if (var.type ^= 2)
2502 | (array.lower ^= lower)
2503 | (var.len ^= higher - lower + 1)
2504 then do;
2505 dcl_err:
2506 msg = "Data declaration does not match prior declaration for """;
2507 msg = msg || vname;
2508 msg = msg || """. ";
2509 goto add_identification;
2510 end;
2511 end;
2512 else do;
2513 var.type = 2;
2514 array.l_bound = higher + 1;
2515 array.h_bound = lower - 1;
2516 end;
2517 end;
2518 else if (substr (input, ifi, 4) = "list")
2519 then do;
2520 ifi = ifi + 4;
2521 if (found = which)
2522 then do;
2523 if (var.type ^= 3)
2524 | (var.len ^= higher)
2525 then goto dcl_err;
2526 end;
2527 else do;
2528 var.type = 3;
2529 array.l_bound = 1;
2530 array.h_bound = 0;
2531 end;
2532 end;
2533 else if (substr (input, ifi, 4) = "fifo")
2534 then do;
2535 ifi = ifi + 4;
2536 if (found = which)
2537 then do;
2538 if (var.type ^= 4)
2539 | (array.l_bound ^= lower)
2540 | (array.h_bound ^= higher)
2541 then goto dcl_err;
2542 end;
2543 else do;
2544 var.type = 4;
2545 array.l_bound = 1;
2546 array.h_bound = 0;
2547 end;
2548 end;
2549 else if (substr (input, ifi, 4) = "lifo")
2550 then do;
2551 ifi = ifi + 4;
2552 if (found = which)
2553 then do;
2554 if (var.type ^= 5)
2555 | (array.l_bound ^= lower)
2556 | (array.h_bound ^= higher)
2557 then goto dcl_err;
2558 end;
2559 else do;
2560 var.type = 5;
2561 array.l_bound = 1;
2562 array.h_bound = 0;
2563 end;
2564 end;
2565 else do;
2566 if (found = which)
2567 then do;
2568 if (var.type ^= 1)
2569 | (array.l_bound ^= lower)
2570 | (array.h_bound ^= higher)
2571 then goto dcl_err;
2572 end;
2573 else do;
2574 array.l_bound = lower;
2575 array.h_bound = higher;
2576 end;
2577 end;
2578 call strip (ifp, ifi, ife);
2579 end;
2580 else do;
2581 if (var.type ^= 1) & (var.type ^= 2)
2582 then do;
2583 msg = "Attempt to do array assignment to non-array variable. ";
2584 goto add_identification;
2585 end;
2586 arr_ptr = var.ref;
2587 if (lower < array.lower)
2588 then do;
2589 msg = "Attempt to set below lower bound. ";
2590 goto add_identification;
2591 end;
2592 if (higher > array.lower + var.len - 1)
2593 then do;
2594 msg = "Attempt to set above upper bound. ";
2595 goto add_identification;
2596 end;
2597 end;
2598 call strip (ifp, ifi, ife);
2599 if (which > 0)
2600 then if (substr (input, ifi, 2) = "&;")
2601 then do;
2602 call strip2 (ifp, ifi, ife);
2603 return;
2604 end;
2605 end;
2606 else do;
2607 if (var.type = 1)
2608 | (var.type = 2)
2609 then do;
2610 msg = "Attempt to do scalar assignment to array variable. ";
2611 goto add_identification;
2612 end;
2613 if (var.type = 4)
2614 then do;
2615 arr_ptr = var.ref;
2616 if (array.l_bound + var.len - 1 > array.h_bound)
2617 then do;
2618 msg = "Out-of-bounds on fifo """;
2619 msg = msg || vname;
2620 msg = msg || """. ";
2621 goto add_identification;
2622 end;
2623 if (array.l_bound + var.len - 1 = array.h_bound)
2624 then do;
2625 msg = "Attempt to stack too many elements. ";
2626 goto add_identification;
2627 end;
2628 array.h_bound = array.h_bound + 1;
2629 lower, higher = mod (array.h_bound, var.len) + 1;
2630 end;
2631 if (var.type = 5)
2632 then do;
2633 arr_ptr = var.ref;
2634 if (var.len < array.h_bound)
2635 then do;
2636 msg = "Out-of-bounds on lifo """;
2637 msg = msg || vname;
2638 msg = msg || """. ";
2639 goto add_identification;
2640 end;
2641 if (var.len = array.h_bound)
2642 then do;
2643 msg = "Attempt to stack too many elements. ";
2644 goto add_identification;
2645 end;
2646 array.h_bound, lower, higher = array.h_bound + 1;
2647 end;
2648 end;
2649 if (inputa (ifi) ^= "=")
2650 then do;
2651 msg = "=";
2652 call error_missing (cmd (which), begl, ifi);
2653 dcl cmd (0:3) char (4) int static init ("let ", "ext ", "int ", "loc ");
2654 end;
2655 ifi = ifi + 1;
2656 call strip (ifp, ifi, ife);
2657 jj = ofe;
2658 if (inputa (ifi) = "(")
2659 then do;
2660 msg = "Vector assignment not available yet.";
2661 call error_gen (cmd (which), begl, ifi);
2662 end;
2663 if (substr (input, ifi, 2) = "&(")
2664 then do;
2665 call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
2666 call strip (ifp, ifi, ife);
2667 end;
2668 else do;
2669 construct_nest = construct_nest + 1;
2670 loop:
2671 i = index (substr (input, ifi), "&") -1;
2672 if (i < 0)
2673 then do;
2674 msg = "&;";
2675 call error_missing (cmd (which), begl, ife);
2676 end;
2677 if (i > 0)
2678 then do;
2679 call putout (ofp, ofe, substr (input, ifi, i));
2680 ifi = ifi + i;
2681 end;
2682 if (substr (input, ifi, 2) ^= "&;")
2683 then do;
2684 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
2685 goto loop;
2686 end;
2687 construct_nest = construct_nest - 1;
2688 end;
2689 if (substr (input, ifi, 2) ^= "&;")
2690 then do;
2691 msg = "&;";
2692 call error_missing (cmd (which), begl, ife);
2693 end;
2694 call strip2 (ifp, ifi, ife);
2695 if (found = 0)
2696 | (which = 0)
2697 then do;
2698 j = ofe - jj;
2699 var_ptr = vptr;
2700 if (var.type = 0)
2701 then do;
2702 if (var.len ^= j)
2703 then do;
2704 if (var.len > 0)
2705 then do;
2706 if al_sw
2707 then call ioa_ ("F ^a ^i ^p", vname, var.len,
2708 var.ref);
2709 free vartext in (free_area);
2710 end;
2711 var.len = j;
2712 allocate vartext in (free_area) set (var.ref);
2713 if al_sw
2714 then call ioa_ ("A ^a ^i ^p", vname, size (vartext),
2715 var.ref);
2716 end;
2717 vartext = substr (output, jj + 1, j);
2718 if db_sw | tr_sw
2719 then do;
2720 call ioa_$nnl ("#^a:^a^-&^a ^a =", lineno (begl),
2721 lineno (ifi - 1), cmd (which), var.name);
2722 call show_string (vartext, "&;
2723 ");
2724 end;
2725 end;
2726 else do;
2727 arr_ptr = var.ref;
2728 if (var.type = 2)
2729 then do;
2730 array.l_bound = min (array.l_bound, lower);
2731 array.h_bound = max (array.h_bound, higher);
2732 end;
2733 if (var.type = 3)
2734 then do;
2735 do arr_elem = array.l_bound to array.h_bound;
2736 if (arrtext = substr (output, jj + 1, j))
2737 then do;
2738 ofe = jj;
2739 return;
2740 end;
2741 end;
2742 if (array.h_bound = var.len)
2743 then do;
2744 msg = "Attempt to add too many elements to list. ";
2745 goto add_identification;
2746 end;
2747 array.h_bound, lower, higher = array.h_bound + 1;
2748 end;
2749 do arr_elem = lower - array.lower + 1 to higher - array.lower + 1;
2750 if (array.len (arr_elem) ^= j)
2751 then do;
2752 if (array.ref (arr_elem) ^= null ())
2753 then do;
2754 if al_sw
2755 then call ioa_ ("F ^a{^i} ^i ^p", vname,
2756 arr_elem, array.len (arr_elem),
2757 array.ref (arr_elem));
2758 free arrtext in (free_area);
2759 end;
2760 array.len (arr_elem) = j;
2761 allocate arrtext in (free_area) set (array.ref (arr_elem));
2762 if al_sw
2763 then call ioa_ ("A ^a{^i} ^i ^p", vname,
2764 arr_elem, size (arrtext),
2765 array.ref (arr_elem));
2766 end;
2767 arrtext = substr (output, jj + 1, j);
2768 end;
2769 if db_sw | tr_sw
2770 then do;
2771 call ioa_$nnl ("#^a:^a^-&^a ^a{^i:^i} =", lineno (begl),
2772 lineno (ifi - 1), cmd (which), var.name, lower, higher);
2773 call show_string (substr (output, jj + 1, j), "&;
2774 ");
2775 end;
2776 end;
2777 end;
2778 ofe = jj;
2779 end macro_let; %page;
2780
2781
2782
2783
2784 macro_quote: proc (ifp, ifi, ife, ofp, ofe, tf);
2785
2786 dcl ifp ptr,
2787 ifi fixed bin (24),
2788 ife fixed bin (24),
2789 ofp ptr,
2790 ofe fixed bin (24),
2791 tf bit (2);
2792
2793 dcl begl fixed bin (24);
2794 dcl inputa (ife) char (1) based (ifp);
2795 dcl input char (ife) based (ifp);
2796 dcl output char (ofe) based (ofp);
2797 dcl (i, j, ii, jj) fixed bin (24);
2798 dcl inside bit (1);
2799 dcl ch char (1);
2800
2801
2802
2803 begl = ifi;
2804 ifi = ifi + 6;
2805 call strip (ifp, ifi, ife);
2806 ii = ofe;
2807 construct_nest = construct_nest + 1;
2808 loop:
2809 i = index (substr (input, ifi), "&") -1;
2810 if (i < 0)
2811 then do;
2812 msg = "&;";
2813 call error_missing ("quote", begl, ife);
2814 end;
2815 if (i > 0)
2816 then do;
2817 call putout (ofp, ofe, substr (input, ifi, i));
2818 ifi = ifi + 1;
2819 end;
2820 if (substr (input, ifi, 2) ^= "&;")
2821 then do;
2822 call ampersand (ifp, ifi, ife, ofp, ofe, tf, "0"b);
2823 goto loop;
2824 end;
2825 call strip2 (ifp, ifi, ife);
2826 i = ofe - ii;
2827 if (i > 16384)
2828 then do;
2829 msg = "Sorry, not yet handling "e strings > 16384 chrs.";
2830 goto add_identification;
2831 end;
2832 construct_nest = construct_nest - 1;
2833 if (index (substr (output, ii + 1, i), """") = 0)
2834 then do;
2835 return;
2836 end;
2837 begin;
2838 dcl argstr char (i);
2839 argstr = substr (output, ii + 1, i);
2840 ofe = ii;
2841 j = 1;
2842 loop:
2843 ii = index (substr (argstr, j), """");
2844 if (ii = 0)
2845 then ii = i - j + 1;
2846 call putout (ofp, ofe, substr (argstr, j, ii));
2847 j = j + ii;
2848 if (substr (output, ofe, 1) = """")
2849 then call putout (ofp, ofe, """");
2850 if (j > i)
2851 then return;
2852 goto loop;
2853 end;
2854 end macro_quote; %page;
2855
2856
2857
2858
2859 macro_scan: proc (ifp, ifi, ife, ofp, ofe, TF);
2860
2861 dcl ifp ptr,
2862 ifi fixed bin (24),
2863 ife fixed bin (24),
2864 ofp ptr,
2865 ofe fixed bin (24),
2866 TF bit (2);
2867 dcl begl fixed bin (24);
2868 dcl inputa (ife) char (1) based (ifp);
2869 dcl input char (ife) based (ifp);
2870 dcl output char (ofe) based (ofp);
2871 dcl (i, j, ii, jj) fixed bin (24);
2872 dcl loc (24) fixed bin (24);
2873 dcl sep_ct fixed bin (24);
2874 dcl argstrl fixed bin (24);
2875
2876
2877
2878 begl = ifi;
2879 ifi = ifi + 5;
2880 call strip (ifp, ifi, ife);
2881 if db_sw then call dumper ("scan", ifp, ifi, ife, ofp, ofe, TF);
2882 ii = ofe;
2883 construct_nest = construct_nest + 1;
2884 loop:
2885 i = index (substr (input, ifi), "&") -1;
2886 if (i < 0)
2887 then do;
2888 msg = "&;";
2889 call error_missing ("scan", begl, ife);
2890 end;
2891 if (i > 0)
2892 then do;
2893 call putout (ofp, ofe, substr (input, ifi, i));
2894 ifi = ifi + i;
2895 end;
2896 if (substr (input, ifi, 2) = "&;")
2897 then do;
2898 call strip2 (ifp, ifi, ife);
2899 argstrl = ofe - ii;
2900 if (argstrl > 16384)
2901 then do;
2902 msg = "&scan string > 16384 chars.";
2903 goto add_identification;
2904 end;
2905 begin;
2906 dcl argstr char (argstrl);
2907 if db_sw | tr_sw
2908 then do;
2909 call ioa_$nnl ("#^a:^a^-&scan ", lineno (begl), lineno (ifi - 1));
2910 call show_string (substr (output, ii + 1, argstrl), "&;
2911 ");
2912 end;
2913 string (argstr) = substr (output, ii + 1, argstrl);
2914 ofe = ii;
2915 call expand (addr (argstr), 1, argstrl, ofp, ofe, (TF));
2916 construct_nest = construct_nest - 1;
2917 return;
2918 end;
2919 end;
2920 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
2921 goto loop;
2922 end macro_scan; %page;
2923
2924
2925
2926
2927 macro_substr: proc (ifp, ifi, ife, ofp, ofe, TF);
2928
2929 dcl ifp ptr,
2930 ifi fixed bin (24),
2931 ife fixed bin (24),
2932 ofp ptr,
2933 ofe fixed bin (24),
2934 TF bit (2);
2935 dcl begl fixed bin (24);
2936 dcl inputa (ife) char (1) based (ifp);
2937 dcl input char (ife) based (ifp);
2938 dcl output char (ofe) based (ofp);
2939 dcl (i, j, ii, jj) fixed bin (24);
2940 dcl loc (24) fixed bin (24);
2941 dcl sep_ct fixed bin (24);
2942 dcl argstrl fixed bin (24);
2943
2944
2945
2946
2947
2948 begl = ifi;
2949 ifi = ifi + 7;
2950 call strip (ifp, ifi, ife);
2951 if db_sw then call dumper ("subs", ifp, ifi, ife, ofp, ofe, TF);
2952 ii = ofe;
2953 construct_nest = construct_nest + 1;
2954 loop:
2955 i = search (substr (input, ifi), "&,") -1;
2956 if (i < 0)
2957 then do;
2958 msg = "&;";
2959 call error_missing ("substr", begl, ife);
2960 end;
2961 if (i > 0)
2962 then do;
2963 call putout (ofp, ofe, substr (input, ifi, i));
2964 ifi = ifi + i;
2965 end;
2966 if (inputa (ifi) = "&")
2967 then do;
2968 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
2969 goto loop;
2970 end;
2971 argstrl = ofe - ii;
2972 if (argstrl > 16384)
2973 then do;
2974 msg = "&substr string > 16384 chrs.";
2975 goto add_identification;
2976 end;
2977 begin;
2978 dcl argstr char (argstrl);
2979 dcl sepch char (1);
2980 argstr = substr (output, ii + 1, argstrl);
2981 ofe = ii;
2982 ifi = ifi - 1;
2983 call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
2984 i = fixed (substr (output, ii + 1, ofe - ii));
2985 sepch = " ";
2986 ofe = ii;
2987 if (inputa (ifi) = ",")
2988 | (inputa (ifi) = ":")
2989 then do;
2990 sepch = inputa (ifi);
2991 ifi = ifi - 1;
2992 call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
2993 j = fixed (substr (output, ii + 1, ofe - ii));
2994 ofe = ii;
2995 end;
2996 if (substr (input, ifi, 2) ^= "&;")
2997 then goto misplaced;
2998 call strip2 (ifp, ifi, ife);
2999 if (TF ^= "00"b)
3000 then do;
3001 if (i < 0)
3002 then i = argstrl + i + 1;
3003 if (sepch = " ")
3004 then j = argstrl - i + 1;
3005 if (sepch = ":")
3006 then do;
3007 if (j < 1)
3008 then do;
3009 msg = "Substr end location <0. ";
3010 goto add_identification;
3011 end;
3012 if (j < i)
3013 then do;
3014 msg = "Substr end before begin. ";
3015 goto add_identification;
3016 end;
3017 j = j - i + 1;
3018 end;
3019 if (j < 0)
3020 then do;
3021 jj = (argstrl - i + 1) + j;
3022 if (jj < 0)
3023 then do;
3024 substr (output, ofe + 1, -jj) = " ";
3025 ofe = ofe - jj;
3026 j = -j + jj;
3027 end;
3028 else j = -j;
3029 end;
3030 if (i < 1)
3031 then do;
3032 msg = "Substr before string begin. ";
3033 goto add_identification;
3034 end;
3035 if (i > argstrl)
3036 then do;
3037 msg = "Substr after string end. ";
3038 msg_etc = ltrim (char (i));
3039 msg_etc = msg_etc || ",";
3040 msg_etc = msg_etc || ltrim (char (j));
3041 msg_etc = msg_etc || " of ";
3042 msg_etc = msg_etc || ltrim (char (argstrl));
3043 msg_etc = msg_etc || """";
3044 msg_etc = msg_etc || argstr;
3045 msg_etc = msg_etc || """";
3046 goto add_identification;
3047 end;
3048 jj = min (argstrl-i+1, j);
3049 call putout (ofp, ofe, substr (argstr, i, jj));
3050 if (j > jj)
3051 then call putout (ofp, ofe, copy (" ",j-jj));
3052 end;
3053 end;
3054 construct_nest = construct_nest - 1;
3055 end macro_substr; %page;
3056
3057
3058
3059
3060 macro_unquote: proc (ifp, ifi, ife, ofp, ofe, tf);
3061
3062 dcl ifp ptr,
3063 ifi fixed bin (24),
3064 ife fixed bin (24),
3065 ofp ptr,
3066 ofe fixed bin (24),
3067 tf bit (2);
3068
3069 dcl begl fixed bin (24);
3070 dcl inputa (ife) char (1) based (ifp);
3071 dcl input char (ife) based (ifp);
3072 dcl output char (ofe) based (ofp);
3073 dcl (i, j, ii, jj) fixed bin (24);
3074 dcl inside bit (1);
3075 dcl ch char (1);
3076
3077
3078
3079 begl = ifi;
3080 ifi = ifi + 8;
3081 call strip (ifp, ifi, ife);
3082 ii = ofe;
3083 construct_nest = construct_nest + 1;
3084 loop:
3085 i = index (substr (input, ifi), "&") -1;
3086 if (i < 0)
3087 then do;
3088 msg = "&;";
3089 call error_missing ("unquote", begl, ife);
3090 end;
3091 if (i > 0)
3092 then do;
3093 call putout (ofp, ofe, substr (input, ifi, i));
3094 ifi = ifi + 1;
3095 end;
3096 if (substr (input, ifi, 2) ^= "&;")
3097 then do;
3098 call ampersand (ifp, ifi, ife, ofp, ofe, tf, "0"b);
3099 goto loop;
3100 end;
3101 call strip2 (ifp, ifi, ife);
3102 construct_nest = construct_nest - 1;
3103 i = ii;
3104 inside = "0"b;
3105 do ii = ii + 1 to ofe;
3106 ch = substr (output, ii, 1);
3107 if (ch = """")
3108 then do;
3109 if inside
3110 then do;
3111 if (substr (output, ii + 1, 1) = """")
3112 then do;
3113 ii = ii + 1;
3114 goto use_char;
3115 end;
3116 else inside = "0"b;
3117 end;
3118 else inside = "1"b;
3119 end;
3120 else do;
3121 use_char:
3122 i = i + 1;
3123 substr (output, i, 1) = ch;
3124 end;
3125 end;
3126 ofe = i;
3127
3128 end macro_unquote; %page;
3129
3130
3131
3132
3133 macro_usage: proc (ifp, ifi, ife, ofp, ofe, TF);
3134
3135 dcl ifp ptr,
3136 ifi fixed bin (24),
3137 ife fixed bin (24),
3138 ofp ptr,
3139 ofe fixed bin (24),
3140 TF bit (2);
3141 dcl begl fixed bin (24);
3142 dcl inputa (ife) char (1) based (ifp);
3143 dcl input char (ife) based (ifp);
3144 dcl output char (ofe) based (ofp);
3145 dcl (i, j, ii, jj) fixed bin (24);
3146 dcl loc (24) fixed bin (24);
3147 dcl sep_ct fixed bin (24);
3148 dcl argstrl fixed bin (24);
3149 dcl ctl char (100) var;
3150 dcl ret_str char (256);
3151 dcl ret_len fixed bin (24);
3152 dcl ioa_$rsnpnnl entry options (variable);
3153
3154
3155
3156 begl = ifi;
3157 ifi = ifi + 6;
3158 call strip (ifp, ifi, ife);
3159 if db_sw then call dumper ("usag", ifp, ifi, ife, ofp, ofe, TF);
3160 ii = ofe;
3161 construct_nest = construct_nest + 1;
3162 loop:
3163 i = index (substr (input, ifi), "&") -1;
3164 if (i < 0)
3165 then do;
3166 msg = "&;";
3167 call error_missing ("usage", begl, ife);
3168 end;
3169 if (i > 0)
3170 then do;
3171 call putout (ofp, ofe, substr (input, ifi, i));
3172 ifi = ifi + i;
3173 end;
3174 if (substr (input, ifi, 2) = "&;")
3175 then do;
3176 call strip2 (ifp, ifi, ife);
3177 ctl = substr (output, ii + 1, ofe - ii);
3178 ofe = ii;
3179 do maclp = macro_list_p
3180 repeat (macro_list.next)
3181 while (maclp ^= null ());
3182 call ioa_$rsnpnnl (ctl, ret_str, ret_len,
3183 macro_list.dname, macro_list.ename,
3184 macro_list.name);
3185 call putout (ofp, ofe, substr (ret_str, 1, ret_len));
3186 end;
3187 construct_nest = construct_nest - 1;
3188 return;
3189 end;
3190 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
3191 goto loop;
3192 end macro_usage; %page;
3193
3194
3195
3196
3197
3198 putout: proc (ofp, ofe, str);
3199
3200 dcl ofp ptr,
3201 ofe fixed bin (24),
3202 str char (*);
3203
3204 dcl output char (ofe) based (ofp);
3205 dcl tofe fixed bin (24);
3206
3207 tofe = ofe + 1;
3208 ofe = ofe + length (str);
3209 substr (output, tofe, length (str)) = str;
3210 if dt_sw & db_sw
3211 then call ioa_ ("^i,^i `^va'", tofe, length (str), length (str), str);
3212
3213 end putout;
3214
3215
3216
3217
3218
3219 protected: proc (ifp, ifi, ife, ofp, ofe);
3220
3221 dcl ifp ptr,
3222 ifi fixed bin (24),
3223 ife fixed bin (24),
3224 ofp ptr,
3225 ofe fixed bin (24);
3226 dcl begl fixed bin (24);
3227 dcl inputa (ife) char (1) based (ifp);
3228 dcl input char (ife) based (ifp);
3229 dcl output char (ofe) based (ofp);
3230 dcl (i, j, ii, jj) fixed bin (24);
3231 dcl loc (24) fixed bin (24);
3232 dcl sep_ct fixed bin (24);
3233 dcl argstrl fixed bin (24);
3234
3235
3236
3237 begl = ifi;
3238 ifi = ifi + 2;
3239 do while ("1"b);
3240 i = index (substr (input, ifi), "&""") -1;
3241 if (i < 0)
3242 then do;
3243 msg = "&""";
3244 call error_missing ("""", begl, ife);
3245 end;
3246 call putout (ofp, ofe, substr (input, ifi, i));
3247 ifi = ifi + i + 2;
3248 if (substr (input, ifi, 2) ^= "&""")
3249 then return;
3250 call putout (ofp, ofe, "&""");
3251 ifi = ifi + 2;
3252 end;
3253 end protected; %page;
3254
3255
3256
3257
3258 show_string: proc (str1, str2);
3259
3260 dcl (str1, str2) char (*);
3261 dcl (i, j, k) fixed bin (24);
3262 dcl HT_sw bit (1);
3263
3264 i = 1;
3265 do while (i <= length (str1));
3266 j = index (substr (str1, i), NL);
3267 if (j = 0)
3268 then do;
3269 j = length (str1) - i + 1;
3270 HT_sw = "0"b;
3271 end;
3272 else HT_sw = "1"b;
3273 k = i + j;
3274 call ioa_$nnl ("^a^[^-^]", substr (str1, i, j), HT_sw);
3275 i = k;
3276 end;
3277 call ioa_$nnl ("^a", str2);
3278
3279 end show_string; %page;
3280
3281
3282
3283
3284 strip2: proc (ifp, ifi, ife);
3285
3286 ifi = ifi + 2;
3287
3288 strip: entry (ifp, ifi, ife);
3289
3290 dcl ifp ptr,
3291 ifi fixed bin (24),
3292 ife fixed bin (24);
3293 dcl input char (ife) based (ifp);
3294
3295 dcl i fixed bin (24);
3296
3297 loop:
3298 i = verify (substr (input, ifi), space);
3299 if (i = 0)
3300 then ifi = ife + 1;
3301 else ifi = ifi + i - 1;
3302 if (substr (input, ifi, 1) ^= "&")
3303 then return;
3304 i = verify (substr (input, ifi + 1), token_chars);
3305 if (substr (input, ifi + 1, i) ^= "comment")
3306 then return;
3307 i = index (substr (input, ifi), "&;");
3308 if (i = 0)
3309 then do;
3310 msg = "&;";
3311 call error_missing ("comment", ifi, ifi + 8);
3312 end;
3313 ifi = ifi + i + 1;
3314 goto loop;
3315
3316 end strip2; %page;
3317
3318
3319
3320
3321 var_bound: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;
3322
3323 dcl ifp ptr,
3324 ifi fixed bin (24),
3325 ife fixed bin (24),
3326 ofp ptr,
3327 ofe fixed bin (24),
3328 TF bit (2);
3329 dcl begl fixed bin (24);
3330 dcl inputa (ife) char (1) based (ifp);
3331 dcl input char (ife) based (ifp);
3332 dcl output char (ofe) based (ofp);
3333 dcl (i, j, ii, jj) fixed bin (24);
3334 dcl loc (24) fixed bin (24);
3335 dcl (sep_ct, level) fixed bin (24);
3336 dcl argstrl fixed bin (24);
3337 dcl vname char (32) var;
3338
3339 xxx
3340 xxx
3341 ii = ofe;
3342 call strip (ifp, ifi, ife);
3343 loop:
3344 i = index (substr (input, ifi), "&") -1;
3345 if (i < 0)
3346 then do;
3347 msg = "Missing terminator on &";
3348 msg = msg || c32;
3349 msg = msg || ". ";
3350 goto add_identification;
3351 end;
3352 if (i > 0)
3353 then do;
3354 call putout (ofp, ofe, substr (input, ifi, i));
3355 ifi = ifi + i;
3356 end;
3357 if (substr (input, ifi, 2) ^= "&;")
3358 then do;
3359 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
3360 goto loop;
3361 end;
3362 vname = substr (output, ii + 1, ofe - ii);
3363 ofe = ii;
3364 j = lookup (vname);
3365 if (j = 0)
3366 then do;
3367 msg = "Attempt to reference undeclared variable """;
3368 msg = msg || vname;
3369 msg = msg || """. ";
3370 goto add_identification;
3371 end;
3372 if (var.type = 0)
3373 then do;
3374 msg = "Attempt to get ";
3375 msg = msg || c32;
3376 msg = msg || " of a scalar. ";
3377 goto add_identification;
3378 end;
3379 arr_ptr = var.ref;
3380 if (var.type = 1)
3381 | (var.type = 2)
3382 | (var.type = 3)
3383 then do;
3384 if (c32 = "lbound")
3385 then i = array.l_bound;
3386 else i = array.h_bound;
3387 end;
3388 if (var.type = 4)
3389 | (var.type = 5)
3390 then do;
3391 msg = "Cannot get ";
3392 msg = msg || c32;
3393 msg = msg || " of ";
3394 if (var.type = 5)
3395 then msg = msg || "l";
3396 else msg = msg || "f";
3397 msg = msg || "ifo.";
3398 goto add_identification;
3399 end;
3400 end var_bound; %page;
3401
3402
3403
3404
3405 var_range: proc (ifp, ifi, ife, ofp, ofe, TF);
3406
3407 dcl ifp ptr,
3408 ifi fixed bin (24),
3409 ife fixed bin (24),
3410 ofp ptr,
3411 ofe fixed bin (24),
3412 TF bit (2);
3413 dcl begl fixed bin (24);
3414 dcl inputa (ife) char (1) based (ifp);
3415 dcl input char (ife) based (ifp);
3416 dcl output char (ofe) based (ofp);
3417 dcl (i, j, ii, jj) fixed bin (24);
3418 dcl separator char (150) var;
3419 dcl vptr ptr;
3420 dcl limit fixed bin;
3421
3422
3423
3424
3425
3426
3427
3428 begl = ifi;
3429 ii = ofe;
3430 i = lookup (c32);
3431 if (i = 0)
3432 then do;
3433 msg = "Attempt to reference undeclared array. ";
3434 goto add_identification;
3435 end;
3436 if (var.type = 0)
3437 then do;
3438 msg = "Attempt to make non-scalar ref to scalar variable """;
3439 msg = msg || c32;
3440 msg = msg || """. ";
3441 goto add_identification;
3442 end;
3443 vptr = var_ptr;
3444 arr_ptr = var.ref;
3445 i = array.l_bound;
3446 j = array.h_bound;
3447 ifi = ifi - 2;
3448 call get_range (ifp, ifi, ife, ofp, ofe, TF, i, j);
3449 var_ptr = vptr;
3450 arr_ptr = var.ref;
3451 if (TF ^= "00"b)
3452 then do;
3453 if (var.type = 4)
3454 | (var.type = 5)
3455 then do;
3456 if (i ^= j)
3457 then do;
3458 msg = "Attempt to make multiple ref to stack """;
3459 msg = msg || c32;
3460 msg = msg || """. ";
3461 goto add_identification;
3462 end;
3463 if (i > 0)
3464 then do;
3465 msg = "Attempt to ref positive stack element """;
3466 msg = msg || c32;
3467 msg = msg || """. ";
3468 goto add_identification;
3469 end;
3470 if (var.type = 4)
3471 then do;
3472 i, j = array.l_bound - i;
3473 if (i > array.h_bound)
3474 then do;
3475 msg = "Attempt to ref non-existant stack element in """;
3476 msg = msg || c32;
3477 msg = msg || """. ";
3478 goto add_identification;
3479 end;
3480 end;
3481 else do;
3482 i, j = array.h_bound + i;
3483 if (i < array.l_bound)
3484 then do;
3485 msg = "Attempt to ref non-existant stack element in """;
3486 msg = msg || c32;
3487 msg = msg || """. ";
3488 goto add_identification;
3489 end;
3490 end;
3491 end;
3492 else do;
3493 if (i < array.l_bound)
3494 then do;
3495 msg = "Attempt to reference below lower bound. ";
3496 goto add_identification;
3497 end;
3498 if (j > array.h_bound)
3499 then do;
3500 msg = "Attempt to reference above upper bound. ";
3501 goto add_identification;
3502 end;
3503 end;
3504 end;
3505 separator = " ";
3506 if (inputa (ifi) = ",")
3507 then do;
3508 ifi = ifi + 1;
3509 do while ("1"b);
3510 jj = search (substr (input, ifi), "&}") -1;
3511 if (jj < 0)
3512 then do;
3513 msg = "}";
3514 call error_missing ("xxx{", begl, ife);
3515 end;
3516 if (jj > 0)
3517 then do;
3518 call putout (ofp, ofe, substr (input, ifi, jj));
3519 ifi = ifi + jj;
3520 end;
3521 if (inputa (ifi) = "}")
3522 then do;
3523 separator = substr (output, ii + 1, ofe - ii);
3524 ofe = ii;
3525 goto end_range;
3526 end;
3527 call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
3528 end;
3529 end;
3530 if (inputa (ifi) = "}")
3531 then do;
3532 end_range:
3533 ifi = ifi + 1;
3534 if (TF = "00"b)
3535 then return;
3536 var_ptr = vptr;
3537 arr_ptr = var.ref;
3538 limit = j - array.lower + 1;
3539 do arr_elem = i - array.lower + 1 to limit;
3540 call putout (ofp, ofe, arrtext);
3541 if (arr_elem ^= limit)
3542 then call putout (ofp, ofe, (separator));
3543 end;
3544 end;
3545 else do;
3546 msg = "&var{ ... }";
3547 goto syntax_err;
3548 end;
3549 end var_range; %page;
3550
3551
3552
3553
3554 var_ref: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;
3555
3556 dcl ifp ptr,
3557 ifi fixed bin (24),
3558 ife fixed bin (24),
3559 ofp ptr,
3560 ofe fixed bin (24),
3561 TF bit (2);
3562 dcl begl fixed bin (24);
3563 dcl inputa (ife) char (1) based (ifp);
3564 dcl input char (ife) based (ifp);
3565 dcl output char (ofe) based (ofp);
3566 dcl (i, j, ii, jj) fixed bin (24);
3567 dcl loc (24) fixed bin (24);
3568 dcl (sep_ct, level) fixed bin (24);
3569 dcl argstrl fixed bin (24);
3570
3571 xxx xxx
3572 if (TF = "00"b)
3573 then return;
3574 begl = ifi;
3575 j = lookup (c32);
3576 if (j = 0)
3577 then do;
3578 msg = "Attempt to reference undeclared variable """;
3579 msg = msg || c32;
3580 msg = msg || """. ";
3581 goto add_identification;
3582 end;
3583 if (var.type = 0)
3584 then do;
3585 if (c32 = watchword)
3586 then call ioa_ ("^a ^i ""^va""", watchword, var.len, var.len,
3587 vartext);
3588 call putout (ofp, out_len, vartext);
3589 end;
3590 else do;
3591 arr_ptr = var.ref;
3592 if (var.type = 4)
3593 then do;
3594 if (array.l_bound > array.h_bound)
3595 then do;
3596 msg = "Attempt to reference empty fifo """;
3597 msg = msg || c32;
3598 msg = msg || """. ";
3599 goto add_identification;
3600 end;
3601 arr_elem = mod (array.l_bound, var.len) + 1;
3602 if (c32 = watchword)
3603 then call ioa_ ("^a{^i} ^i ""^va""", watchword, arr_elem,
3604 array.len (arr_elem), array.len (arr_elem), arrtext);
3605 call putout (ofp, out_len, arrtext);
3606 array.l_bound = array.l_bound + 1;
3607 if al_sw
3608 then call ioa_ ("F ^a{^i} ^i ^p", c32, arr_elem,
3609 array.len (arr_elem), array.ref (arr_elem));
3610 free arrtext in (free_area);
3611 end;
3612 else if (var.type = 5)
3613 then do;
3614 if (array.l_bound > array.h_bound)
3615 then do;
3616 msg = "Attempt to reference empty lifo """;
3617 msg = msg || c32;
3618 msg = msg || """. ";
3619 goto add_identification;
3620 end;
3621 arr_elem = array.h_bound;
3622 if (c32 = watchword)
3623 then call ioa_ ("^a{^i} ^i ""^va""", watchword, arr_elem,
3624 array.len (arr_elem), array.len (arr_elem), arrtext);
3625 call putout (ofp, out_len, arrtext);
3626 array.h_bound = array.h_bound - 1;
3627 if al_sw
3628 then call ioa_ ("F ^a{^i} ^i ^p", c32, arr_elem,
3629 array.len (arr_elem), array.ref (arr_elem));
3630 free arrtext in (free_area);
3631 end;
3632 else do;
3633 msg = "Attempt to make scalar reference to non-scalar """;
3634 msg = msg || c32;
3635 msg = msg || """. ";
3636 goto add_identification;
3637 end;
3638 end;
3639 end var_ref; %page;
3640
3641
3642
3643
3644 dcl ref_path char (168);
3645 free: entry (pr_sw);
3646
3647 dcl pr_sw bit (1);
3648
3649 dcl define_area_ entry (ptr, fixed bin (35));
3650 dcl release_area_ entry (ptr);
3651
3652 if free_area_p ^= null ()
3653 then do;
3654 tptr = ext_var_ptr;
3655 call free_um ("ext");
3656 ext_var_ptr = null ();
3657 do while (int_vars_base ^= null ());
3658 int_var_ptr = int_vars_base;
3659 if db_sw
3660 then call ioa_ ("^p^-macro ^a", int_var_ptr, int_vars.macro);
3661 int_vars_base = int_vars.next;
3662 tptr = int_vars.ref;
3663 call free_um ("int");
3664 if al_sw then call ioa_ ("F int_vars ^p", int_var_ptr);
3665 free int_vars in (free_area);
3666 end;
3667 tptr = macro_list_p;
3668 if (tptr ^= null ()) & pr_sw
3669 then call ioa_ ("^aS USED:", who_am_i);
3670 do while (tptr ^= null ());
3671 maclp = tptr;
3672 if pr_sw & (macro_list.dname ^= "")
3673 then do;
3674 call ioa_ ("^i:^i ^a>^a
3675 macro_list.to, macro_list.dname,
3676 macro_list.ename, macro_list.name);
3677 end;
3678 tptr = macro_list.next;
3679 macro_holder_p = macro_list.ref;
3680 if (substr (macro_list.dname, 1, 4) = " &")
3681 then do;
3682 macro_holder_l = macro_list.to;
3683 if al_sw
3684 then call ioa_ ("F macro_holder ^p", macro_holder_p);
3685 free macro_holder in (free_area);
3686 end;
3687 if al_sw then call ioa_ ("F macro_list ^p", maclp);
3688 free macro_list in (free_area);
3689 end;
3690 call release_area_ (free_area_p);
3691 free_area_p = null ();
3692 end;
3693 macro_list_p = null ();
3694 err_ct (*) = 0;
3695 macro_nest = 0;
3696 return;
3697
3698 dcl dname char (168);
3699 dcl ename char (32);
3700 dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (24), char (*), fixed bin (35));
3701
3702
3703
3704
3705
3706 dcl al_sw bit (1) int static init ("0"b);
3707 dcl db_sw bit (1) int static init ("0"b);
3708 dcl dt_sw bit (1) int static init ("0"b);
3709 dcl end_sym char (8) var;
3710 dcl err_ct (0:4) fixed bin int static init ((5) 0);
3711 dcl ext_var_ptr ptr int static init (null ());
3712 dcl free_area_p ptr int static init (null ());
3713 dcl int_vars_base ptr int static init (null ());
3714 dcl lg_sw bit (1) int static init ("0"b);
3715 dcl macro_list_p ptr int static init (null ());
3716 dcl macro_nest fixed bin int static init (0);
3717 dcl pc_sw bit (1) int static init ("0"b);
3718 dcl watchword char (32) int static init ("");
3719 dcl who_am_i char (12) var int static;
3720
3721
3722
3723 dcl NL char (1) int static options (constant) init ("
3724 ");
3725 dcl space char (5) int static options (constant) init ("
3726 ^K^L");
3727
3728
3729
3730 dcl var_ptr ptr;
3731 dcl 1 var based (var_ptr),
3732 2 next ptr,
3733 2 name char (16),
3734 2 type fixed bin,
3735
3736 2 len fixed bin,
3737 2 ref ptr;
3738 dcl vartext char (var.len) based (var.ref);
3739
3740
3741 dcl arr_ptr ptr;
3742 dcl 1 array based (arr_ptr),
3743 2 lower fixed bin,
3744 2 l_bound fixed bin,
3745 2 h_bound fixed bin,
3746 2 elem (var.len),
3747 3 len fixed bin,
3748 3 ref ptr unal;
3749 dcl arrtext char (array.len (arr_elem)) based (array.ref (arr_elem));
3750 dcl arr_elem fixed bin (24);
3751
3752 dcl int_var_ptr ptr;
3753 dcl 1 int_vars based (int_var_ptr),
3754 2 next ptr unal,
3755 2 ref ptr unal,
3756 2 macro char (32);
3757
3758 dcl maclp ptr;
3759 dcl 1 macro_list based (maclp),
3760 2 next ptr,
3761 2 ref ptr,
3762 2 dname char (168),
3763 2 ename char (32),
3764 2 from fixed bin (24),
3765 2 to fixed bin (24),
3766 2 name char (32),
3767 2 int_mac bit (1);
3768
3769
3770
3771 dcl argleng_less_than_zero condition;
3772 dcl bc fixed bin (24);
3773 dcl c32 char (32) var;
3774 dcl c32x char (32) var;
3775 dcl call_err bit (1);
3776 dcl ch_2nd char (1);
3777 dcl construct_nest fixed bin (24);
3778 dcl free_area area based (free_area_p);
3779 dcl i fixed bin (24);
3780 dcl jaf fixed bin (24);
3781 dcl local_var_ptr ptr;
3782 dcl macro_holder char (macro_holder_l) based (macro_holder_p);
3783 dcl macro_holder_l fixed bin (24);
3784 dcl macro_holder_p ptr;
3785 dcl msg_etc char (1000) var;
3786 dcl myname char (32) var;
3787 dcl output char (ofe) based (out_ptr);
3788 dcl save_db bit (1);
3789 dcl seg char (sege) based (segptr);
3790 dcl sega (sege) char (1) based (segptr);
3791 dcl sege fixed bin (24);
3792 dcl segi fixed bin (24);
3793 dcl segii fixed bin (24);
3794 dcl segment char (sege) based (segptr);
3795 dcl segptr ptr;
3796 dcl segtype char (8) var;
3797 dcl start_sym char (8) var;
3798 dcl tptr ptr;
3799 dcl token_chars char (63) int static options (constant) init (
3800 "abcdefghijklmnopqrstuvwxyz" ||
3801 "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
3802 dcl tr_sw bit (1);
3803
3804 dcl error_table_$action_not_performed fixed bin (35) ext static;
3805 dcl error_table_$archive_fmt_err fixed bin (35) ext static;
3806 dcl error_table_$badsyntax fixed bin (35) ext static;
3807 dcl error_table_$new_search_list fixed bin (35) ext static;
3808 dcl error_table_$no_search_list fixed bin (35) ext static;
3809 dcl error_table_$translation_aborted fixed bin (35) ext static;
3810 dcl error_table_$translation_failed fixed bin (35) ext static;
3811
3812 dcl ioa_ entry options (variable);
3813 dcl com_err_ entry options (variable);
3814 dcl archive_util_$first_element entry (ptr, fixed bin (35));
3815 dcl archive_util_$search entry (ptr, ptr, char (32), fixed bin (35));
3816 dcl ioa_$nnl entry options (variable);
3817 dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
3818 dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
3819 dcl hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35));
3820 dcl get_seg_ptr_ entry (char (*), bit (6), fixed bin (24), ptr, fixed bin (35));
3821 dcl mac_sw bit (1);
3822
3823 dcl (addr, addrel, char, convert, divide, fixed, hbound, index, length, ltrim,
3824 max, min, mod, null, reverse, rtrim, search, size, string, substr,
3825 translate, verify) builtin;
3826 dbn: entry; db_sw = "1"b; return;
3827 dtn: entry; dt_sw = "1"b; return;
3828 aln: entry; al_sw = "1"b; return;
3829 pcn: entry; pc_sw = "1"b; return;
3830 lgn: entry; lg_sw = "1"b; return;
3831 lgf: entry; lg_sw = "0"b; return;
3832 pcf: entry; pc_sw = "0"b; return;
3833 alf: entry; al_sw = "0"b; return;
3834 dtf: entry; dt_sw = "0"b; return;
3835 dbf: entry; db_sw = "0"b; return;
3836
3837 watch: entry (watchfor);
3838 dcl watchfor char (*);
3839
3840 watchword = watchfor;
3841 return;
3842
3843 end;