1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   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                                         /** FUTURE &fileout name ... &filend */
  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,      /* search  list name                 */
  44     segname         char (32) var,      /* name of segment to find           */
  45                                         /* "" -> not specified               */
  46     macname         char (32) var,      /* name of macro to expand           */
  47                                         /* "" -> expanding a string          */
  48     out_ptr         ptr,                /* output string (not aligned)       */
  49     out_len         fixed bin (24),     /* length of output produced (Out)   */
  50     arglp           ptr,                /* pointer to argument list          */
  51     argct           fixed bin,          /* number of arguments               */
  52     msg             char (1000) var,    /* error message text                */
  53     refseg          ptr,                /* pointer to referencing segment    */
  54     strptr          ptr,                /* pointer to string to expand       */
  55     strlen          fixed bin (24),     /* length of string to expand        */
  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 /* name = "macro" | "foo$foo" | "foo$bar"                                    */
  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;              /* didn't find an imbedded macro by  */
 119          end;                           /*  this name, try for macro$macro.  */
 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 /* add a macro to the list of known macros                                   */
 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),            /* 1- is &macro/&define              */
 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 /* An ampersand has been found, handle it.                                   */
 280 
 281 ampersand: proc (ifp, ifi, ife, ofp, ofe, TF, err_sw) recursive;
 282 
 283 dcl ifp             ptr,                /* pointer to input                  */
 284     ifi             fixed bin (24),     /* first char of input to use        */
 285     ife             fixed bin (24),     /* last char of input to use         */
 286     ofp             ptr,                /* pointer to output                 */
 287     ofe             fixed bin (24),     /* last char of output used          */
 288     TF              bit (2),
 289     err_sw          bit (1);            /* 0- misplaced are error            */
 290                                         /* 1- misplaced no sweat             */
 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 = ".")         /* &. null separator                 */
 331          then ifi = ifi + 2;
 332 
 333          else if (ch_2nd = "+")         /* &+ null separator,                */
 334          then call strip2 (ifp, ifi, ife); /*  grabs trailing space          */
 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;           /* error                             */
 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 /* arg */
 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), "&macro ") ^= 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 /* parse an argument range specification.                                    */
 557 
 558 arg_range: proc (ifp, ifi, ife, ofp, ofe, TF);
 559 
 560 dcl ifp             ptr,                /* pointer to input                  */
 561     ifi             fixed bin (24),     /* first char of input to use        */
 562     ife             fixed bin (24),     /* last char of input to use         */
 563     ofp             ptr,                /* pointer to output                 */
 564     ofe             fixed bin (24),     /* last char of output used          */
 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 /* &{ ARITH }                           yields argument ARITH                */
 574 /* &{ ARITH : ARITH }                   yields arguments ARITH thru ARITH    */
 575 /*                                          separated by a SP                */
 576 /* &{ ARITH : ARITH , STRING }          yields arguments ARITH thru ARITH    */
 577 /*                                          separated by STRING              */
 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 /* process an arithmetic expression.                                         */
 630 
 631 arithmetic: proc (ifp, ifi, ife, ofp, ofe, TF);
 632 
 633 dcl ifp             ptr,                /* pointer to input                  */
 634     ifi             fixed bin (24),     /* first char of input to use        */
 635     ife             fixed bin (24),     /* last char of input to use         */
 636     ofp             ptr,                /* pointer to output                 */
 637     ofe             fixed bin (24),     /* last char of output used          */
 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);               /* It stops scan, but is not used up */
 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;                    /* don't want to use up this char    */
 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                                         /* format: off */
 715 /*                                       "---------1111111111222222   22 2   */
 716 /*                                       "---------0123456789012345   67 8   */
 717 dcl arithchar char (28) int static init ("0123456789(=^=<=>=+-*/)     .""
 718 "); /* format: on */
 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):                              /* decimal point */
 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):                              /* quoted string not handled yet     */
 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):                              /* SP */ /* */
 903 type (25):                              /* HT */ /* */
 904 type (28):                              /* NL */ /* */
 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 /* convert a text string for debug display.                                  */
 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 /* show a bunch of debugging information.                                    */
 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 /* ERROR MESSAGE procs                                                       */
 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 /* expand a specified string                                                 */
