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 
  11 mexp: proc;
  12 
  13 /* This program is a simple macro expander for alm type programs. */
  14 
  15 
  16 dcl (char_count, next) fixed bin (21),
  17      bit_count fixed bin (24),
  18      code fixed bin (35),
  19      entry_no fixed bin (21),
  20      based_2_chars char (2) based,
  21      1 dummy_dcl based,
  22      2 pad char (3),
  23      2 fourth_char char (1),
  24      WHITE char (2) static init ("       "),
  25      TERM char (2) static init (";
  26 "),
  27      ENDS char (4) static init ("();
  28 "),
  29      WHITE_TERM char (4) static init ("  ;
  30 "),
  31     (last_macro, old_free) ptr,
  32     (i, j) fixed bin (21),
  33     (unique_generator, unique_generator1) fixed bin init (0),
  34      unique_changed bit (1) aligned init ("0"b),
  35      discard fixed bin,
  36      vc char (12) var,
  37      convert_binary_integer_$octal_string entry (fixed bin) returns (char (12) var),
  38      get_wdir_ entry () returns (char (168) aligned),
  39      convert_binary_integer_$decimal_string entry (fixed bin) returns (char (12) var),
  40      cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
  41      path char (168) aligned,
  42      dirname char (168),
  43      ename char (32),
  44      sname char (32) var,
  45     (ilp, outp, olp, mbp, bp (32)) ptr,
  46      c char (1) aligned,
  47      hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
  48      hcs_$fs_move_seg entry (ptr, ptr, fixed bin, fixed bin (35)),
  49     (addr, substr, ptr, unspec, index, divide, null, addrel, baseno, baseptr, length, min) builtin,
  50      expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
  51      com_err_ ext entry options (variable),
  52      find_include_file_$initiate_count entry (char (*), ptr, char (*) aligned, fixed bin (24), ptr, fixed bin (35)),
  53      hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin, ptr, fixed bin (35)),
  54      hcs_$delentry_seg entry (ptr, fixed bin (35)),
  55      line_no fixed bin,
  56     (nargs, arg_len) fixed bin,
  57     (no_exargs, no_ifargs) fixed bin,
  58      my_name char (4) aligned static init ("mexp"),
  59      cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
  60      cu_$arg_count entry returns (fixed bin),
  61      dirname_p char (168),
  62     (ename2, ename_p) char (32),
  63      arg char (arg_len) based (arg_ptr),
  64      input_arg (0: 9) char (32) var init ((10) (1)""),
  65      no_input_args fixed bin,
  66      targ char (128) var,
  67     (arg_ptr, fp) ptr,
  68      QUOTE char (1) aligned static init (""""),
  69      ol char (max_char_count) aligned based (olp),
  70      max_char_count fixed bin (21),
  71      sys_info$max_seg_size ext static fixed bin (35),
  72      hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
  73      hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)),
  74      hcs_$terminate_noname entry (ptr, fixed bin (35)),
  75      COMMA_NL char (2) static init (",
  76 "),
  77      NL char (1) static init ("
  78 "),
  79      TAB char (1) static init ("        ");
  80 dcl  type_NORMAL fixed bin static options (constant) init (1);
  81 dcl  type_PREV_UNIQUE fixed bin static options (constant) init (2);
  82 dcl  type_UNIQUE fixed bin static options (constant) init (3);
  83 dcl  type_NEXT_UNIQUE fixed bin static options (constant) init (4);
  84 dcl  type_ITERATE fixed bin static options (constant) init (5);
  85 dcl  type_OPEN fixed bin static options (constant) init (6);
  86 dcl  type_CLOSE fixed bin static options (constant) init (7);
  87 dcl  type_COMMAND_ARGNO fixed bin static options (constant) init (8);
  88 dcl  type_SPEC_UNIQUE fixed bin static options (constant) init (9);
  89 dcl  type_COMMAND_ARG fixed bin static options (constant) init (10);
  90 dcl  type_LENGTH fixed bin static options (constant) init (11);
  91 dcl  type_NARGS fixed bin static options (constant) init (12);
  92 dcl  type_NITER fixed bin static options (constant) init (13);
  93 dcl  type_ENDM fixed bin static options (constant) init (14);
  94 
  95 /* Based */
  96 
  97 
  98 
  99 /* ^L */
 100 
 101 /* Scan the argument(s) and create necessary buffers, etc. */
 102 
 103 
 104           max_char_count = sys_info$max_seg_size*4;
 105           nargs = cu_$arg_count ();                         /* get the number of arguments given */
 106           no_input_args = min (10, nargs-1);                /* get the number of additional arguments */
 107           if nargs < 1 then do;                             /* wrong usage, give correct */
 108 USAGE:         call com_err_ (0, (my_name), "Usage: mexp name (looks for name.mexp)");
 109                return;
 110           end;
 111 
 112           call cu_$arg_ptr (1, arg_ptr, arg_len, code);     /* get the arg */
 113           if code ^= 0 | arg_len = 0 then goto USAGE;
 114 
 115           call expand_path_ (arg_ptr, arg_len, addr (dirname), addr (ename), code);
 116           if code ^= 0 then goto USAGE;
 117 
 118           j = index (ename, " ");                           /* search for end of name, see if ends with ".mexp" */
 119           if j > 0 then if j < 27 then if substr (ename, j-5, 5) ^= ".mexp" then do;
 120                          substr (ename, j, 5) = ".mexp";    /* if doesn't end in ".mexp", make sure it does */
 121                          j = j + 5;
 122                     end;
 123           sname = substr (ename, 1, j-6);                   /* get primary component of name */
 124 
 125           call hcs_$initiate_count (dirname, ename, "", bit_count, 0, ilp, code); /* get pointer to source */
 126           if ilp = null then do;
 127                call com_err_ (code, (my_name), "^a>^a", dirname, ename);
 128                return;
 129           end;
 130 
 131           ename2 = sname || ".alm";                         /* get name of output segment */
 132 
 133           call hcs_$make_seg (get_wdir_ (), ename2, "", 01011b, outp, code);
 134           if outp = null then goto USAGE;
 135 
 136           char_count = divide (bit_count, 9, 17, 0);        /* get number of chars in source */
 137 
 138 /* Now create the two temporary segments needed */
 139 
 140           call hcs_$make_seg ("", "mexp.temp", "", 01011b, fp, code);
 141           if fp = null then goto USAGE;
 142           call hcs_$truncate_seg (fp, 0, code);
 143           if code ^= 0 then goto USAGE;
 144           call hcs_$make_seg ("", ename2, "", 01011b, olp, code);
 145           if olp = null then goto USAGE;
 146           call hcs_$make_seg ("", "macro_buffers.mexp", "", 01011b, mbp, code);
 147           if mbp = null then goto USAGE;
 148 
 149           do i = 2 to 32;
 150                bp (i) = addrel (mbp, (i-2)*1024);
 151           end;
 152 
 153           if nargs > 11 then call com_err_ (0, (my_name), "Only first 10 arguments will be accepted.");
 154           do i = 0 to no_input_args-1;
 155                call cu_$arg_ptr (i+2, arg_ptr, arg_len, code);
 156                if code ^= 0 then goto NOMOREARGS;
 157                input_arg (i) = arg;
 158           end;
 159 NOMOREARGS:
 160                                                             /* ^L */
 161 
 162 /* Now expand the input text.  This is done by expanding the data pointed to by
 163    bp (level) ... which is done by a (recursive) call to scan_buffer. */
 164 
 165 
 166           old_free = ptr (fp, 0);                           /* initialize pointer to macro table */
 167           last_macro = null;                                /* set up for reverse chain of macros */
 168           line_no = 0;                                      /* initialize line number counter */
 169           next = 1;                                         /* initialize output character index */
 170           if ilp -> based_2_chars = "%;" then ilp = addr (ilp -> dummy_dcl.fourth_char); /* BUG */
 171           bp (1) = ilp;                                     /* first buffer load is input text */
 172 
 173           call scan_buffer (1, char_count);                 /* this will do all the work */
 174 ERROR:
 175           call hcs_$fs_move_seg (olp, outp, 1, code);       /* copy the data into the segment */
 176           if code ^= 0 then do;                             /* some trouble */
 177                call com_err_ (code, (my_name), "Copying segment from process directory.");
 178                call com_err_ (0, (my_name), "Segment is in process directory with name ^a.", ename2);
 179                call hcs_$set_bc_seg (olp, (next-1)*9, code);
 180                if code ^= 0 then call com_err_ (code, (my_name), "Setting bit count on ^a.", ename2);
 181                return;
 182           end;
 183           call hcs_$set_bc_seg (outp, (next-1)*9, code);
 184           if code ^= 0 then call com_err_ (code, (my_name), "Setting bit count on ^a.", ename2);
 185           call hcs_$delentry_seg (olp, code);               /* delete the temp */
 186           call hcs_$delentry_seg (fp, code);
 187           call hcs_$delentry_seg (mbp, code);
 188           call hcs_$terminate_noname (ilp, code);
 189           call hcs_$terminate_noname (outp, code);
 190           return;
 191 
 192 /* ^L */
 193 
 194 /* SCAN_BUFFER   This is the main work program of mexp. It scans the text pointed to by
 195    bp (level) and places output into the output temporary. Any buffers
 196    which are used for macro expansion along the way are expanded and
 197    hence output into the output segment with a recursive call to SCAN_BUFFER */
 198 
 199 scan_buffer: proc (a_level, a_size);
 200 
 201 dcl (a_level, a_size) fixed bin (21);
 202 
 203 dcl (nparens, i, ci, start, stop, j, iterate, macro_len) fixed bin (21),
 204      found_number bit (1) aligned,
 205      si fixed bin (21),
 206      pfree ptr,
 207      save_free fixed bin (21),
 208      val fixed bin,
 209      filling_buffer bit (1),
 210      t fixed bin (21),
 211      type fixed bin,
 212     (nargs, level) fixed bin,
 213     (nchars, arg_start, len_op, start_name, len1, len, nextb, ia) fixed bin (21),
 214      ml char (macro_len) based (mp),
 215      ob char (max_char_count) based (obp),
 216      il char (nchars) based (tp),
 217     (end_index, ntimes) fixed bin (21),
 218      match bit (1) aligned,
 219     (lab_start, lab_end, op_start, op_end, var_start, var_end, mstart) fixed bin (21),
 220      opcode char (32) aligned,
 221      iterate_arg_no fixed bin (21),
 222      save_start fixed bin (21),
 223     (obp, mp, p, tp) ptr;
 224 
 225 dcl 1 ifargs (0: 99) aligned,
 226     2 start fixed bin (21),
 227     2 len fixed bin (21);
 228 
 229 dcl 1 exargs (0: 99) aligned,
 230     2 start fixed bin (21),
 231     2 len fixed bin (21);
 232 
 233 dcl 1 args (0: 99) aligned,
 234     2 start fixed bin (21),
 235     2 len fixed bin (21);
 236 
 237 dcl 1 macro based (pfree) aligned,
 238     2 next_macro ptr unal,
 239     2 segno fixed bin,
 240     2 num_entries fixed bin,
 241     2 name char (32) var,
 242     2 entry (1),
 243       3 type fixed bin,
 244       3 value_1 fixed bin,
 245       3 value_2 fixed bin,
 246       3 first_char fixed bin (21),
 247       3 n_chars fixed bin (21);
 248 
 249 
 250                stop = 0;                                    /* initialize end of line index */
 251                nchars = a_size;                             /* copy length of buffer to work on */
 252                level = a_level;                             /* copy recursion depth */
 253                if level > 32 then do;                       /* too much recursion ... */
 254                     call com_err_ (0, "mexp", "Maximum recursion exceeded.");
 255                     goto ERROR;
 256                end;
 257 
 258                tp = bp (level);                             /* copy pointer to text to expand and copy */
 259                obp = bp (level+1);                          /* get pointer to output buffer if needed */
 260                nextb = 1;                                   /* next available char position in output buffer */
 261                filling_buffer = "0"b;                       /* indicates we are not using output buffer (yet) */
 262 GETLINE:
 263 
 264                call skip_to_next_line;                      /* get bounds of next line */
 265                if stop > nchars then do;                    /* all done, see if some thing in output buffer */
 266                     if filling_buffer then call scan_buffer (level+1, nextb-1); /* clean out the output buffer */
 267                     return;
 268                end;
 269 
 270                if stop = start then do;                     /* blank line, just copy NL */
 271 copy_terminator:
 272                     if filling_buffer then do;
 273                          substr (ob, nextb, 1) = substr (il, stop, 1);
 274                          nextb = nextb + 1;
 275                     end;
 276                     else do;
 277                          substr (ol, next, 1) = substr (il, stop, 1); /* may also be a ";" */
 278                          next = next + 1;
 279                     end;
 280                     goto GETLINE;
 281                end;
 282 
 283                lab_start, op_start, var_start = -1;         /* initialize starting indexes as flags */
 284                ci = start;                                  /* initialize scanning index */
 285                call sob;                                    /* skip over blanks */
 286 
 287 
 288                arg_start = ci;                              /* remember where the scan started */
 289 
 290 /* The first search is special cased because of label possibilities */
 291 
 292 check_char:
 293                c = substr (il, ci, 1);                      /* pick up the next character of the line */
 294 
 295                if c = ":" then do;                          /* we've come across a label */
 296                     lab_start = arg_start;                  /* set index to start of the label */
 297                     lab_end = ci;                           /* set index to end of label */
 298                     if ci = arg_start then goto syn;        /* check for initial : */
 299                     ci = ci + 1;                            /* skip over the : */
 300                     goto scan_opcode;                       /* look for an opcode */
 301                end;
 302 
 303                if c = " " | c = TAB then do;                /* if we've come to white space we just scanned an opcode */
 304                     op_start = arg_start;                   /* set the index to the start of the opcode */
 305                     op_end = ci-1;                          /* and the index to the end of the opcode */
 306                     len_op = op_end - op_start + 1;
 307                     opcode = substr (il, op_start, len_op);
 308                     goto scan_var;                          /* scan the variables field */
 309                end;
 310 
 311                if c = NL | c = ";" then do;                 /* we've come to the end of the line */
 312                     if ci ^= arg_start then do;             /* if opcode was given, remember it */
 313                          op_start = arg_start;
 314                          op_end = ci-1;
 315                          len_op = op_end - op_start + 1;
 316                          opcode = substr (il, op_start, len_op);
 317                     end;
 318                     goto output_current_line;               /* go clean up the current line */
 319                end;
 320 
 321                if c = QUOTE then do;                        /* we came across a comment */
 322                     if ci ^= arg_start then do;
 323 syn:                     call com_err_ (0, (my_name), "Unexpected syntax in line ^d", line_no);
 324                          call com_err_ (0, (my_name), "line is: ^/^a", substr (il, start, stop-start+1));
 325                          call copy_line;
 326                          goto GETLINE;
 327                     end;
 328                     goto output_current_line;
 329                end;
 330 
 331                ci = ci + 1;                                 /* scan to the next character */
 332                goto check_char;
 333 
 334 /* ^L */
 335 
 336 scan_opcode:
 337                call sob;                                    /* skip over blanks and tabs */
 338                if substr (il, ci, 1) = QUOTE then goto output_current_line; /* check for a comment */
 339 
 340                op_start = ci;                               /* save start of the opcode */
 341                call soc;                                    /* skip over non-white characters */
 342                op_end = ci-1;                               /* save end of the opcode */
 343                if ci > stop then op_end = op_end - 1;       /* if last thing on line was opcode, don't copy term */
 344                len_op = op_end - op_start + 1;              /* get length of opcode */
 345                opcode = substr (il, op_start, len_op);      /* get the opcode */
 346 
 347 scan_var:
 348                call sob;                                    /* skip over blanks again */
 349                if opcode = "acc" | opcode = "aci" | opcode = "bci" then do; /* special case these opcodes */
 350                     c = substr (il, ci, 1);                 /* get quoting character used by ACC or ACI */
 351                     t = index (substr (il, ci+1, stop-ci), c)-1; /* look for matching char */
 352                     if t < 0 then goto output_current_line; /* really was comment */
 353                     else i = ci+1+t;                        /* index of matching char */
 354                     var_start = ci;                         /* treat char string as variable field */
 355                     var_end = i;
 356                     ci = i+1;
 357                     goto output_current_line;               /* search for a comment */
 358                end;
 359                var_start = ci;                              /* save start of variable field */
 360                call soc;                                    /* skip over non-white characters */
 361                var_end = ci-1;                              /* save last char of variable field */
 362                if ci > stop then var_end = var_end - 1;
 363 
 364 
 365 /* ^L */
 366 
 367 output_current_line:
 368 
 369                if op_start > 0 then do;                     /* see if an opcode was given */
 370 
 371 /* See if the opcode is some special pseudo-op */
 372 
 373                     if opcode = "ife" | opcode = "ine" | opcode = "ifarg" | opcode = "ifint" | opcode = "inint" then do;
 374                          j = index (substr (il, stop), "ifend"); /* search for end of conditional data */
 375                          if j <= 0 then do;                 /* bad use of pseudo-op */
 376 BAD_PSEUDO:                   call com_err_ (0, (my_name), "Bad use of ^a at line ^d.", opcode, line_no);
 377                               return;
 378                          end;
 379                          end_index = stop + j;              /* save position of ifend */
 380                          if var_start < 0 then goto BAD_PSEUDO; /* must have args for INE and IFE */
 381                          call scan_args (ifargs, no_ifargs, var_start, var_end-var_start+1);
 382                          targ = substr (il, ifargs (1).start, ifargs (1).len);
 383                          if opcode = "ifarg" then do;       /* conditional expansion on input arg */
 384                               match = "0"b;                 /* default is no match */
 385                               do ia = 1 to no_input_args while (match = "0"b); /* search all input args */
 386                                    if targ = input_arg (ia-1) then match = "1"b;
 387                               end;
 388                          end;
 389                          else if opcode = "ifint" | opcode = "inint" then do;
 390                               discard = cv_dec_check_ ((targ), code); /* check for decimal number */
 391                               match = (code = 0);           /* match if arg is decimal integer */
 392                               if opcode = "inint" then match = ^match;
 393                          end;
 394                          else do;
 395                               if targ = substr (il, ifargs (2).start, ifargs (2).len) then
 396                               match = "1"b; else match = ""b;
 397                               if opcode = "ine" then match = ^match; /* inverse meaning for INE case */
 398                          end;
 399                          ntimes = 1;                        /* we join the dup code so ... */
 400 INE_JOIN:
 401                          if lab_start > 0 then do;          /* don't leave off label */
 402                               len1 = lab_end -lab_start + 1;
 403                               substr (ob, nextb, len1) = substr (il, lab_start, len1);
 404                               nextb = nextb + len1;
 405                          end;
 406                          filling_buffer = "1"b;
 407 GET_ANOTHER_LINE:        call skip_to_next_line;            /* scan another line */
 408                          if stop > end_index then do;       /* if the new line includes the ifend ... */
 409                               ntimes = ntimes - 1;          /* decrement number of passes through */
 410                               if ntimes > 0 then do;        /* only for dup case */
 411                                    stop = save_start;       /* go back */
 412                                    goto GET_ANOTHER_LINE;
 413                               end;
 414                               if match then do;
 415                                    len1 = end_index-start-1;
 416                                    call copy_line_len;
 417                               end;
 418                               if substr (il, end_index+4, 5) = "_exit" & level > 1 & match then do;
 419                                    if filling_buffer then call scan_buffer (level+1, nextb-1);
 420                                    return;
 421                               end;
 422                               goto GETLINE;                 /* and start with next normal line */
 423                          end;
 424                          else do;                           /* one of the lines to be expanded conditionally */
 425                               if match then call copy_line;
 426                               goto GET_ANOTHER_LINE;
 427                          end;
 428                     end;
 429 
 430                     if opcode = "dup" then do;
 431                          j = index (substr (il, stop), "dupend"); /* search for end of dup */
 432                          if j < 0 then goto BAD_PSEUDO;
 433                          if var_start < 0 then goto BAD_PSEUDO;
 434                          save_start = stop;
 435                          match = "1"b;                      /* for later join with INE/IFE code */
 436                          end_index = stop + j;
 437                          ntimes = cv_dec_check_ (substr (il, var_start, var_end-var_start+1), code);
 438                          if code ^= 0 then goto BAD_PSEUDO;
 439                          goto INE_JOIN;
 440                     end;
 441 
 442                     if opcode = "&include" then do;         /* an include file was specified */
 443                          call copy_line_quoted;             /* print out macro line as a comment */
 444                          if var_start < 0 then goto BAD_MACRO_FILE; /* no file name, bad style */
 445                          path = substr (il, var_start, var_end-var_start+1) || ".incl.mexp"; /* get pathname */
 446                          call find_include_file_$initiate_count ("mexp", tp, path, bit_count, mp, code);
 447                          if mp = null then do;              /* couldn't get pointer to macro file */
 448                               call com_err_ (code, (my_name), "Could not get pointer to include file ^a", path);
 449                               goto BAD_MACRO_FILE;
 450                          end;
 451                          call build_macros (mp, bit_count); /* place macros in macro directory */
 452                          goto GETLINE;
 453                     end;
 454 
 455                     if opcode = "&macros" then do;          /* a macro segment was specified */
 456                          call copy_line_quoted;             /* print out macro line as a comment */
 457                          if var_start < 0 then goto nopath; /* if no macro file given, use default */
 458                          path = substr (il, var_start, var_end-var_start+1); /* get pathname */
 459                          if path = "&system" then do;
 460 nopath:                       dirname_p = ">system_library_tools"; /* use system standard macro segment */
 461                               ename_p = "mexp_system_macros";
 462                          end;
 463                          else do;                           /* not system macros */
 464                               call expand_path_ (addr (path), var_end-var_start+1, addr (dirname_p), addr (ename_p), code);
 465                               if code ^= 0 then do;         /* something screwed up in pathname */
 466 BAD_MACRO_FILE:                    call com_err_ (code, (my_name), "Bad syntax in macro pathname on line ^d", line_no);
 467                                    goto GETLINE;
 468                               end;
 469                          end;
 470                          call hcs_$initiate_count (dirname_p, ename_p, "", bit_count, 0, mp, code); /* get pointer to macro file */
 471                          if mp = null then do;              /* couldn't get pointer to macro file */
 472                               call com_err_ (code, (my_name), "Could not get pointer to macro file ^a>^a", dirname_p, ename_p);
 473                               goto BAD_MACRO_FILE;
 474                          end;
 475                          call build_macros (mp, bit_count); /* place macros in macro directory */
 476                          goto GETLINE;
 477                     end;
 478 
 479                     if opcode = "&macro" then do;           /* a macro was given within the text of this program */
 480                          j = index (substr (il, stop), "&end"); /* search for matching "&end" */
 481                          if j < 1 then do;                  /* bad macro definition */
 482                               call com_err_ (0, (my_name), "Bad macro definition starting at line ^d.", line_no);
 483                               return;
 484                          end;
 485                          macro_len = j+stop+3;
 486                          substr (ol, next, 1) = QUOTE;      /* comment out macro def */
 487                          next = next + 1;
 488                          start_name = var_start;
 489                          len1 = var_end-var_start+1;
 490                          pfree = old_free;                  /* restore free index (restored earlier) */
 491                          call build_macro (ilp, stop, len1, start_name); /* leaves stop pointing to end of macro def */
 492                          old_free = pfree;                  /* save free index (used later) */
 493                          do i = start to stop - 1;          /* scan over all characters of the macro definition */
 494                               c = substr (il, i, 1);        /* get current character */
 495                               substr (ol, next, 1) = c;     /* copy it into the output segment */
 496                               next = next + 1;
 497                               if c = NL | c = ";" then do;  /* follow all NL's and ;'s with a " */
 498                                    substr (ol, next, 1) = QUOTE;
 499                                    next = next+1;
 500                                    if level = 1 then if c = NL then line_no = line_no + 1;
 501                               end;
 502                          end;
 503                          if level = 1 then line_no = line_no - 1; /* first line was counted twice, so ... */
 504                          goto copy_terminator;
 505                     end;
 506 
 507 /* See if the opcode is a macro name */
 508 
 509                     do pfree = last_macro repeat macro.next_macro while (pfree ^= null);
 510                          if macro.name = opcode then do;    /* we have found a macro to expand */
 511 
 512                               if filling_buffer then do;    /* must fisrt clean out what's in the buffer */
 513                                    call scan_buffer (level+1, nextb-1);
 514                                    filling_buffer = "0"b;
 515                                    nextb = 1;
 516                               end;
 517                               mp = baseptr (macro.segno);   /* get pointer to macro segment to use */
 518 
 519 /* Write out the macro line preceded with a comment character */
 520 
 521                               if lab_start > 0 then do;     /* if a label was given on the macro, don't comment it out */
 522                                    len1 = lab_end - lab_start + 1;
 523                                    substr (ob, nextb, len1) = substr (il, lab_start, len1);
 524                                    nextb = nextb + len1;
 525                               end;
 526 
 527                               call copy_line_quoted;        /* copy the macro line as a comment */
 528                               if unique_changed then do;    /* did we use it last macro? */
 529                                    unique_generator1 = unique_generator1 + 1;
 530                                    unique_changed = ""b;
 531                               end;
 532 
 533 /* Now pick off any args from the input source, save pointers to them */
 534 
 535                               if var_start > 0 then do;     /* if args were given ... */
 536                                    call scan_args (args, nargs, var_start, var_end-var_start+1);
 537                               end;
 538                               else do;                      /* no args to macro */
 539                                    do i = 0 to 99;
 540                                         args (i).len = 0;
 541                                    end;
 542                                    nargs = 0;
 543                               end;
 544                               if lab_start > 0 then do;
 545                                    args.len (0) = lab_end-lab_start;
 546                                    args.start (0) = lab_start;
 547                               end;
 548                               else args.len (0) = 0;
 549                               iterate = 0;                  /* in case &x is used and iteration isn't */
 550 
 551 /* Now copy expanded text into file */
 552 
 553                               do entry_no = 1 to macro.num_entries;
 554                                    len = macro.entry (entry_no).n_chars; /* get size of element */
 555                                    if len > 0 then do;
 556                                         substr (ob, nextb, len) = substr (ml, macro.entry (entry_no).first_char, len);
 557                                         nextb = nextb + len;
 558                                    end;
 559                                    val = macro.entry (entry_no).value_1; /* extract value for this type of element */
 560                                    type = macro.entry (entry_no).type; /* also extract type of element */
 561                                    if type = type_UNIQUE then do; /* "u" expansion */
 562                                         unique_generator = unique_generator + 1;
 563                                         i = unique_generator; /* get value for symbol */
 564 UNIQUE:                                 substr (ob, nextb, 3) = "..."; /* generate unique symbol */
 565 UNIQUE1:                                nextb = nextb + 3;
 566                                         vc = convert_binary_integer_$octal_string (i + 1e27b); /* convert to char */
 567                                         substr (ob, nextb, 5) = substr (vc, 6, 5);
 568                                         nextb = nextb + 5;
 569                                    end;
 570                                    else if type = type_PREV_UNIQUE then do; /* "p" expansion" */
 571                                         i = unique_generator; /* get value for symbol */
 572                                         goto UNIQUE;
 573                                    end;
 574                                    else if type = type_NEXT_UNIQUE then do; /* "n" expansion */
 575                                         i = unique_generator + 1;
 576                                         goto UNIQUE;
 577                                    end;
 578                                    else if type = type_SPEC_UNIQUE then do; /* "U" expansion */
 579                                         i = unique_generator1;
 580                                         substr (ob, nextb, 3) = ".._"; /* this "_" used to be "!" */
 581                                         unique_changed = "1"b;
 582                                         goto UNIQUE1;
 583                                    end;
 584                                    else if type = type_ITERATE then do; /* 5 indicates &i */
 585                                         len = exargs (iterate).len;
 586                                         if len > 0 then do;
 587                                              substr (ob, nextb, len) = substr (il, exargs (iterate).start, len);
 588                                              nextb = nextb + len;
 589                                         end;
 590                                    end;
 591                                    else if type = type_COMMAND_ARGNO then do; /* &x */
 592                                         val = iterate;
 593 PUTNUM:                                 vc = convert_binary_integer_$decimal_string (val);
 594                                         i = length (vc);
 595                                         substr (ob, nextb, i) = vc;
 596                                         nextb = nextb+i;
 597                                    end;
 598                                    else if type = type_COMMAND_ARG then do; /* A_^Hn */
 599                                         len = length (input_arg (val-1));
 600                                         substr (ob, nextb, len) = input_arg (val-1);
 601                                         nextb = nextb + len;
 602                                    end;
 603                                    else if type = type_NORMAL then do; /* normal argument expansion */
 604                                         if val <= nargs then do;
 605                                              len = args.len (val);
 606                                              substr (ob, nextb, len) = substr (il, args.start (val), len);
 607                                              nextb = nextb + len;
 608                                         end;
 609                                    end;
 610                                    else if type = type_CLOSE then do; /* &) */
 611                                         iterate = iterate + 1; /* another iteration complete */
 612                                         entry_no = save_free;
 613                                         goto ANY_ARGS_Q;
 614                                    end;
 615                                    else if type = type_OPEN then do; /* &( */
 616                                         save_free = entry_no;
 617                                         iterate_arg_no = val;
 618                                         iterate = 1;
 619                                         i = args (iterate_arg_no).len;
 620                                         if i > 0 then do;
 621                                              j = args (iterate_arg_no).start;
 622                                              call scan_args (exargs, no_exargs, j, i);
 623                                         end;
 624                                         else no_exargs = 0;
 625 ANY_ARGS_Q:                             if no_exargs < iterate then do;
 626                                              entry_no = macro.entry (save_free).value_2;
 627                                         end;
 628                                    end;
 629                                    else if type = type_LENGTH then do;
 630                                         val = args (val).len;
 631                                         goto PUTNUM;
 632                                    end;
 633                                    else if type = type_NARGS then do;
 634                                         val = nargs;
 635                                         go to PUTNUM;
 636                                    end;
 637                                    else if type = type_NITER then do;
 638                                         val = no_exargs;
 639                                         go to PUTNUM;
 640                                    end;
 641                                    else if type ^= type_ENDM then do; /* internal error in mexp */
 642                                         call com_err_ (0, (my_name), "Mexp internal error");
 643                                         goto ERROR;
 644                                    end;
 645                               end;
 646                               call scan_buffer (level+1, nextb-1); /* scan newly expanded macro for more macros */
 647                               nextb = 1;
 648                               goto GETLINE;                 /* get next line of text */
 649                          end;
 650 
 651                     end;
 652 
 653 /* No macros match, just copy given line */
 654 
 655                end;
 656 
 657                call copy_line;                              /* copy the line into the output text */
 658                goto GETLINE;
 659 
 660 /* ^L */
 661 
 662 /* The following routine parses a string and picks off arguments */
 663 
 664 scan_args:     proc (array, no_args, firstx, count);
 665 
 666 dcl 1 array (0: 99) aligned,
 667     2 first fixed bin (21),
 668     2 size fixed bin (21);
 669 
 670 dcl
 671      c2 char (2) aligned;
 672 
 673 dcl  no_args fixed bin,
 674     (firstx, count, arg_start, i, last) fixed bin (21);
 675 
 676                     do i = 0 to 99;
 677                          array (i).size = 0;
 678                     end;
 679                     arg_start, ci = firstx;
 680                     last = ci + count - 1;
 681                     no_args = 0;
 682 GET_ANOTHER_ARG:
 683                     c2 = substr (il, ci-1, 2);
 684                     if c2 = COMMA_NL | c2 = ", " | c2 = ",  " | c2 = ",""" then do; /* continue on next line */
 685                          call skip_to_next_line;
 686                          if stop > nchars then return;
 687                          call copy_line_quoted;             /* comment out the arguments */
 688                          t = verify (substr (il, start, stop-start+1), WHITE)-1; /* skip white space */
 689                          if t < 0 then ci = stop+1;
 690                          else ci = start + t;
 691                          arg_start = ci;                    /* save start of variable field */
 692                          call soc;                          /* skip to end of variable field */
 693                          if stop = ci-1 then last = ci-2;
 694                          else last = ci-1;
 695                          ci = arg_start;
 696                          goto GET_ANOTHER_ARG;
 697                     end;
 698 
 699                     else if substr (il, ci, 1) = "(" then do; /* watch out for args with parens */
 700                          nparens = 1;                       /* skip till no more parens at this level */
 701                          do ci = ci+1 to last while (nparens > 0);
 702                               if substr (il, ci, 1) = "(" then nparens = nparens + 1;
 703                               else if substr (il, ci, 1) = ")" then nparens = nparens - 1;
 704                          end;
 705                          if nparens > 0 then do;
 706                               call com_err_ (0, (my_name), "Unbalanced parentheses at line ^d", line_no);
 707                               return;
 708                          end;
 709 
 710                          no_args = no_args + 1;
 711                          array.first (no_args) = arg_start+1; /* copy information about where the arg is */
 712                          array.size (no_args) = ci - arg_start - 2;
 713                          goto NEXT_ARG;
 714                     end;
 715 
 716                     else do;                                /* argument didn' start with paren */
 717                          t = index (substr (il, ci, last-ci+1), ",")-1;
 718                          if t < 0 then ci = last + 1;
 719                          else ci = ci + t;
 720 
 721                          no_args = no_args + 1;
 722                          array.first (no_args) = arg_start;
 723                          array.size (no_args) = ci - arg_start;
 724 NEXT_ARG:                ci, arg_start = ci+1;
 725                          if arg_start <= last+1 then goto GET_ANOTHER_ARG;
 726                     end;
 727                     return;
 728 
 729 
 730                end scan_args;
 731                                                             /* ^L */
 732 
 733 /* The following procedure is used to extract the macro definitions found in the
 734    macro file pointed to by mp. */
 735 
 736 build_macros:  proc (mp, bit_count);
 737 
 738 dcl  mp ptr, bit_count fixed bin (24);
 739 
 740 /* Scan the macro source file extracting information about the macros
 741    and puting the information into the temporary segment pointed to by fp */
 742 
 743                     macro_len = divide (bit_count, 9, 17, 0);
 744                     pfree = old_free;                       /* index to next free word of the free segment */
 745                     ci = 1;                                 /* points to current character being scanned */
 746 
 747 ANOTHER_MACRO:
 748                     len = 100;
 749                     j = index (substr (ml, ci), "&macro")-1;
 750                     if j < 0 then do;                       /* no more, all done with this macro seg */
 751                          old_free = pfree;
 752                          return;
 753                     end;
 754 
 755                     mstart = j+ci;                          /* get start of macro definition */
 756                     t = verify (substr (ml, mstart+6), WHITE)-1;
 757                     if t < 0 then goto BAD_MACRO_DEF;
 758                     start_name = mstart+6+t;
 759                     t = search (substr (ml, start_name), WHITE_TERM)-1;
 760                     if t < 0 then goto BAD_MACRO_DEF;
 761                     ci = start_name + t;
 762                     len = ci - start_name;                  /* get length of macro name */
 763                     call build_macro (mp, ci, len, start_name);
 764                     goto ANOTHER_MACRO;                     /* process another macro */
 765 
 766 BAD_MACRO_DEF:      call com_err_ (0, (my_name), "Bad macro defintion at line ^d.", line_no);
 767                     return;
 768 
 769                end build_macros;
 770 
 771 /* ^L */
 772 /* The following procedure is used to enter a single macro into the macro table */
 773 
 774 build_macro:   proc (mp, ci, len, start_name);
 775 
 776 dcl  mp ptr, ci fixed bin (21), len fixed bin (21), start_name fixed bin (21);
 777 
 778 dcl  ml char (macro_len) based (mp) aligned;
 779 dcl  tfree ptr;
 780 
 781 dcl  start fixed bin (21);
 782 dcl  in_iteration fixed bin;
 783 
 784 
 785                     in_iteration = 0;
 786 
 787                     tfree = pfree;                          /* remember where this macro started */
 788                     macro.name = substr (ml, start_name, len);
 789 
 790                     macro.segno = bin (baseno (mp));        /* save segment number in macro structure */
 791 
 792 /* Now generate sub-structure */
 793 
 794                     t = search (substr (ml, ci), TERM)-1;
 795                     if t < 0 then goto BAD_MACRO_DEF;
 796                     ci = ci + t;
 797 
 798                     do entry_no = 1 by 1;                   /* iterate until macro defined */
 799                          start = ci+1;                      /* get start of the current element */
 800                          do ci = start to macro_len while (substr (ml, ci, 1) ^= "&");
 801                          end;                               /* skip to next special character */
 802                          if ci >= macro_len then do;
 803                               ci = macro_len;               /* leave ci pointing to end of macro */
 804                               goto FIN_MACRO;
 805                          end;
 806 
 807                          macro.entry (entry_no).first_char = start;
 808                          macro.entry (entry_no).n_chars = ci-start;
 809 
 810                          c = substr (ml, ci+1, 1);          /* copy next character -- might by argument number */
 811                          si = 1;                            /* indicates where to start scan */
 812                          call get_numeric_value;
 813                          if found_number then do;
 814                               type = type_NORMAL;           /* normal arg expansion */
 815                               macro.entry (entry_no).value_1 = i;
 816                               ci = ci-1;
 817                          end;
 818                          else if c = "p" then type = type_PREV_UNIQUE; /* predecessor */
 819                          else if c = "u" then type = type_UNIQUE; /* unique number */
 820                          else if c = "n" then type = type_NEXT_UNIQUE; /* next unique */
 821                          else if c = "i" then do;
 822                               if in_iteration > 0 then do;
 823                                    type = type_ITERATE;
 824                               end;
 825                               else do;
 826                                    call com_err_ (0, (my_name), """&i"" occured outside of iteration bounds in macro ^a", macro.name);
 827                                    goto FIN_MACRO;
 828                               end;
 829                          end;
 830                          else if c = "(" then do;           /* start of iteration */
 831                               save_free = entry_no;
 832                               si = 2;
 833                               call get_numeric_value;
 834                               if i = 0 then i = 1;
 835                               type = type_OPEN;
 836                               macro.entry (entry_no).value_1 = i;
 837                               if in_iteration > 0 then do;  /* warn against recursive iteration */
 838                                    call com_err_ (0, (my_name), "Illegal recursive iteration in macro ^a", macro.name);
 839                                    goto FIN_MACRO;
 840                               end;
 841                               else in_iteration = 1;
 842                          end;
 843                          else if c = ")" then do;           /* end of iteration */
 844                               in_iteration = in_iteration - 1;
 845                               if in_iteration < 0 then goto bad_iter;
 846                               type = type_CLOSE;
 847                               macro.entry (entry_no).value_1 = save_free;
 848                               macro.entry (save_free).value_2 = entry_no;
 849                          end;
 850                          else if c = "x" then type = type_COMMAND_ARGNO;
 851                          else if c = "U" then type = type_SPEC_UNIQUE;
 852                          else if c = "A" then do;           /* &A0, ... &A9 */
 853                               si = 2;
 854                               call get_numeric_value;
 855                               type = type_COMMAND_ARG;
 856                               macro.entry (entry_no).value_1 = i;
 857                          end;
 858                          else if c = "l" then do;
 859                               si = 2;
 860                               call get_numeric_value;
 861                               if i = 0 then i = 1;
 862                               type = type_LENGTH;
 863                               macro.entry (entry_no).value_1 = i;
 864                          end;
 865                          else if c = "K" then type = type_NARGS;
 866                          else if c = "k" then type = type_NITER;
 867 
 868                          else if substr (ml, ci, 4) = "&end" then do; /* end of macro */
 869                               t = search (substr (ml, ci), TERM)-1;
 870                               if t < 0 then ci = macro_len + 1;
 871                               else ci = ci + t;
 872                               goto FIN_MACRO;
 873                          end;
 874 
 875                          else do;                           /* unexpected control */
 876 BAD_MACRO_DEF:                call com_err_ (0, (my_name), "Bad macro definition within macro ^a", macro.name);
 877                               t = index (substr (ml, ci), "&end")-1;
 878                               if t < 0 then ci = macro_len+1;
 879                               else ci = ci + t;
 880                          end;
 881 
 882                          macro.entry (entry_no).type = type;
 883                          ci = ci + 1;
 884 
 885                     end;
 886 
 887 
 888 FIN_MACRO:
 889                     if in_iteration ^= 0 then do;
 890 bad_iter:                call com_err_ (0, (my_name), "Unbalanced iteration within macro ^a", macro.name);
 891                     end;
 892                     macro.entry (entry_no).type = type_ENDM; /* indicates end of macro */
 893                     macro.num_entries = entry_no;
 894                     macro.next_macro = last_macro;          /* fill in pointer to previous macro structure */
 895                     last_macro = tfree;
 896                     pfree = addr (macro.entry (entry_no+1)); /* save pointer to where next macro goes */
 897                     return;
 898 
 899 
 900 get_numeric_value:  proc;
 901 
 902 dcl  c char (1) aligned;
 903 
 904                          i = 0;                             /* initialize return value */
 905                          found_number = "0"b;
 906                          do ci = ci to ci+2;
 907                               c = substr (ml, ci+si, 1);
 908                               if c < "0" then return;
 909                               if c > "9" then return;
 910                               found_number = "1"b;
 911                               i = i*10 + bin (unspec (c), 9) - 48;
 912                          end;
 913 
 914                     end;
 915 
 916                end build_macro;
 917 
 918 /* ^L */
 919 
 920 copy_line_quoted: proc;
 921 
 922 dcl  tx fixed bin;
 923 
 924                     if filling_buffer then do;
 925                          substr (ob, nextb, 1) = QUOTE;
 926                          nextb = nextb + 1;
 927                     end;
 928                     else do;
 929                          substr (ol, next, 1) = QUOTE;
 930                          next = next + 1;
 931                     end;
 932 txl:                tx = index (substr (il, start, stop-start), ";");
 933                     if tx ^= 0 then do;
 934                          if filling_buffer then do;
 935                               substr (ob, nextb, tx+1) = substr (il, start, tx) || QUOTE;
 936                               nextb = nextb + tx+1;
 937                               start = start + tx;
 938                          end;
 939                          else do;
 940                               substr (ol, next, tx+1) = substr (il, start, tx) || QUOTE;
 941                               next = next + tx+1;
 942                               start = start + tx;
 943                          end;
 944                          go to txl;
 945                     end;
 946 
 947 copy_line:          entry;
 948 
 949                     len1 = stop - start + 1;
 950 copy_line_len:      entry;
 951 
 952                     if filling_buffer then do;
 953                          substr (ob, nextb, len1) = substr (il, start, len1);
 954                          nextb = nextb + len1;
 955                     end;
 956                     else do;
 957                          substr (ol, next, len1) = substr (il, start, len1);
 958                          next = next + len1;
 959                     end;
 960                     return;
 961 
 962 
 963                end;
 964 
 965 skip_to_next_line: proc;
 966 
 967                     start = stop+1;                         /* get start of next line */
 968 dcl  nparens fixed bin;
 969 
 970                     nparens = 0;
 971                     stop = start;
 972 more:               t = search (substr (il, stop), ENDS)-1;
 973                     if t < 0 then do;
 974                          stop = nchars + 1;
 975                          return;
 976                     end;
 977                     stop = stop + t;
 978                     if substr (il, stop, 1) = "(" then nparens = nparens + 1;
 979                     else if substr (il, stop, 1) = ")" then nparens = nparens - 1;
 980                     else if substr (il, stop, 1) = ";" & nparens > 0 then; /* ignore ";" unless outside "()" */
 981                     else do;
 982                          if level = 1 & substr (il, stop, 1) = NL then line_no = line_no + 1;
 983                          return;
 984                     end;
 985                     stop = stop + 1;
 986                     go to more;
 987 
 988                end;
 989                                                             /* ^L */
 990 sob:           proc;
 991 
 992                     t = verify (substr (il, ci, stop-ci+1), WHITE)-1;
 993                     if t < 0 then goto output_current_line;
 994                     ci = ci + t;
 995                     return;
 996 
 997                end;
 998 soc:           proc;
 999 
1000 dcl  nparens fixed bin;
1001 
1002                     nparens = 0;
1003 more:               t = search (substr (il, ci, stop-ci+1), "()        """)-1;
1004                     if t < 0 then do;
1005                          ci = stop+1;
1006                          return;
1007                     end;
1008                     ci = ci + t;
1009                     c = substr (il, ci, 1);
1010                     if c = "(" then nparens = nparens + 1;
1011                     else if c = ")" then nparens = nparens - 1;
1012                     else if nparens = 0 then return;
1013                     ci = ci + 1;
1014                     goto more;
1015 
1016                end;
1017           end scan_buffer;
1018 
1019      end mexp;