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