1025 
1026 expand: proc (ifp, ifi, ife, ofp, ofe, tf);
1027 
1028 dcl ifp             ptr,                /* pointer to input                  */
1029     ifi             fixed bin (24),     /* first char of input to use        */
1030     ife             fixed bin (24),     /* last char of input to use         */
1031     ofp             ptr,                /* pointer to output                 */
1032     ofe             fixed bin (24),     /* last char of output used          */
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 /* search for the macro specified                                            */
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); /* fudge a little */
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, "&macro " || 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;            /* &expand 1 char>than &macro        */
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 /* now all that is fine and dandy, but we don't want to let &b() find an     */
1156 /* external b$b because nothing has been internally defined and then later   */
1157 /* have the same thing find a different macro because there now has been an  */
1158 /* internal macro/define encountered. So we dummy up a pseudo-internal entry */
1159 /* to nip such a thing in the bud.                                           */
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 /* free all the storage used                                                 */
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 /* set up an area                                                            */
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 /* parse an array range specification.                                       */
1238 
1239 get_range: proc (ifp, ifi, ife, ofp, ofe, TF, i, j);
1240 
1241 dcl ifp             ptr,                /* pointer to input                  */
1242     ifi             fixed bin (24),     /* first char of input to use        */
1243     ife             fixed bin (24),     /* last char of input to use         */
1244     ofp             ptr,                /* pointer to output                 */
1245     ofe             fixed bin (24),     /* last char of output used          */
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 /* parse the next input token                                                */
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 /* determine and format the line number of a given point in a segment        */
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 /* process a logical expression                                              */
1328 
1329 logical: proc (ifp, ifi, ife, ofp, ofe, TF);
1330 
1331 dcl ifp             ptr,                /* pointer to input                  */
1332     ifi             fixed bin (24),     /* first char of input to use        */
1333     ife             fixed bin (24),     /* last char of input to use         */
1334     ofp             ptr,                /* pointer to output                 */
1335     ofe             fixed bin (24),     /* last char of output used          */
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                                         /* 2 =    4 ^=                       */
1412                                         /* 5 <    6 <=                       */
1413                                         /* 7 >    8 >=                       */
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 /* look up a specified name in the variable lists                            */
1490 
1491 lookup: proc (vname) returns (fixed bin) recursive;
1492 
1493 dcl vname           char (32) var;
1494 
1495 /* first look up local variables                                             */
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 /* then look up internal static variables                                    */
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 /* then look up external static variables */
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 /* handle the active function call                                           */
1546 
1547 macro_af: proc (ifp, ifi, ife, ofp, ofe, TF);
1548 
1549 dcl ifp             ptr,                /* pointer to input                  */
1550     ifi             fixed bin (24),     /* first char of input to use        */
1551     ife             fixed bin (24),     /* last char of input to use         */
1552     ofp             ptr,                /* pointer to output                 */
1553     ofe             fixed bin (24),     /* last char of output used          */
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 /* handle a macro call                                                       */
1639 
1640 macro_call: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;
1641 
1642 dcl ifp             ptr,                /* pointer to input                  */
1643     ifi             fixed bin (24),     /* first char of input to use        */
1644     ife             fixed bin (24),     /* last char of input to use         */
1645     ofp             ptr,                /* pointer to output                 */
1646     ofe             fixed bin (24),     /* last char of output used          */
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$yy( ... , ... , ...) */
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 /* dynamically define a macro                                                */
1770 
1771 macro_define: proc (ifp, ifi, ife, ofp, ofe, TF);
1772 
1773 dcl ifp             ptr,                /* pointer to input                  */
1774     ifi             fixed bin (24),     /* first char of input to use        */
1775     ife             fixed bin (24),     /* last char of input to use         */
1776     ofp             ptr,                /* pointer to output                 */
1777     ofe             fixed bin (24),     /* last char of output used          */
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 /* &define ... &dend */
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 /* handle the iteration construct                                            */
1858 
1859 macro_do: proc (ifp, ifi, ife, ofp, ofe, TF);
1860 
1861 dcl ifp             ptr,                /* pointer to input                  */
1862     ifi             fixed bin (24),     /* first char of input to use        */
1863     ife             fixed bin (24),     /* last char of input to use         */
1864     ofp             ptr,                /* pointer to output                 */
1865     ofe             fixed bin (24),     /* last char of output used          */
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 /* &do EXPAND &while LOGICAL &; EXPAND &od */
1875 /* LOGICAL ::= arithmetic | compare */
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 /* make a list or array var be empty again                                   */
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 /* &empty name &; */
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                                         /* free any allocated strings */
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 /* print a user specified error message                                      */
2024 
2025 macro_error: proc (ifp, ifi, ife, ofp, ofe, TF);
2026 
2027 dcl ifp             ptr,                /* pointer to input                  */
2028     ifi             fixed bin (24),     /* first char of input to use        */
2029     ife             fixed bin (24),     /* last char of input to use         */
2030     ofp             ptr,                /* pointer to output                 */
2031     ofe             fixed bin (24),     /* last char of output used          */
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 "-------9";
2042 
2043 /* &error ARITH , ... &; */
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 /* handle the "if then [elseif] ... [else] fi" construct                     */
2128 
2129 macro_if: proc (ifp, ifi, ife, ofp, ofe, tf);
2130 
2131 dcl ifp             ptr,                /* pointer to input                  */
2132     ifi             fixed bin (24),     /* first char of input to use        */
2133     ife             fixed bin (24),     /* last char of input to use         */
2134     ofp             ptr,                /* pointer to output                 */
2135     ofe             fixed bin (24),     /* last char of output used          */
2136     tf              bit (2);            /* 1x- process true                  */
2137                                         /* x1- process false                 */
2138                                         /* value not returned (modified)     */
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 /* &if LOGICAL &then EXPAND {&elseif EXPAND} ... {&else EXPAND} &fi */
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 /* return the length of a string                                             */
2258 
2259 macro_length: proc (ifp, ifi, ife, ofp, ofe, TF);
2260 
2261 dcl ifp             ptr,                /* pointer to input                  */
2262     ifi             fixed bin (24),     /* first char of input to use        */
2263     ife             fixed bin (24),     /* last char of input to use         */
2264     ofp             ptr,                /* pointer to output                 */
2265     ofe             fixed bin (24),     /* last char of output used          */
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 /* &length ... &; */
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 /* process loc/int/ext/let statements (they look very much alike             */
2311 
2312 macro_let: proc (ifp, ifi, ife, ofp, ofe, TF, which) recursive;
2313 
2314 dcl ifp             ptr,                /* pointer to input                  */
2315     ifi             fixed bin (24),     /* first char of input to use        */
2316     ife             fixed bin (24),     /* last char of input to use         */
2317     ofp             ptr,                /* pointer to output                 */
2318     ofe             fixed bin (24),     /* last char of output used          */
2319     TF              bit (2),
2320     which           fixed bin (24);     /* 0-let, 1-ext, 2-int, 3-loc */
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 /* &let var = EXPR &;
2332    &ext var = EXPR &;
2333    &ext var &;
2334    &int var = EXPR &;
2335    &int var &;
2336    &loc var = EXPR &;
2337    &loc var &; */
2338 /* EXPR ::= arithmetic | string */
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)                 /*  not let */
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)              /*  fifo */
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 /* double any quotes in a string                                             */
2783 
2784 macro_quote: proc (ifp, ifi, ife, ofp, ofe, tf);
2785 
2786 dcl ifp             ptr,                /* pointer to input                  */
2787     ifi             fixed bin (24),     /* first char of input to use        */
2788     ife             fixed bin (24),     /* last char of input to use         */
2789     ofp             ptr,                /* pointer to output                 */
2790     ofe             fixed bin (24),     /* last char of output used          */
2791     tf              bit (2);            /* 1x- process true                  */
2792                                         /* x1- process false                 */
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 /* &quote ... &; */
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 &quote 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 /* rescan a result of macro expansion                                        */
2858 
2859 macro_scan: proc (ifp, ifi, ife, ofp, ofe, TF);
2860 
2861 dcl ifp             ptr,                /* pointer to input                  */
2862     ifi             fixed bin (24),     /* first char of input to use        */
2863     ife             fixed bin (24),     /* last char of input to use         */
2864     ofp             ptr,                /* pointer to output                 */
2865     ofe             fixed bin (24),     /* last char of output used          */
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 /* &scan ... &; */
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 /* return part of a string with needed padding                               */
2926 
2927 macro_substr: proc (ifp, ifi, ife, ofp, ofe, TF);
2928 
2929 dcl ifp             ptr,                /* pointer to input                  */
2930     ifi             fixed bin (24),     /* first char of input to use        */
2931     ife             fixed bin (24),     /* last char of input to use         */
2932     ofp             ptr,                /* pointer to output                 */
2933     ofe             fixed bin (24),     /* last char of output used          */
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 /* &substr ... , ARITH , ARITH &;
2945    &substr ... , ARITH &;
2946    &substr ... , ARITH : ARITH &; */
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 /* remove doubled quotes and surrounding quotes (if any) from a string       */
3059 
3060 macro_unquote: proc (ifp, ifi, ife, ofp, ofe, tf);
3061 
3062 dcl ifp             ptr,                /* pointer to input                  */
3063     ifi             fixed bin (24),     /* first char of input to use        */
3064     ife             fixed bin (24),     /* last char of input to use         */
3065     ofp             ptr,                /* pointer to output                 */
3066     ofe             fixed bin (24),     /* last char of output used          */
3067     tf              bit (2);            /* 1x- process true                  */
3068                                         /* x1- process false                 */
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 /* &unquote ... &; */
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 /* show the macros used up to this point                                     */
3132 
3133 macro_usage: proc (ifp, ifi, ife, ofp, ofe, TF);
3134 
3135 dcl ifp             ptr,                /* pointer to input                  */
3136     ifi             fixed bin (24),     /* first char of input to use        */
3137     ife             fixed bin (24),     /* last char of input to use         */
3138     ofp             ptr,                /* pointer to output                 */
3139     ofe             fixed bin (24),     /* last char of output used          */
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 /* &usage string &; */
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 /* put a string into the output, making sure the length is updated before    */
3196 /*  placing the data therein.                                                */
3197 
3198 putout: proc (ofp, ofe, str);
3199 
3200 dcl ofp             ptr,                /* points to receiver           (IN) */
3201     ofe             fixed bin (24),     /* length of receiver          (OUT) */
3202     str             char (*);           /* string to insert             (IN) */
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 /* process a protected string                                                */
3218 
3219 protected: proc (ifp, ifi, ife, ofp, ofe);
3220 
3221 dcl ifp             ptr,                /* pointer to input                  */
3222     ifi             fixed bin (24),     /* first char of input to use        */
3223     ife             fixed bin (24),     /* last char of input to use         */
3224     ofp             ptr,                /* pointer to output                 */
3225     ofe             fixed bin (24);     /* last char of output used          */
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 /* scan a string and print it indenting 1 HT.                                */
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 /* skip over whitespace. strip2 moves ahead 2 first                          */
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;                        /* keep on stripping                 */
3315 
3316    end strip2; %page;
3317 /*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
3318 /*                                                                           */
3319 /* return the lbound/hbound of an array                                      */
3320 
3321 var_bound: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;
3322 
3323 dcl ifp             ptr,                /* pointer to input                  */
3324     ifi             fixed bin (24),     /* first char of input to use        */
3325     ife             fixed bin (24),     /* last char of input to use         */
3326     ofp             ptr,                /* pointer to output                 */
3327     ofe             fixed bin (24),     /* last char of output used          */
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 /* &lbound xxx&;
3340    &hbound 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)                 /* array                             */
3381          | (var.type = 2)               /* array var                         */
3382          | (var.type = 3)               /* list                              */
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)                 /* fifo                              */
3389          | (var.type = 5)               /* lifo                              */
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,                /* pointer to input                  */
3408     ifi             fixed bin (24),     /* first char of input to use        */
3409     ife             fixed bin (24),     /* last char of input to use         */
3410     ofp             ptr,                /* pointer to output                 */
3411     ofe             fixed bin (24),     /* last char of output used          */
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 /* &var{ ARITH }                        yields argument ARITH                */
3423 /* &var{ ARITH : ARITH }                yields arguments ARITH thru ARITH    */
3424 /*                                            separated by a SP              */
3425 /* &var{ ARITH : ARITH , STRING }       yields arguments ARITH thru ARITH    */
3426 /*                                            separated by STRING            */
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 /* reference a variable                                                      */
3553 
3554 var_ref: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;
3555 
3556 dcl ifp             ptr,                /* pointer to input                  */
3557     ifi             fixed bin (24),     /* first char of input to use        */
3558     ife             fixed bin (24),     /* last char of input to use         */
3559     ofp             ptr,                /* pointer to output                 */
3560     ofe             fixed bin (24),     /* last char of output used          */
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 can be SCALAR, FIFI, or LIFO */
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 /* EXTERNAL entry to cleanup the processing environment                      */
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 -- (^a.macro)", macro_list.from,
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 /* * * * * * * * * * * * * * INTERNAL STATIC DATA  * * * * * * * * * * * * * */
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 /* * * * * * * * * * * * * * * *  CONSTANTS  * * * * * * * * * * * * * * * * */
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 /* * * * * * * * * * * * * * * *  STRUCTURES * * * * * * * * * * * * * * * * */
3729 
3730 dcl var_ptr         ptr;
3731 dcl 1 var           based (var_ptr),
3732       2 next        ptr,                /* next variable in list             */
3733       2 name        char (16),
3734       2 type        fixed bin,          /* 0-scalar  1-array   2-array var   */
3735                                         /* 3-list    4-fifo    5-lifo        */
3736       2 len         fixed bin,          /* length of data string             */
3737       2 ref         ptr;                /* points to data string             */
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,          /* defined lower bound               */
3745       2 h_bound     fixed bin,          /* defined higher bound              */
3746       2 elem        (var.len),
3747         3 len       fixed bin,          /* length of data string             */
3748         3 ref       ptr unal;           /* points to data string             */
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,           /* points to variable definition     */
3756       2 macro       char (32);          /* name of macro owning it           */
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);            /* 1- &macro/&define'ed              */
3768 
3769 /* * * * * * * * * * * * * LOOSE ARRAYS and SCALARS  * * * * * * * * * * * * */
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;