1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1988                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 
  15 /****^  HISTORY COMMENTS:
  16   1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
  17      audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
  18      Modified to change argument passing conventions. This is part of the
  19      changes for calling via the new subroutine "alm_".
  20                                                    END HISTORY COMMENTS */
  21 
  22 
  23 mexp_$ignore: procedure ();
  24           return;
  25 
  26 /* This program is a simple macro expander for alm programs. */
  27 
  28 /* Last modified to list skipped iftarget code as comments by E. N. Kittlitz on 8/17/83 */
  29 /* Last modified for changes requested by MTR 175 by EBush on 3/26/81 */
  30 /* Modified to implement "iftarget" and "intarget" by EBush on 2/5/81 */
  31 /* First written "about '70, '71" by Steve Webber, as stand-alone program. */
  32 /* Integrated with ALM, fully EIS-ed, resubroutinized by Bernard Greenberg 3/25/77
  33    Also implemented functions 14-22 at that time, and shared-seg buffer stack. */
  34 
  35 
  36 dcl  next fixed bin (21),
  37      code fixed bin (35),
  38      entry_no fixed bin (21),
  39      WHITE char (2) static init ("       ") options (constant),
  40      ENDS char (4) static init ("();
  41 ") options (constant),
  42      TERMS char (2) static init (";
  43 ") options (constant),
  44      discard fixed bin,
  45      vc char (12) var,
  46      convert_binary_integer_$octal_string entry (fixed bin) returns (char (12) var),
  47      cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
  48      c char (1) aligned,
  49     (addr, substr, ptr, unspec, index, null, length) builtin,
  50      gtsname char (32) static options (constant) init ("ALM macro expander"),
  51     (no_exargs, no_ifargs) fixed bin,
  52      alm_finished_the_line bit (1) aligned,
  53      cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
  54      cu_$arg_list_ptr entry returns (ptr),
  55      error_table_$noarg fixed bin(35) external,
  56      ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned),
  57      targ char (128) var,
  58      cbuf1 char (200), cb1b char (cb1l) based (addr (cbuf1)), cb1l fixed bin,
  59      temp_ap ptr, temp_al fixed bin (21),
  60      input_arg char (temp_al) based (temp_ap),
  61      arg_1 char (args (1).len) based (substaddr (il, args (1).start)),
  62      QUOTE char (1) aligned static init (""""),
  63      max_char_count fixed bin (21),
  64      sys_info$max_seg_size ext static fixed bin (35),
  65      COMMA_NL char (2) static init (",
  66 ") options (constant),
  67      NL char (1) static init ("
  68 ") options (constant),
  69      SIGNATURE char (14) static init ("ALM assembly: ") options (constant);
  70 
  71 /* ^L
  72 
  73    TABLE OF MEXP CONTROL CODES and INDICES.
  74 
  75    Keep the vars HERE_FOR_DOCU(1 2) declared under MEXP_CTL_CHARS.
  76    They document the char/index relation.
  77 
  78 */
  79 dcl  MEXP_CTL_CHARS char (22) init ("1puni()xUAlKk&=[];sFfR") static options (constant);
  80 dcl  HERE_FOR_DOCU1 char (22) init ("0000000001111111111222") static options (constant);
  81 dcl  HERE_FOR_DOCU2 char (22) init ("1234567890123456789012") static options (constant);
  82 dcl  TRIVIAL_ENCODES char (9) init ("punxUKksR") static options (constant);
  83 dcl  COMPARISON_CHARS char (4) init ("^=><") static options (constant);
  84 dcl  COMPARISON_ENCODE char (12) init ("= ^=< <=> >=") static options (constant);
  85 dcl (EQ init (1), NE init (2), LT init (3), LE init (4), GT init (5), GE init (6)) static options (constant);
  86 dcl  type_NORMAL fixed bin static options (constant) init (1);
  87 dcl  type_PREV_UNIQUE fixed bin static options (constant) init (2);
  88 dcl  type_UNIQUE fixed bin static options (constant) init (3);
  89 dcl  type_NEXT_UNIQUE fixed bin static options (constant) init (4);
  90 dcl  type_ITERATE fixed bin static options (constant) init (5);
  91 dcl  type_OPEN fixed bin static options (constant) init (6);
  92 dcl  type_CLOSE fixed bin static options (constant) init (7);
  93 dcl  type_ITER_INDEX fixed bin static options (constant) init (8);
  94 dcl  type_SPEC_UNIQUE fixed bin static options (constant) init (9);
  95 dcl  type_COMMAND_ARG fixed bin static options (constant) init (10);
  96 dcl  type_LENGTH fixed bin static options (constant) init (11);
  97 dcl  type_NARGS fixed bin static options (constant) init (12);
  98 dcl  type_NITER fixed bin static options (constant) init (13);
  99 dcl  type_NULL fixed bin static options (constant) init (14);
 100 dcl  type_COMPARE fixed bin static options (constant) init (15);
 101 dcl  type_STARTCOND fixed bin static options (constant) init (16);
 102 dcl  type_ENDCOND fixed bin static options (constant) init (17);
 103 dcl  type_ELSE fixed bin static options (constant) init (18);
 104 dcl  type_SELECT fixed bin static options (constant) init (19);
 105 dcl  type_FARGS_MACRO fixed bin static options (constant) init (20);
 106 dcl  type_FARGS_ITER fixed bin static options (constant) init (21);
 107 dcl  type_RANGECTL fixed bin static options (constant) init (22);
 108 dcl  type_MAXTYPE fixed bin static options (constant) init (22);
 109 
 110 /* WARNING: All internal procedures other than deferr, experr, and genabort must be kept quick, especially
 111    substaddr. This implies that the three above-named routines, which have formline_ arguments,
 112    and must therefore be non-quick, must never call any subroutines in this program, or they become
 113    non-quick. */
 114 
 115 
 116 
 117 /* ^L */
 118 
 119 /*  Declarations for ALM environment integration. */
 120 
 121 dcl (envp, sfap) ptr;
 122 dcl  acode fixed bin (35);                                  /* return code for Multics errors */
 123 dcl  hashx fixed bin (17);                                  /* macro name hash index */
 124 
 125 dcl 1 bct based (envp) aligned,                             /* control structure */
 126     2 sfap ptr init (null ()),                              /* ptr to system_free_area */
 127     2 nsegs fixed bin init (2),                             /* number of tempsegs gotten */
 128     2 curexpseg fixed bin init (2),                         /* cur seg for expansions */
 129     2 macroptr (0:126) ptr,                                 /* non-initted hash table of macros */
 130     2 hashx_used bit (127) aligned init ("0"b),             /* 0 => macroptr(x) not valid */
 131     2 curlevel fixed bin init (0),                          /* level of macros handed out */
 132     2 macfree fixed bin init (0),                           /* rel index to macro free def seg */
 133     2 outstack (100),                                       /* segx-ptr of macros handed out */
 134       3 segx fixed bin (13) unal,                           /* seg index of expansion buffer */
 135       3 charx fixed bin (21) unal,                          /* index of first char of that exp. */
 136     2 segarray (10) ptr init ((10) null ()),                /* temp seg array */
 137     2 segarray_free (10) fixed bin (21) init ((10) 1),      /* charx of first unused char in each buffer tempseg */
 138     2 unique_generator fixed bin init (0),
 139     2 unique_generator1 fixed bin init (0),
 140     2 unique_changed bit (1) init ("0"b);                   /* "1"b if used &U in this expansion */
 141 
 142 dcl 1 arguments(eb_data_$alm_arg_count) based(eb_data_$alm_arg_ptr),
 143      2 arg_ptr ptr,
 144      2 arg_len fixed bin(21);
 145 
 146 dcl  segarray_of_one (1) ptr auto;
 147 dcl  segarray_of_two ptr dim (2) based (addr (bct.segarray));
 148 dcl  system_free_area area based (sfap);
 149 
 150 dcl  get_system_free_area_ entry returns (ptr);
 151 dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35));
 152 
 153 dcl (inputs_$run_statement, inputs_$run_statement_nolist, inputs_$next_statement, inputs_$next_statement_nolist) ext entry;
 154 dcl  inputs_$get_ptr entry (ptr, fixed bin (21), fixed bin (21), bit (1) aligned);
 155 dcl  alm_include_file_$macro entry (ptr, fixed bin (21)),
 156      alm_include_file_$pop entry;
 157 
 158 dcl  prnter_$macro_error entry (char (*), char (*));
 159 dcl  prnter_$general_abort entry (char (*));
 160 dcl  eb_data_$mexp_env_ptr ptr external,
 161      eb_data_$macro_linect fixed bin ext,
 162      eb_data_$mexp_argno fixed bin ext,
 163      eb_data_$alm_arg_count fixed bin ext,
 164      eb_data_$alm_arg_ptr ptr ext;
 165 
 166 %include system_types;
 167 %include varcom;
 168 
 169 /* ^L */
 170 mexp_$init: entry (acode);
 171 
 172 /* Called by ALM at pass1/pass2 init. Allocate control structure, get 2 temp segs. First
 173    contains macro definition blocks, second is first expansion output buffer. */
 174 
 175           sfap = get_system_free_area_ ();                  /* set up to alloc bct */
 176           allocate bct in (system_free_area);
 177           bct.sfap = sfap;                                  /* for later free */
 178           eb_data_$mexp_env_ptr = envp;
 179           eb_data_$macro_linect = 0;
 180           call get_temp_segments_ (gtsname, segarray_of_two, acode);
 181           return;
 182 
 183 mexp_$cleanup: entry;                                       /* relinquish temp segs */
 184 
 185 /* Called by ALM at pass1/pass2 end, and on cleanup condition. Release control structure and
 186    temp segs. */
 187 
 188           envp = eb_data_$mexp_env_ptr;
 189           if envp = null then return;
 190           call release_temp_segments_ (gtsname, bct.segarray, (0));
 191           sfap = bct.sfap;
 192           free bct in (system_free_area);
 193           eb_data_$mexp_env_ptr = null ();
 194           return;
 195 
 196 /* ^L */
 197 
 198 dcl (nparens, i, ci, start, stop, j, iterate) fixed bin (21),
 199      found_number bit (1) aligned,
 200      si fixed bin (21),
 201      mbptr ptr,                                             /* Ptr to macro structure */
 202      save_free fixed bin (21),
 203      val fixed bin,
 204      semict fixed bin,                                      /* Count of ALM statements by which to run ALM */
 205      t fixed bin (21),
 206      type fixed bin,
 207      nargs fixed bin,                                       /* Number of macro args */
 208      nchars fixed bin (21),
 209      ia fixed bin,
 210      ml char (macro_len) based (mp),                        /* The Macro Definition Text. */
 211      macro_len fixed bin (21),
 212      ob char (max_char_count) based (obp),                  /* The Output Buffer */
 213      currob char (next - 1) based (obp),                    /* Currently filled portion of Output Buffer */
 214      il char (nchars) based (tp),                           /* The Input Source */
 215      end_index fixed bin (21),
 216     (save_segx, save_segx1, save_curlev) fixed bin, (save_charx, save_charx1) fixed bin (21),
 217      match bit (1) aligned,
 218      iftarget_cond bit (1) aligned,
 219     (var_start, var_end) fixed bin (21),
 220      opcode char (32) aligned,
 221      iftarget_str  char(24) varying,
 222      iftarget_error  fixed bin(35),
 223      iftarget_value fixed bin(17),
 224      system_type_ external entry(char(*), char(*), fixed bin(17), fixed bin(35)),
 225      com_err_      external entry options(variable),
 226      eb_data_$who_am_I   external static char(12),
 227      iterate_arg_no fixed bin (21),
 228     (obp, mp, tp) ptr;
 229 
 230 /* ^L */
 231 
 232 /* Data structure used by expander---  macro is structure in temp seg (1). */
 233 
 234 dcl 1 ifargs (0: 99) aligned like args;                     /* Ptr/len array for pseudoop args */
 235 
 236 dcl 1 iterargs (0: 99) aligned like args based (iap), iap ptr; /* Bound to either args or exargs for &( */
 237 
 238 dcl 1 exargs (0: 99) aligned like args;                     /* Ptr/len array for decomposed argument */
 239 
 240 dcl 1 args (0: 99) aligned,                                 /* Ptr/len array for macro args */
 241     2 start fixed bin (21),
 242     2 len fixed bin (21);
 243 
 244 dcl 1 macro based (mbptr) aligned,                          /* Definition of a macro, in tempseg (1) */
 245     2 next_macro ptr unal,                                  /* Hash thread on name. */
 246     2 startchar fixed bin (21),                             /* charx of 1st char, for exp-time err recov. */
 247     2 sourcelen fixed bin (21),                             /* Length of def in chars, for ditto. */
 248     2 sourcep ptr unal,                                     /* Ptr to sourceseg/expansion of def */
 249 
 250     2 pad bit (14) unal,
 251     2 num_entries fixed bin (21) unal,                      /* Number of entries in macro.entry */
 252 
 253     2 name char (32),                                       /* Macro name */
 254     2 entry (1000),                                         /* One entry for control seq and tex up to it. */
 255       3 type fixed bin,                                     /* Type of control sequence, see tbl above */
 256       3 value_1 fixed bin (13) unal,                        /* Encoded info, value depends on type of ctl seq */
 257       3 first_char fixed bin (21) unal,                     /* charx of text preceding ctl seq, always valid */
 258 
 259       3 value_2 fixed bin (13) unal,                        /* Encoded info, value depends on type of ctl seq */
 260       3 n_chars fixed bin (21) unal;                        /* Number of chars of text preceding ctl seq, c/b 0. */
 261 
 262 /* ^L */
 263 
 264 mexp_$define_macro: entry (a_opcode);                       /* define a macro. */
 265 
 266 /* Define a macro. ALM has already picked up the name, and passed it to us, and validated the syntax
 267    of the statement, which means that inputs_ is at the end of the statement. We let ALM decompose the
 268    "macro" statement so that ALM's rules on valid symbols and delimiters, which will be used when
 269    macro is used as opcode, can be applied. */
 270 
 271           envp = eb_data_$mexp_env_ptr;                     /* access control frame */
 272 
 273           do i = 1 to bct.curlevel;                         /* If source for definition lies in macro expansion,
 274                                                                make sure than no buffer space occupied by
 275                                                                outstanding macro expansions is ever freed/re-used. */
 276                                                             /* This ensures the validity of ptr/len's to be encoded. */
 277                bct.outstack.segx (i) = bct.curexpseg;
 278                bct.outstack.charx (i) = bct.segarray_free (bct.curexpseg);
 279           end;
 280 
 281           call get_ptrs;                                    /* Find out where alm is, oughtta be next sta. */
 282 
 283           call get_hashx ((a_opcode));                      /* Compute hash index */
 284 
 285           call define_macro (a_opcode, (tp), stop + 1, nchars - stop); /* do it */
 286           return;
 287 
 288 /* ^L */
 289 define_macro: proc (mname, mpstart, cistart, amacrolen);
 290 
 291 dcl  mp ptr, cifin fixed bin (21);
 292 dcl  bad_macro bit (1);
 293 dcl (almpos, lasteralmpos) fixed bin (21);
 294 dcl  amacrolen fixed bin (21);
 295 dcl  condthread fixed bin, condstack (10) fixed bin;
 296 dcl  mname char (*), cistart fixed bin (21), mpstart ptr, ciprev fixed bin (21);
 297 
 298 dcl  ml char (macro_len) based (mp) aligned;
 299 dcl (condlevel, itercondlevel) fixed bin;
 300 dcl  c2 char (2);
 301 
 302 dcl  start fixed bin (21);
 303 dcl  in_iteration fixed bin;
 304 
 305 
 306                in_iteration = 0;                            /* Not inside ()'s */
 307                bad_macro = "0"b;                            /* No known problems, don't trash def. */
 308                condthread = -1;                             /* Not in []'s */
 309                condlevel = 0;                               /* Zero levels of outsdg []'s */
 310                macro_len = amacrolen;                       /* random arg copy, is remaining source len. */
 311 
 312                eb_data_$macro_linect = 1;                   /* Triggers inputs_ to increment this,
 313                                                                and prwrd_ to print it when > 0. */
 314                mbptr = ptr (bct.segarray (1), bct.macfree); /* This is where def block goes. */
 315                macro.name = mname;                          /* Copy name to defblock */
 316 
 317                mp = mpstart;                                /* Copy to automatic */
 318                macro.sourcep = mp;                          /* All parms in def block rel to this value */
 319 
 320                almpos, macro.startchar = cistart;           /* Almpos for deferr, startchar for experr. */
 321                lasteralmpos = -1;                           /* For deferr. */
 322                ci = cistart - 1;                            /* Prime scan. */
 323 
 324 /* Break up macro definition text into control sequences separated by text. Each element in
 325    macro.entry defines a control sequence and the text preceding it. */
 326 
 327                do entry_no = 1 by 1;                        /* iterate until macro defined */
 328 
 329 /* Locate the next &--- countrol sequence. If there's none, &end must be missing. */
 330 
 331                     start = ci+1;                           /* get start of the current element */
 332                     t = index (substr (ml, start), "&");
 333                     if t = 0 | t = macro_len - start + 1 then do;
 334                          call deferr ("No &end");
 335                          go to FIN_MACRO;
 336                     end;
 337 
 338                     ci = ci + t;
 339 
 340                     macro.entry (entry_no).first_char = start;
 341 
 342 /* Encode the location (rel to macro.sourcep) and length (could be 0) of fixed text which
 343    PRECEDES control sequence, for each sequence. */
 344 
 345                     macro.entry (entry_no).n_chars = ci-start;
 346 
 347                     c = substr (ml, ci+1, 1);               /* copy next character -- might be argument number */
 348                     si = 2;                                 /* More general case */
 349 
 350                     type = index (MEXP_CTL_CHARS, c);       /* Find type index */
 351                     if type <= type_NORMAL then do;
 352                          type = type_NORMAL;                /* Try for number> */
 353                          si = 1;
 354                          macro.entry (entry_no).value_1 = get_numeric_value_could_be_0 ();
 355                          if ^found_number then do;
 356                               if substr (ml, ci, 4) = "&end" then go to FIN_MACRO;
 357                               t = index (COMPARISON_CHARS, c);
 358                               if t > 0 then go to compare_op;
 359                               else call deferr_g ("Undefined substitution type: &^a", c);
 360                          end;
 361                          if macro.entry (entry_no).value_1 = 0 then call deferr_g ("&0 is not supported");
 362                          ci = ci - 1;                       /* Back up  a little. */
 363                     end;
 364                     else if index (TRIVIAL_ENCODES, c) > 0 then; /* All work done here. */
 365                     else if type = type_ITERATE then if in_iteration <= 0 then
 366                               call deferr_g ("""&i"" occured outside of iteration bounds");
 367                          else;
 368                     else if type = type_COMPARE then do;
 369 compare_op:              c2 = substr (ml, ci + 1, 2);
 370                          if c2 = "^=" | c2 = ">=" | c2 = "<=" then ci = ci + 1;
 371                          if c = "^" & c2 ^= "^=" then
 372                               call deferr_g ("Illegal conditional construct: &^a", c2);
 373                          if substr (c2, 2, 1) ^= "=" then substr (c2, 2, 1) = " ";
 374                          macro.entry (entry_no).value_1 = (index (COMPARISON_ENCODE, c2) + 1)/2;
 375                          type = type_COMPARE;
 376                     end;
 377                     else if type = type_STARTCOND then do;  /* [ */
 378                          if condlevel >= hbound (condstack, 1) then
 379                               call deferr_g ("Conditional depth exceeds ^d", hbound (condstack, 1));
 380                          condlevel = condlevel + 1;
 381 
 382 /* Save previous cond-thread in condstack at appropriate level. Start a thread of ['s and ;'s at this
 383    level, so that we can back-fill entry.val_1 in [ or ; to next ; or ], so expander can skip. */
 384 
 385                          condstack (condlevel) = condthread;
 386                          condthread = entry_no;
 387                     end;
 388                     else if type = type_ENDCOND then do;    /* ] */
 389                          if condlevel = 0 then call deferr_g ("Unbalanced brackets");
 390                          macro.entry (condthread).value_1 = entry_no;
 391                          macro.entry (entry_no).value_1 = -1;
 392                          condthread = condstack (condlevel);
 393                          condlevel = condlevel - 1;
 394                          if in_iteration >0 & condlevel + 1 = itercondlevel then go to icerr;
 395                     end;
 396                     else if type = type_ELSE then do;       /* ; */
 397                          if condlevel = 0 then call deferr_g ("Semicolon outside of brackets");
 398                          macro.entry (condthread).value_1 = entry_no;
 399                          condthread = entry_no;
 400                          if in_iteration > 0 & itercondlevel = condlevel then go to icerr;
 401                     end;
 402                     else if type = type_OPEN then do;       /* Start of iteration */
 403                          save_free = entry_no;
 404                          macro.entry (entry_no).value_1 = get_numeric_value ();
 405                          if in_iteration > 0 then call deferr_g ("Illegal recursive iteration");
 406                          in_iteration = 1;
 407                          itercondlevel = condlevel;
 408                     end;
 409                     else if type = type_CLOSE then do;      /* end of iteration */
 410                          in_iteration = in_iteration - 1;
 411                          if in_iteration < 0 then call deferr_g ("Unbalanced iteration clause");
 412                          if itercondlevel ^= condlevel then
 413 icerr:                        call deferr_g ("Illegal intertwining of conditionals and iteration");
 414                          macro.entry (entry_no).value_1 = save_free;
 415                          macro.entry (save_free).value_2 = entry_no;
 416                     end;
 417                     else if type = type_COMMAND_ARG | type = type_LENGTH
 418                                                             /* Required simple number, &A, &l */
 419                     then macro.entry (entry_no).value_1 = get_numeric_value ();
 420                     else if type = type_NULL
 421                     then macro.entry (entry_no).n_chars = macro.entry (entry_no).n_chars + 1;
 422 
 423                     else if type = type_FARGS_MACRO | type = type_FARGS_ITER then do; /* sequence of args */
 424                          c = substr (ml, ci + 2, 1);
 425                          if c = "q" | c = "Q" then do;
 426                               ci = ci + 1;
 427                               macro.entry (entry_no).value_2 = 1;
 428                          end;
 429                          else macro.entry (entry_no).value_2 = 0;
 430                          macro.entry (entry_no).value_1 = get_numeric_value ();
 431                          if type = type_FARGS_ITER & in_iteration <= 0 then call deferr_g ("&f used outside of iteration");
 432                     end;
 433                     else call genabort ("ALM internal problem. Contact assembler maintainers.");
 434 
 435 deferr_nlexit:      macro.entry (entry_no).type = type;
 436                     ci = ci + 1;
 437 
 438                end;
 439 
 440 
 441 FIN_MACRO:
 442                if in_iteration ^= 0 then call deferr ("Unbalanced iteration");
 443                if condlevel > 0 then call deferr ("Unbalanced conditional");
 444                cifin = ci + 1;                              /* Prime the loop */
 445                macro.sourcelen = cifin - cistart + 1;       /* Used by experr to count lines */
 446 
 447 /* Figure out where ALM input scanner is, in case deferr ran some statements by, and run all
 448    remaining ALM statements in macro definition by, until the statement with the &end has been run by. */
 449 
 450                call get_ptrs;                               /* set ci to 1st char after invoc */
 451                do while (tp = mpstart & cifin >= ci);
 452                     call inputs_$run_statement;             /* Skip stuff for ALM */
 453                     ciprev = ci;                            /* save beginning of line previous line */
 454                     call get_ptrs;
 455                end;
 456                eb_data_$macro_linect = 0;                   /* no more macrodef */
 457 
 458                macro.entry (entry_no).n_chars = macro.entry (entry_no).n_chars - (cifin - ciprev) + 1;
 459                                                             /* This causes partial line to &end to be skipped. */
 460                if bad_macro then do;                        /* Any problems => null definition */
 461                     entry_no = 1;
 462                     macro.entry (1).n_chars = 0;
 463                end;
 464 
 465                macro.entry (entry_no).type = type_NULL;     /* indicates no expansion */
 466                macro.num_entries = entry_no;
 467                macro.next_macro = bct.macroptr (hashx);
 468 
 469 /* Thread macro definition into correct hash bucket. */
 470 
 471                bct.macroptr (hashx) = mbptr;
 472                bct.macfree = fixed (rel (addr (macro.entry (entry_no + 1))));
 473                return;
 474 
 475 
 476 get_numeric_value: proc returns (fixed bin);
 477 
 478                     return (max (1, get_numeric_value_could_be_0 ()));
 479 
 480                end get_numeric_value;
 481 
 482 get_numeric_value_could_be_0: proc returns (fixed bin);
 483 
 484 /* Collect up-to-3-digit decimal number at il|ci+(1 0r 2) to that + 2. */
 485 
 486 dcl  c char (1) aligned;
 487 
 488                     i = 0;                                  /* initialize return value */
 489                     found_number = "0"b;
 490                     do ci = ci to ci+2;
 491                          c = substr (ml, ci+si, 1);
 492                          if c < "0" | c > "9" then go to r;
 493                          found_number = "1"b;
 494                          i = i*10 + bin (unspec (c), 9) - 48;
 495                     end;
 496 r:                  if i > hbound (args, 1) then do;
 497                          call deferr ("Definition time parameter (^d) may not be larger than ^d", i, hbound (args, 1));
 498                          i = 0;
 499                     end;
 500                     return (i);
 501 
 502                end;
 503 
 504 /* ^L */
 505 
 506 deferr:        proc options (variable, non_quick);          /* general def error. */
 507 
 508 /* Report any problem in definition. Run ALM past any statments in definition that haven't been
 509    so run yet, so that D error comes out on right line. Set "bad_macro" sw, so that null
 510    definition results, so expander won't blow up on known bad definition. Calling deferr_g
 511    causes non-local go-to to next definition control sequence. */
 512 
 513                     gsw = "0"b;
 514 
 515 deferr_g:           entry options (variable);
 516 
 517 
 518 dcl  jx fixed bin (21), cha char (1);
 519 dcl  gsw bit (1) init ("1"b);
 520 
 521                     call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, cbuf1, cb1l, "0"b, "0"b);
 522                                                             /* generate remark */
 523 
 524                     do while ("1"b);
 525                          jx = search (substr (ml, almpos), TERMS);
 526                          if jx = 0 then cha = NL; else cha = substr (ml, almpos + jx - 1, 1);
 527                          if cha = NL & almpos + jx > ci then do;
 528                               eb_data_$erflgs_overlay.prntd = 1;
 529                               if lasteralmpos ^= almpos then call inputs_$run_statement;
 530                               eb_data_$erflgs_overlay.prntd = 0; /* could be pass 1, ya know */
 531                                                             /* so keep errs off coll. tape */
 532                               lasteralmpos = almpos;
 533                               bad_macro = "1"b;
 534                               call prnter_$macro_error
 535                                    ("Macro definition error: " || cb1b || " in macro " || rtrim (macro.name) || ".",
 536                                    "**** **** **** ERROR IN MACRO DEFINITION: " || cb1b || ".");
 537                               if gsw then go to deferr_nlexit;
 538                               else return;
 539                          end;
 540                          if lasteralmpos ^= almpos then call inputs_$run_statement;
 541                          almpos = almpos + jx;
 542                     end;
 543 
 544                end deferr;
 545 
 546           end define_macro;
 547                                                             /* ^L */
 548 mexp_$mexp_: entry (a_opcode, errflag, target_value, no_target_given, first_time_thru );
 549              dcl a_opcode            char(*),
 550                  errflag             fixed bin(1),
 551                  target_value        fixed bin(17),
 552                  (no_target_given,
 553                  first_time_thru)     bit (1),      parameter;
 554 
 555 /* Called by pass1_/pass2_. The input scanner (inputs_) has scanned an opcode, and the break after it.
 556    ALM opcode-looker (oplook_) does not know, or claims not to know about the opcode. Value of
 557    opcode is a parameter to us. The vbl "errflag" is used to tell ALM that we never heard of it
 558    either. Target_value comes all the way from alm_ and is used to decide iftarget conditionals. */
 559 
 560 
 561           opcode = a_opcode;                                /* Get into stack */
 562           errflag = 0;                                      /* Set up for ALM. */
 563           envp = eb_data_$mexp_env_ptr;
 564           semict = 0;                                       /* ALM lines to skip */
 565 
 566           call get_ptrs;
 567           var_start = -1;                                   /* Set up for no var field */
 568           if ^alm_finished_the_line then do;                /* If line not done, ... */
 569                call skip_to_next_line;
 570 
 571                ci = start;                                  /* initialize scanning index */
 572                call sob;                                    /* skip over blanks */
 573 
 574                c = substr (il, ci, 1);                      /* pick up the next character of the line */
 575 
 576                if ^(c = QUOTE | c = NL | c = ";") then do;
 577                     var_start = ci;                         /* save start of var field */
 578                     call soc;                               /* skip over non-white characters */
 579                     var_end = ci - 1;                       /* save last char of variable field */
 580                     if ci > stop then var_end = var_end - 1;
 581                end;
 582           end;
 583 
 584 /* See if the opcode is a macro name */
 585 
 586           call get_hashx (opcode);
 587 
 588           do mbptr = bct.macroptr (hashx) repeat macro.next_macro while (mbptr ^= null);
 589                if macro.name = opcode then do;              /* we have found a macro to expand */
 590                     call make_new_outbuf;
 591                     call expand_macro;                      /* mbptr implied arg */
 592                     call push_mexp_output_upon_alm;
 593                     return;
 594                end;
 595           end;
 596 
 597 
 598 /* ^L */
 599 /* See if the opcode is conditional-assembly pseudo-op */
 600 
 601           if opcode = "ife" | opcode = "ine" | opcode = "ifarg" | opcode = "ifint" | opcode = "inint"
 602           | opcode = "inarg" | opcode = "iftarget" | opcode = "intarget" then do;
 603 
 604 /* Get extents of argument list, collect them. Run ALM past all of argument-list statements. */
 605 
 606                iftarget_cond = substr (opcode, 3) = "target";
 607                if var_start < 0 then goto BAD_PSEUDO;       /* must have args for INE and IFE */
 608                call make_new_outbuf;
 609                j = index (substr (il, stop), "ifend");      /* search for end of conditional data */
 610                if j <= 0 then do;                           /* bad use of pseudo-op */
 611 BAD_PSEUDO:         eb_data_$erflgs_overlay.prntf = 1;
 612                     return;
 613                end;
 614                if bct.curlevel = 0 then call inputs_$next_statement;
 615                else call inputs_$next_statement_nolist;
 616                end_index = stop + j;                        /* save position of ifend */
 617                call scan_args (ifargs, no_ifargs, var_start, var_end-var_start+1, code);
 618                do j = 1 to semict;
 619                     if bct.curlevel = 0 then call inputs_$run_statement;
 620                     else call inputs_$run_statement_nolist;
 621                end;
 622                if code ^= 0 then go to BAD_PSEUDO;
 623 
 624 /* Based upon the opcode, figure out if code is to be skipped or output. Set "match" accordingly. */
 625 
 626                targ = substr (il, ifargs (1).start, ifargs (1).len);
 627                if opcode = "ifarg" | opcode = "inarg" then do; /* Check command arg */
 628                     match = "0"b;                           /* default is no match */
 629                     do ia = eb_data_$mexp_argno + 1 to eb_data_$alm_arg_count while (^match);
 630                          temp_ap = arguments(ia).arg_ptr;
 631                          temp_al = arguments(ia).arg_len;
 632                          if input_arg = targ then match = "1"b;
 633                     end;
 634                     if opcode = "inarg" then match = ^match;
 635                end;
 636                else if opcode = "ifint" | opcode = "inint" then do;
 637                     discard = cv_dec_check_ ((targ), code); /* check for decimal number */
 638                     match = (code = 0);                     /* match if arg is decimal integer */
 639                     if opcode = "inint" then match = ^match;
 640                end;
 641                else if opcode = "iftarget" | opcode = "intarget" then do;
 642 
 643                     if no_target_given
 644                         then do;
 645                                 if tpass1 = 1
 646                                      then prnta = 1;
 647                                 target_value = L68_SYSTEM;
 648                                 if first_time_thru
 649                                      then do;
 650                                            call com_err_(0,eb_data_$who_am_I,"Attempted use of ""iftarget"" or ""intarget"" without providing a value via ""-target"".");
 651                                            first_time_thru = "0"b;
 652                                           end;
 653                              end;
 654                     iftarget_str = targ;
 655                     call system_type_((iftarget_str),(""),iftarget_value,iftarget_error);
 656                     if iftarget_error ^=0 & tpass1 = 1
 657                         then do;
 658                                 eb_data_$erflgs_overlay.prntf = 1;
 659                                 iftarget_value = L68_SYSTEM;
 660                              end;
 661                     match = (target_value = iftarget_value);
 662                     if opcode = "intarget"
 663                         then match = ^match;
 664                end;
 665                else do;
 666                     if targ = substr (il, ifargs (2).start, ifargs (2).len) then
 667                     match = "1"b; else match = ""b;
 668                     if opcode = "ine" then match = ^match;  /* inverse meaning for INE case */
 669                end;
 670 
 671 /* Having figured out whether code will be skipped or output, run ALM past the conditional
 672    code, outputting ALM statements if code is to be output. */
 673 
 674                call skip_to_next_line;                      /* Prime the loop. */
 675                do while (stop <= end_index);                /* Stop when ifend line eaten. */
 676                     if ^match & iftarget_cond then call outptr (addr (QUOTE), 1);
 677                     if match | iftarget_cond then call outptr (substaddr (il, start), stop - start + 1);
 678                     call skip_to_next_line;
 679                     call inputs_$run_statement_nolist;
 680                end;
 681                call inputs_$run_statement_nolist;
 682                if iftarget_cond then do;
 683                     call outptr (addr (QUOTE), 1);
 684                     call outptr (substaddr (il, start), stop - start + 1);
 685                end;
 686                if substr (il, end_index + 4, 5) = "_exit" & match & bct.curlevel > 0
 687                then do;                                     /* pop curr. macro. */
 688 
 689 /* This  save-and-restore song and dance is needed for the following reason: Calling
 690    alm_include_file$pop will cause the top regnant expansion (the one the ifend_exit alludes to)
 691    to pop available buffer space to start below that expansion, which is below the
 692    expansion we just produced, which isn't regnant yet.  We can't push our ife output
 693    until this old thing is off the stack, or they'd pop in the wrong order. */
 694 
 695                     save_segx = bct.curexpseg;
 696                     save_charx = bct.segarray_free (save_segx);
 697                     call alm_include_file_$pop;             /* pop mexp and alm */
 698                     save_segx1 = bct.curexpseg;
 699                     save_charx1 = bct.segarray_free (save_segx1);
 700                     save_curlev = bct.curlevel;
 701                     bct.curexpseg = save_segx;
 702                     bct.segarray_free (save_segx) = save_charx;
 703                     call push_mexp_output_upon_alm;         /* Do it. */
 704                     if bct.curlevel ^= save_curlev then do; /* Make it ss that pop this pops hole. */
 705                          bct.outstack (bct.curlevel).segx = save_segx1;
 706                          bct.outstack (bct.curlevel).charx = save_charx1;
 707                     end;
 708                     return;
 709                end;
 710                call push_mexp_output_upon_alm;
 711                return;
 712           end;
 713 
 714 /* ^L */
 715 
 716 
 717           if opcode = "warn" then do;                       /* Assembly-time msg */
 718                if var_start > 0 then call scan_args (args, nargs, var_start, var_end - var_start +1, code);
 719                else args (1).len = 0;
 720                if var_start ^> 0 | code ^= 0 then eb_data_$erflgs_overlay.prntf = 1;
 721                call inputs_$next_statement;
 722                do j = 1 to semict;
 723                     call inputs_$run_statement;
 724                end;
 725                temp_ap = addr (arg_1); temp_al = length (arg_1);
 726                                                             /* This little bit of obscurity
 727                                                                keeps substaddr from being non-quicked,
 728                                                                cause compiler would call it after
 729                                                                stack was extended for catenate. */
 730                call prnter_$macro_error (SIGNATURE || input_arg, input_arg);
 731                return;
 732           end;
 733 
 734 
 735 /* No macros or pseudos match, return an error. */
 736 
 737           errflag = 1;
 738           return;
 739 
 740 /* ^L */
 741 
 742 expand_macro: procedure;
 743 
 744 /* The value of "opcode" has been found to be a macro name. The vbl "mbptr" points
 745    to the macro definition block.  The output buffer "ob" has been setup. Run ALM
 746    past the invocation, and produce the expansion into ob. */
 747 
 748 dcl  selector_eno fixed bin;
 749 dcl  tcode fixed bin (35);
 750 dcl  arg_offset fixed bin;
 751 dcl (outstanding_select, outstanding_range) bit (1);
 752 dcl (selector_ob_charpos, range_ob_charpos) fixed bin (21);
 753 dcl  select_answer fixed bin;
 754 dcl  found_d_error_lying_there bit (1);
 755 
 756                mp = macro.sourcep;
 757                outstanding_select, outstanding_range = "0"b;
 758                found_d_error_lying_there = (eb_data_$erflgs_overlay.prntd ^= 0);
 759                                                             /* If this is pass2, all errors that we are going to find
 760                                                                were already found by us in pass1,  and collated
 761                                                                on coll. tape entry for 1st sta of invoc. */
 762                call inputs_$next_statement;                 /* Skip over first line of invocation. */
 763 
 764                if bct.unique_changed then do;               /* did we use it last macro? */
 765                     bct.unique_generator1 = bct.unique_generator1 + 1;
 766                     bct.unique_changed = ""b;
 767                end;
 768 
 769 /* Now pick off any args from the input source, save pointers to them */
 770 
 771                if var_start > 0 then call scan_args (args, nargs, var_start, var_end-var_start+1, tcode);
 772                else args (*).len, nargs, tcode = 0;
 773 
 774                do j = 1 to semict;                          /* Run ALM over breaks scan_args saw. */
 775                     call inputs_$run_statement;
 776                end;
 777                if tcode ^= 0 then do;
 778                     eb_data_$erflgs_overlay.prntf = 1;
 779                     return;
 780                end;
 781                args.len (0) = 0;                            /* For good luck. */
 782                iterate = 0;                                 /* in case &x is used and iteration isn't */
 783 
 784 /* Now expand each element in array- first the text, then the expansions. */
 785 
 786                do entry_no = 1 to macro.num_entries;
 787                     call outptr (substaddr (ml, (macro.entry (entry_no).first_char)),
 788                          (macro.entry (entry_no).n_chars));
 789                     val = macro.entry (entry_no).value_1;   /* extract value for this type of element */
 790                     type = macro.entry (entry_no).type;     /* also extract type of element */
 791                     if type < 1 | type > type_MAXTYPE then
 792                          call genabort ("ALM internal error. Contact assembler maintainers.");
 793                     go to XP (type);
 794 XP (1):                                                     /* Normal argument expansion (&1, &2, etc.) */
 795                     if val <= nargs
 796                     then call outptr (substaddr (il, args.start (val)), args.len (val));
 797                     go to A;
 798 
 799 XP (2):                                                     /* Previous unique (&p) */
 800                     i = bct.unique_generator;
 801                     go to UNIQUE;
 802 XP (3):                                                     /* Unique symbol (&u) */
 803                     bct.unique_generator = bct.unique_generator + 1;
 804                     i = bct.unique_generator;               /* get value for symbol */
 805 UNIQUE:             call ouch ("...");
 806 UNIQUE1:            vc = convert_binary_integer_$octal_string (i + 1e27b); /* convert to char */
 807                     call ouch (substr (vc, 6, 5));
 808                     go to A;
 809 XP (4):                                                     /* next unique (&n) */
 810                     i = bct.unique_generator + 1;
 811                     go to UNIQUE;
 812 XP (5):                                                     /* iterate arg (&i) */
 813                     call outptr (substaddr (il
 814                          , iterargs (iterate + arg_offset).start),
 815                          iterargs (iterate + arg_offset).len);
 816                     go to A;
 817 XP (6):                                                     /* Start of iteration (&() */
 818                     save_free = entry_no;
 819                     iterate = 1;                            /* Value of &x, index ito iter set. */
 820                     if outstanding_range then do;           /* &R was used, iter over mac arglist. */
 821                          iap = addr (args);                 /* use real args */
 822                          call get_ob_rangeargs (arg_offset, no_exargs);
 823                          if arg_offset > 0 then arg_offset = arg_offset - 1;
 824                          if no_exargs = 0 then no_exargs = 99999;
 825                          else if no_exargs < arg_offset - 1 then no_exargs = 1;
 826                          else no_exargs = no_exargs - arg_offset;
 827                          no_exargs = min (no_exargs, nargs - arg_offset);
 828                     end;
 829                     else do;                                /* No &R, iterate over pieces of macro arg */
 830                          iterate_arg_no = val;
 831                          i = args (iterate_arg_no).len;
 832                          if i > 0 then do;
 833                               call scan_args (exargs, no_exargs, args (iterate_arg_no).start, i, tcode);
 834                               if tcode ^= 0 then call experr
 835                                    ("Internal unbalanced parentheses in arg ^d in iteration", iterate_arg_no);
 836                          end;
 837                          else no_exargs = 0;                /* null arg => no iterations */
 838                          iap = addr (exargs);
 839                          arg_offset = 0;
 840                     end;
 841 ANY_ARGS_Q:         if no_exargs < iterate then
 842                          entry_no = macro.entry (save_free).value_2;
 843                     go to A;
 844 XP (7):                                                     /* End of iteration (&)) */
 845                     iterate = iterate + 1;
 846                     entry_no = save_free;
 847                     go to ANY_ARGS_Q;
 848 XP (8):                                                     /* Iteration index (&x) */
 849                     call outnum ((iterate));
 850                     go to A;
 851 XP (9):                                                     /* Special unique (&U) */
 852                     i = bct.unique_generator1;
 853                     call ouch (".._");
 854                     bct.unique_changed = "1"b;
 855                     go to UNIQUE1;
 856 XP (10):                                                    /* Command arg (&A) */
 857                     if val <= eb_data_$mexp_argno | val > eb_data_$alm_arg_count then code = error_table_$noarg;
 858                     else do;
 859                          temp_ap = arguments(val + eb_data_$mexp_argno).arg_ptr;
 860                          temp_al = arguments(val + eb_data_$mexp_argno).arg_len;
 861                          call outptr (temp_ap, temp_al);
 862                       end;
 863                     go to A;
 864 XP (11):                                                    /* Arg length (&l) */
 865                     call outnum (args (val).len);
 866                     go to A;
 867 XP (12):                                                    /* Number of args (&K) */
 868                     call outnum ((nargs));
 869                     go to A;
 870 XP (13):                                                    /* Number of iteration args (&k) */
 871                     call outnum ((no_exargs));
 872                     go to A;
 873 XP (14):                                                    /* Null expansion (&& or end of macro) */
 874                     go to A;
 875 XP (15):                                                    /* Comparison ops */
 876 XP (19):                                                    /* Selector ops (&s)  */
 877                     if outstanding_select then call experr ("Unused selection");
 878                     outstanding_select = "1"b;
 879                     selector_ob_charpos = next;             /* Save for evaluator. */
 880                     selector_eno = entry_no;
 881                     go to A;
 882 XP (16):                                                    /* Open conditional (&[) */
 883                     if ^outstanding_select then do;
 884                          call experr ("Brackets with no previous selector operation");
 885                          select_answer = 1;
 886                     end;
 887                     else call pull_apart_select_input;
 888                     do i = 1 by 1 while (i < select_answer);
 889                          if macro.entry (entry_no).value_1 <= 0 then i = select_answer;
 890                          else entry_no = macro.entry (entry_no).value_1;
 891                     end;
 892                     go to A;
 893 XP (17):                                                    /* End of conditional (&])  */
 894                     go to A;
 895 XP (18):                                                    /* Select else (&;) */
 896                     do entry_no = entry_no repeat (macro.entry (entry_no).value_1)
 897                               while (macro.entry (entry_no).value_1 > 0);
 898                     end;
 899                     go to A;
 900 XP (20):                                                    /* Fargs-macro (&F)  */
 901                     call output_fargs (args, nargs);
 902                     go to A;
 903 XP (21):                                                    /* Fargs-iter (&f) */
 904                     call output_fargs (exargs, no_exargs);
 905                     go to A;
 906 XP (22):                                                    /* Iter over args. (&R) */
 907                     if outstanding_range
 908                     then call experr ("Unused range specifier");
 909                     outstanding_range = "1"b;
 910                     range_ob_charpos = next;
 911                     go to A;
 912 A:
 913                end;
 914 
 915                return;
 916 
 917 /* ^L */
 918 output_fargs:  proc (aaray, ct);
 919 
 920 /* Used to output sequence of args, for &F and &f requests. val2 is 1 for FQ/fq */
 921 
 922 
 923 dcl 1 aaray (0:99) aligned,
 924     2 start fixed bin (21),
 925     2 len fixed bin (21);
 926 
 927 dcl  ct fixed bin;
 928 dcl  qsw bit (1);
 929 dcl  k fixed bin;
 930 
 931                     qsw = (macro.entry (entry_no).value_2 = 1);
 932                     do k = macro.entry (entry_no).value_1 to ct by 1;
 933                          if qsw then call ouch ("(");
 934                          call outptr (substaddr (il, aaray (k).start), (aaray (k).len));
 935                          if qsw then call ouch (")");
 936                          if k < ct then call ouch (",");
 937                     end;
 938                end output_fargs;
 939 
 940 /* ^L */
 941 
 942 pull_apart_select_input: proc;                              /* Gets stuff out of output buffer to make selector clauses. */
 943 
 944 /* Used to get whatever input is needed out of expansion (ob) for &[. Defines based/adjustable "ebuf"
 945    as portion of ob between where it was when selector appeared (selector_ob_charpos) and the &[. */
 946 
 947 dcl  ep ptr, ebuf char (elen) based (ep), elen fixed bin (21);
 948 dcl (s, t1, t2) fixed bin;
 949 dcl  comx fixed bin;
 950 
 951                     ep = substaddr (ob, selector_ob_charpos);
 952                     elen = length (currob) - selector_ob_charpos + 1;
 953 
 954                     if macro.entry (selector_eno).type = type_SELECT then
 955                          select_answer = collect_ob_num (1, elen);
 956                     else do;
 957                          comx = index (ebuf, ",");
 958                          if comx = 0 then do;
 959                               call experr ("No comma for conditional after expansion");
 960                               select_answer = 0;
 961                          end;
 962                          else do;
 963                               s = macro.entry (selector_eno).value_1; /* Type of comparison */
 964                                                             /* Remember that EQ and NE are char, others num. */
 965                               if s <= NE then do;           /* String compares, &=, &^= */
 966                                    if substr (ebuf, 1, comx - 1) = substr (ebuf, comx + 1) then select_answer = 1;
 967                                    else select_answer = 2;
 968                                    if s = NE then select_answer = 3 - select_answer; /* NE inverts test */
 969                               end;
 970                               else do;                      /* Numeric compares, EQ and NE dont get used. */
 971                                    t1 = collect_ob_num (1, comx - 1);
 972                                    t2 = collect_ob_num (comx + 1, elen);
 973                                    if ((t1 = t2) & s = EQ) | ((t1 ^= t2) & s = NE) | ((t1 < t2) & s = LT)
 974                                    | ((t1 <= t2) & s = LE) | ((t1 > t2) & s = GT) | ((t1 >= t2) & s = GE)
 975                                    then select_answer = 1;  /* TRUE */
 976                                    else select_answer = 2;  /* FALSE */
 977                               end;
 978                          end;
 979                     end;
 980                     next = selector_ob_charpos;
 981                     outstanding_select = "0"b;
 982                     return;
 983 
 984 get_ob_rangeargs:   entry (v1, v2);                         /* collect m and n, as in &Rm,n into v1, v2 */
 985 
 986 dcl (v1, v2) fixed bin;
 987 
 988                     ep = substaddr (ob, range_ob_charpos);
 989                     elen = length (currob) - range_ob_charpos + 1;
 990                     comx = index (ebuf, ",");
 991                     if comx = 0 then comx = elen + 1;
 992                     v1 = collect_ob_num (1, comx - 1);
 993                     v2 = collect_ob_num (comx + 1, elen);
 994                     next = range_ob_charpos;
 995                     outstanding_range = "0"b;
 996                     return;
 997 
 998 /* ^L */
 999 collect_ob_num:     proc (fx, lx) returns (fixed bin);
1000 
1001 /* This routine collects a decimal number at ebuf|fx until ebuf|lx, returning it. Note
1002    that cases of no digits, bad input, and large number of leading zeros are handled. */
1003 
1004 dcl (i, fx, lx) fixed bin (21);
1005 dcl  d fixed bin init (0), c char (1) aligned;
1006 
1007                          do i = fx to lx;
1008                               c = substr (ebuf, i);
1009                               if c < "0" | c > "9" then do;
1010                                    call experr ("Bad numeric input to selector");
1011                                    return (0);
1012                               end;
1013                               d = 10*d + fixed (unspec (c), 9) - 48;
1014                          end;
1015                          return (d);
1016 
1017                     end collect_ob_num;
1018 
1019                end pull_apart_select_input;
1020 
1021 experr:        proc options (variable, non_quick);          /* expansion error */
1022 
1023 /* Called by all expansion-time errors with formline_ arguments.   Tries to figure out what
1024    _^Hl_^Hi_^Hn_^He of macro def contains the  error, as ALM lists the expanded lines way after we have
1025    the whole expansion out the door, and user needs some hint.  For this purpose
1026    only is macro.startchar maintained. */
1027 
1028 
1029 dcl  apos fixed bin (21), alct fixed bin (18);
1030 dcl  vs char (200) varying;
1031 dcl  nlx fixed bin (21);
1032 dcl  mdef char (macro.sourcelen + macro.startchar - 1) based (macro.sourcep);
1033 dcl  zzzzz9 pic "zzzzz9";
1034 dcl  errpos fixed bin (21);
1035 
1036                     if ^found_d_error_lying_there           /* if this is news, .e., pass 1 */
1037                     then eb_data_$erflgs_overlay.prntd = 1; /* then make an error */
1038 
1039                     call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, cbuf1, cb1l, "0"b, "0"b);
1040 
1041                     errpos = macro.entry (entry_no).first_char + macro.entry (entry_no).n_chars;
1042                     apos = macro.startchar;
1043                     nlx = index (substr (mdef, apos), NL);
1044                     do alct = 1 by 1 while (^(nlx = 0 | apos + nlx > errpos));
1045                          nlx = index (substr (mdef, apos), NL);
1046                          apos = apos + nlx;
1047                     end;
1048 
1049                     zzzzz9 = alct;
1050                     vs = cb1b || " in line " || ltrim (zzzzz9) || " of macro " || rtrim (macro.name) || ".";
1051                     call prnter_$macro_error ("Macro expansion error: " || vs,
1052                          "**** **** **** MACRO EXPANSION ERROR: " || vs);
1053                     return;
1054 
1055                end experr;
1056 
1057           end expand_macro;
1058                                                             /* ^L */
1059 mexp_$reset_macro: entry;
1060 
1061 /* ALM calls this when the ALM input scanner, inputs_, runs off the end of something that was
1062    given to him by push_mexp_output_upon_alm below. */
1063 
1064 
1065           envp = eb_data_$mexp_env_ptr;
1066           call pop_mexp_level;
1067           return;
1068 
1069 
1070 push_mexp_output_upon_alm: procedure;
1071 
1072 /* Redefine free space in segment containing ob not to include ob. Stack  the description
1073    of what free space will be when this is popped (which is what it is now). Tell ALM
1074    to push the string "ob" upon its input stack. ALM will call mexp_$reset_macro
1075    when he (the input scanner, inputs_) runs off the end of it. */
1076 
1077 
1078                if bct.curlevel >= hbound (bct.outstack, 1) then
1079                     call genabort ("Macro depth exceeds ^d.", bct.curlevel);
1080                if length (currob) <= 0 then return;         /* Don't output empty buffers */
1081                if substr (currob, length (currob), 1) ^= NL then call ouch (NL);
1082                                                             /* Make sure lines dont spill, listing happens. */
1083                call alm_include_file_$macro (addr (currob), length (currob));
1084                bct.curlevel = bct.curlevel + 1;
1085                bct.outstack (bct.curlevel).segx = bct.curexpseg;
1086                bct.outstack (bct.curlevel).charx = bct.segarray_free (bct.curexpseg);
1087                bct.segarray_free (bct.curexpseg) = bct.segarray_free (bct.curexpseg) + length (currob);
1088                return;
1089 
1090           end push_mexp_output_upon_alm;
1091 
1092 pop_mexp_level: procedure;
1093 
1094 /* Return current expansion's space to free space in its segment. If this brings us
1095    to bottom of segment other than the first, go back a segment, for free space now starts
1096    there. */
1097 
1098 
1099                if bct.curlevel = 0 then
1100                     call genabort ("Macro stack underflow. Contact assembler maintainers.");
1101 
1102                bct.curexpseg = bct.outstack (bct.curlevel).segx;
1103                bct.segarray_free (bct.curexpseg) = bct.outstack (bct.curlevel).charx;
1104                bct.curlevel = bct.curlevel - 1;
1105                if bct.curexpseg > 2 & bct.segarray_free (bct.curexpseg) = 1
1106                then bct.curexpseg = bct.curexpseg - 1;
1107                return;
1108 
1109           end pop_mexp_level;
1110 
1111 
1112 /* ^L */
1113 
1114 
1115 /* This procedure, with all its entries, generates all text in the
1116    output buffer, ob. It takes responsibility for moving it when it
1117    must be grown. */
1118 
1119 outptr:   proc (aoutp, aoutl);                              /* Output aoutp->char(aoutl) to ob */
1120 
1121 dcl (aoutp, outp) ptr;
1122 dcl  outstring char (outl) based (outp);
1123 dcl  save_obp ptr, save_obl fixed bin (21);
1124 dcl (aoutl, outl) fixed bin (21);
1125 dcl  str char (*);
1126 dcl  num fixed bin (21);
1127 dcl  zzzzzzz9 picture "zzzzzzz9";
1128 dcl  cbuf char (8);
1129 
1130                outl = aoutl;
1131                outp = aoutp;
1132                go to outpr_join;
1133 
1134 ouch:          entry (str);                                 /* Output value of "str" to ob */
1135 
1136                outl = length (str);
1137                outp = addr (str);
1138                go to outpr_join;
1139 
1140 outnum:        entry (num);                                 /* Output canonical number to ob */
1141 
1142                zzzzzzz9 = num;
1143                outl = length (ltrim (zzzzzzz9));
1144                cbuf = ltrim (zzzzzzz9);
1145                outp = addr (cbuf);
1146 
1147 
1148 outpr_join:
1149                if length (outstring) = 0 then return;
1150 
1151                if length (currob) + length (outstring) > length (ob) then do;
1152                     save_obp = addr (currob);
1153                     save_obl = length (currob);
1154                     call make_new_outbuf$force;
1155                     next = save_obl + 1;
1156                     currob = save_obp -> currob;
1157                end;
1158 
1159                substr (ob, next, length (outstring)) = outstring;
1160                next = next + length (outstring);
1161 
1162                return;
1163 
1164           end outptr;
1165 
1166 /* ^L
1167 */
1168 substaddr: proc (chs, ix) returns (ptr);
1169 dcl  chxa (length (chs)) char (1) unal based;               /* for char addressing */
1170 dcl  chs char (*), ix fixed bin (21);
1171                return (addr (addr (chs) -> chxa (ix)));
1172           end substaddr;
1173 
1174 make_new_outbuf: proc;
1175 
1176 /* This procedure  defines the based/adjustable output buffer "ob" as the remainder of the
1177    current output buffer segment. If $force is called, it is because a string that
1178    outptr/ouch/outnum wants to put in ob won't fit. So ob is redefined to the next
1179    buffer segment, and the old ob copied. The vbl "next" is the next available char pos
1180    in current ob. */
1181 
1182 
1183 dcl  segx fixed bin;
1184 dcl  force bit (1);
1185 
1186                force = "0"b;
1187                go to mnob_join;
1188 
1189 make_new_outbuf$force: entry;
1190 
1191                force = "1"b;
1192 mnob_join:
1193 
1194                segx = bct.curexpseg;
1195                if force then segx, bct.curexpseg = segx + 1;
1196                if bct.segarray (segx) = null then do;
1197                     call get_temp_segments_ (gtsname, segarray_of_one, (0));
1198                     bct.segarray (segx) = segarray_of_one (1);
1199                end;
1200                obp = substaddr (bct.segarray (segx) -> ob, bct.segarray_free (segx));
1201                max_char_count = sys_info$max_seg_size * 4 - bct.segarray_free (segx) + 1;
1202                next = 1;
1203 
1204           end make_new_outbuf;
1205                                                             /* ^L */
1206 
1207 scan_args: proc (array, no_args, firstx, count, acode);
1208 
1209 /* This routine scans the "count" chars at il|firstx according to the rules of
1210    macro arguments. Processing of nested parens, line breaks and continuations, and
1211    commas is all done here. */
1212 
1213 
1214 dcl 1 array (0: 99) aligned,
1215     2 first fixed bin (21),
1216     2 size fixed bin (21);
1217 
1218 dcl  acode fixed bin (35);
1219 
1220 dcl  c2 char (2) aligned;
1221 
1222 dcl  no_args fixed bin,
1223     (firstx, count, arg_start, last) fixed bin (21);
1224 
1225                array (*).size = 0;
1226                acode = 0;
1227                arg_start, ci = firstx;
1228                last = ci + count - 1;
1229                no_args = 0;
1230 GET_ANOTHER_ARG:
1231                c2 = substr (il, ci-1, 2);
1232                if c2 = COMMA_NL | c2 = ", " | c2 = ",       " | c2 = ",""" | c2 = ",;" then do;
1233                                                             /* Continue on next ALM statement. */
1234                     if addr (array) ^= addr (exargs) then   /* At top level */
1235                          call skip_to_next_line;
1236                     else do;
1237                          stop = stop - 1;
1238                          start = ci + 1;
1239                     end;
1240                     if stop > nchars then return;
1241                     semict = semict + 1;                    /* schedule almrunning */
1242                     if stop > nchars then return;
1243                     t = verify (substr (il, start, stop-start+1), WHITE)-1; /* skip white space */
1244                     if t < 0 then ci = stop+1;
1245                     else ci = start + t;
1246                     arg_start = ci;                         /* save start of variable field */
1247                     call soc;                               /* skip to end of variable field */
1248                     if stop = ci-1 then last = ci-2;
1249                     else last = ci-1;
1250                     ci = arg_start;
1251                     goto GET_ANOTHER_ARG;
1252                end;
1253 
1254                else if substr (il, ci, 1) = "(" then do;    /* watch out for args with parens */
1255                     nparens = 1;                            /* skip till no more parens at this level */
1256                     do ci = ci+1 to last while (nparens > 0);
1257                          if substr (il, ci, 1) = "(" then nparens = nparens + 1;
1258                          else if substr (il, ci, 1) = ")" then nparens = nparens - 1;
1259                     end;
1260                     if nparens > 0 then do;
1261                          acode = 1;
1262                          return;
1263                     end;
1264 
1265                     no_args = no_args + 1;
1266                     array.first (no_args) = arg_start+1;    /* copy information about where the arg is */
1267                     array.size (no_args) = ci - arg_start - 2;
1268                     goto NEXT_ARG;
1269                end;
1270 
1271                else do;                                     /* argument didn' start with paren */
1272                     t = index (substr (il, ci, last-ci+1), ",")-1;
1273                     if t < 0 then ci = last + 1;
1274                     else ci = ci + t;
1275 
1276                     no_args = no_args + 1;
1277                     array.first (no_args) = arg_start;
1278                     array.size (no_args) = ci - arg_start;
1279 NEXT_ARG:           ci, arg_start = ci+1;
1280                     if arg_start <= last+1 then goto GET_ANOTHER_ARG;
1281                end;
1282                return;
1283 
1284 
1285           end scan_args;
1286                                                             /* ^L */
1287 
1288 
1289 skip_to_next_line: proc;
1290 
1291 /* This procedure sets "stop" to be the charindex of the last char of the
1292    (possibly multi-ALM-statement) macro or pseudoop invocation.  The
1293    only legal ALM-statement breaks are those in parens. The vbl "semict" is incremented
1294    to tell larger routines how many times to call inputs_$run/next_statement to
1295    skip ALM's input scanner (inputs_) over that many ALM statements. Note:
1296    If _^Hw_^He don't know that some semicolon-containing thing is actually an ACC string
1297    etc., ALM doesn't know _^He_^Hi_^Ht_^Hh_^He_^Hr, annd considers it a statement break, 'cause
1298    he's skipping statements, not semanticating them. */
1299 
1300 
1301                start = stop+1;                              /* get start of next line */
1302 dcl  nparens fixed bin;
1303 
1304                nparens = 0;
1305                stop = start;
1306 more:          t = search (substr (il, stop), ENDS)-1;
1307                if t < 0 then do;
1308                     stop = nchars + 1;
1309                     return;
1310                end;
1311                stop = stop + t;
1312                if substr (il, stop, 1) = "(" then nparens = nparens + 1;
1313                else if substr (il, stop, 1) = ")" then nparens = nparens - 1;
1314                else if substr (il, stop, 1) = ";" & nparens > 0 then semict = semict + 1;
1315                else if substr (il, stop, 1) = NL & nparens > 0 then semict = semict + 1;
1316                                                             /* Ignore statement breaks inside parens */
1317                else return;
1318                stop = stop + 1;
1319                go to more;
1320 
1321           end;
1322 
1323 get_hashx: procedure (name);                                /* Generate hash index */
1324 
1325 dcl  name char (32) aligned;
1326 dcl  fb35 fixed bin (35), (mod, abs) builtin;
1327 
1328                unspec (fb35) = bool (substr (unspec (name), 1, 36), bool (substr (unspec (name), 37, 36),
1329                     bool (substr (unspec (name), 73, 36), substr (unspec (name), 109, 36), "0110"b), "0110"b), "0110"b);
1330 
1331                hashx = abs (mod (fb35, 127));
1332                if ^substr (bct.hashx_used, hashx + 1, 1) then do;
1333                     substr (bct.hashx_used, hashx + 1, 1) = "1"b;
1334                     bct.macroptr (hashx) = null;
1335                end;
1336                return;
1337 
1338           end;
1339                                                             /* ^L */
1340 sob:      proc;
1341 
1342 /* This procedure moves ci to first non-white character. */
1343 
1344 
1345                t = verify (substr (il, ci, stop-ci+1), WHITE)-1;
1346                ci = ci + t;
1347                return;
1348 
1349           end;
1350 soc:      proc;
1351 
1352 /* This procedure moves ci over non-white characters to next whitespace. */
1353 
1354 
1355 dcl  nparens fixed bin;
1356 
1357                nparens = 0;
1358 more:          t = search (substr (il, ci, stop-ci+1), "()   """)-1;
1359                if t < 0 then do;
1360                     ci = stop+1;
1361                     return;
1362                end;
1363                ci = ci + t;
1364                c = substr (il, ci, 1);
1365                if c = "(" then nparens = nparens + 1;
1366                else if c = ")" then nparens = nparens - 1;
1367                else if nparens = 0 then return;
1368                ci = ci + 1;
1369                goto more;
1370 
1371           end;
1372 
1373 
1374 
1375 get_ptrs: proc;                                             /* Set mexp ptrs from ALM */
1376 
1377 /* This procedure sets our variables from ALM's input scanner, inputs_. Inputs_
1378    usually scans up to and beyond a break. We set variables to first char he hasn't
1379    scanned. "alm_finished_the_line" is inputs_'s "ibrk = inl" state, in which
1380    he has scanned the last semi/nl on a statement, but inputs_$next_statement
1381    hasn't been called yet. */
1382 
1383 
1384 dcl (offset, sourcelen) fixed bin (21);
1385 
1386                call inputs_$get_ptr (tp, offset, sourcelen, alm_finished_the_line);
1387 
1388                nchars = offset + sourcelen;
1389                stop = offset;
1390                ci, start = stop + 1;
1391                return;
1392           end get_ptrs;
1393 
1394 /* ^L */
1395 
1396 genabort: proc options (variable, non_quick);
1397 
1398                call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, cbuf1, cb1l, "0"b, "0"b);
1399                call prnter_$general_abort (cb1b);
1400           end genabort;
1401                                                             /* ^L */
1402 %include erflgs;
1403      end mexp_$ignore;