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 /* macro expander for pl/1.
  12 
  13   expmac$many expands a macro with many arguments.
  14 
  15    expmac$one expands a macro with a single argument.  m_a is called
  16    if the argument is not addressable already.  the parameter 'double'
  17    being non-zero means that the macro argument represents a double
  18    length operand.  expmac$one will expand macro+1 if the operand is
  19    not on an even boundary and macro+2 if it is on an even boundary.
  20 
  21    expmac$abs is used to append a block of words to the output buffer.
  22 
  23    expmac$eis is used to expand a macro consisting of an EIS instruction where
  24    the result operand is in cg_stat$eis_temp and the other operand is passed as an
  25    argument to expmac$eis.
  26 
  27    expmac$two_eis is used to expand a macro consisting of an EIS instruction that has
  28    two operands, both of which are supplied in the argument list.
  29 
  30    expmac$many_eis expands a macro consisting of an EIS instruction and takes all its
  31    operands from its argument list.
  32 
  33    Initial Version: 10 October, 1968 by BLW
  34           Modified:  6 April, 1971 by BLW for Version II
  35           Modified: 26 October 1972 by BLW
  36           Modified: 14 February 1973 by RAB
  37           Modified: 29 May 1973 by RAB for EIS
  38           Modified: 23 Feb 1976 by RAB to fix 1469
  39           Modified: 1 Dec 1976 by RAB for -long_profile
  40           Modified: 6 Mar 1977 by RAB to opt multiply of constants
  41           Modified: 25 Mar 1977 by RAB to fix 1599
  42           Modified: 5 May 1977 by SHW for new pl1_operator_names_
  43           Modified: 15 July 1977 by RAB to fix 1646
  44           Modified: 6 December 1977 by RAB to fix 1693
  45           Modified: 15 January 1978 by RAB to fix 1698
  46           Modified: 8 March 1978 by RAB to fix 1713
  47           Modified: 11 August 1978 by RAB to change handling of aggregate temp ref counts by expmac$eis and friends
  48           Modified: 21 August 1978 by RAB to increase obj seg limit from 32K to 128K
  49           Modified: 25 August 1978 by RAB to help fix 1780
  50           Modified: 25 April 1979 by PCK to implement 4-bit decimal
  51           Modified: 18 July 1979 by RAB to fix 1842 (ERR 313 when comparing
  52                     entry vars).  Method of counting down ref counts in put_word
  53                     changed to fix the bug.
  54           Modified 791029 by PG to make changes so that fix for 1744 does not degrade
  55                     code for abs(floating_expr). Fixes long-outstanding problem with way
  56                     machine_state.indicators is set for instructions that modify both the A and Q.
  57           Modified 800109 by PG to fix bug 1861 in above change involving pl1_operators_ & handling of indicators.
  58           Modified 8/19/81 by EBush to keep peepholer from removing what it thinks
  59                     are no-ops (eppn pn|0) but are really sites for binder relocation. (Bug 2084)
  60 */
  61 
  62 /* format: style3 */
  63 expmac:
  64      proc (macro, arg_pt);
  65 
  66 /* parameters */
  67 
  68 dcl       PR                  fixed bin (3);
  69 dcl       macro               fixed bin,                    /* id of macro to be expanded */
  70           arg_pt              ptr;                          /* ptr to single arg of macro */
  71 
  72 /* builtins */
  73 
  74 dcl       (abs, addr, addrel, binary, bit, divide, fixed, hbound, lbound, mod, null, ptr, string, substr)
  75                               builtin;
  76 
  77 /* automatic */
  78 
  79 dcl       (arg_blk, p, q, q2, mac_pt, ref_pt, output_pt, sym_use_pt, reloc_pt, text_pt)
  80                               ptr,
  81           b72                 bit (72) aligned,
  82           (addressable, found, hold_perm_address)
  83                               bit (1) aligned,
  84           made_perm_addressable
  85                               bit (1) aligned init ("0"b),
  86           mop                 fixed bin (10),
  87           (s1, s2, n)         fixed bin,
  88           inst                bit (10) aligned,
  89           rhs                 bit (18) aligned,
  90           erase               bit (19) aligned,
  91           not_constant        bit (1),
  92           eis                 bit (1) aligned init ("0"b),
  93           count_arg           bit (7) aligned,
  94           constant_value      fixed bin (18),
  95           (fw, const_string)  bit (36) aligned,
  96           (i, j, k, num_args, text_pos, first_pos, size, shift_amount, inc, offset)
  97                               fixed bin (18),
  98           k71                 fixed bin (71),
  99           mac                 fixed bin;
 100 
 101 dcl       1 info              aligned like instruction_info_$instruction_info;
 102 
 103 /* entries */
 104 
 105 dcl       cg_error            entry (fixed bin, fixed bin),
 106           constant_zero       entry (ptr) returns (bit (1)),
 107           expmac              entry (fixed bin (15), ptr),
 108           c_a                 entry (fixed bin (18), fixed bin (18)) returns (ptr),
 109           error               entry (fixed bin, ptr, ptr),
 110           expmac_test         entry (fixed bin, ptr, (4) ptr, (4) bit (1) aligned) returns (bit (1)),
 111           m_a                 entry (ptr, bit (2) aligned),
 112           expmac$zero         entry (fixed bin (15)),
 113           (load, adjust_ref_count)
 114                               entry (ptr, fixed bin),
 115           need_temp           entry (ptr, bit (2) aligned),
 116           compile_exp         entry (ptr),
 117           compile_exp$save    entry (ptr) returns (ptr),
 118           state_man$erase_reg entry (bit (19) aligned),
 119           base_man$load_var   entry (fixed bin, ptr, fixed bin),
 120           aq_man$save_aq      entry (ptr, fixed bin),
 121           power_of_two        entry (fixed bin (18)) returns (fixed bin (18)) reducible;
 122 
 123 /* internal static */
 124 
 125 dcl       max_obj_seg_size    fixed bin (17) int static init (131071) options (constant);
 126 
 127 dcl       (
 128           ldfx1               init (7),
 129           stfx1               init (15),
 130           sta                 init (4),
 131           load_pt             init (60),
 132           load_ab             init (618),
 133           load_sb             init (621),
 134           fx1_to_fx2          init (88),
 135           quick_desc_mac      init (279),
 136           get_desc_size       init (284),
 137           zero_mac            init (308),
 138           sxl0                init (345),
 139           sxl7                init (352),
 140           stx0                init (714),
 141           stx7                init (721),
 142           xr18_to_q           init (735),
 143           xr_to_q             init (583)
 144           )                   fixed bin (15) int static options (constant);
 145 
 146 dcl       add_op              (2) bit (10) int static init ("0001111100"b,
 147                                                             /* adq */
 148                               "0001111110"b /* adaq */);
 149 
 150 dcl       (
 151           eapbp               init ("0111010100"b),
 152           lcq                 init ("0110111100"b),
 153           fld                 init ("1000110010"b),
 154           fst                 init ("1001011010"b),
 155           lda                 init ("0100111010"b),
 156           ldq                 init ("0100111100"b),
 157           adq                 init ("0001111100"b),
 158           sbq                 init ("0011111100"b),
 159           mpy                 init ("1000000100"b),
 160           qls                 init ("1110111100"b),
 161           lrs                 init ("1110110110"b),
 162           lrl                 init ("1111110110"b),
 163           arl                 init ("1111110010"b),
 164           tsp4                init ("1101110000"b),
 165           tsp2                init ("0101110100"b),
 166           tsp3                init ("0101110110"b),
 167           tra                 init ("1110010000"b),
 168           eax0                init ("1100100000"b),
 169           tsx0                init ("1110000000"b)
 170           )                   bit (10) int static options (constant);
 171 
 172 dcl       (
 173           lda_dl              init ("010011101000000111"b),
 174           lda_du              init ("010011101000000011"b),
 175           mpy_dl              init ("100000010000000111"b)
 176           )                   bit (18) int static options (constant);
 177 
 178 dcl       dl_inst             (0:3) bit (18) aligned int static options (constant) init ("001111110000000111"b,
 179                                                             /* sbq ,dl */
 180                               "000111110000000111"b,        /* adq ,dl */
 181                               "011011110000000111"b,        /* lcq ,dl */
 182                               "010011110000000111"b);       /* ldq ,dl */
 183 
 184 dcl       (
 185           sbq_dl              defined (dl_inst (0)),
 186           adq_dl              defined (dl_inst (1)),
 187           lcq_dl              defined (dl_inst (2)),
 188           ldq_dl              defined (dl_inst (3))
 189           )                   bit (18) aligned;
 190 
 191 dcl       (
 192           eppbp_bp_up_zero    init ("010000000000000000011101010001000000"b),
 193           epplp_lp_up_zero    init ("100000000000000000011111000001000000"b),
 194           eppab_ab_up_zero    init ("001000000000000000011101001101000000"b),
 195           eppbb_bb_up_zero    init ("011000000000000000011101011101000000"b),
 196           epplb_lb_up_zero    init ("101000000000000000011111001101000000"b),
 197           eppsb_sb_up_zero    init ("111000000000000000011111011101000000"b),
 198           eax0_0_al           init ("000000000000000000110010000000000101"b),
 199           fld_0_dl            init ("000000000000000000100011001000000111"b),
 200           llr_36              init ("000000000000100100111111111000000000"b),
 201           ldq_0_dl            init ("000000000000000000010011110000000111"b),
 202           tpl_3_ic            init ("000000000000000011110000101000000100"b),
 203           ora_0_dl            init ("000000000000000000010111101000000111"b),
 204           adq_0_dl            init ("000000000000000000000111110000000111"b),
 205           sbq_0_dl            init ("000000000000000000001111110000000111"b),
 206           mpy_1_dl            init ("000000000000000001100000010000000111"b),
 207           div_1_dl            init ("000000000000000001101000110000000111"b)
 208           )                   bit (36) int static options (constant);
 209 
 210 dcl       (
 211           als_ins             init ("000000000000000000111011101000000000"b),
 212           lls_ins             init ("000000000000000000111011111000000000"b),
 213           anaq_ap             init ("000000000000000000011111111001000000"b)
 214           )                   bit (36) int static;          /* these get set */
 215 
 216 /* external static */
 217 
 218 dcl       (
 219           cg_stat$text_base,
 220           cg_stat$text_reloc_base,
 221           cg_stat$cur_node,
 222           cg_stat$complex_ac,
 223           cg_stat$sym_use_base,
 224           cg_stat$cur_statement
 225           )                   ptr ext,
 226           (
 227           pl1_operator_names_$last,
 228           cg_stat$max_program_size
 229           )                   fixed bin ext,
 230           cg_stat$used_operator
 231                               bit (900) ext,
 232           cg_stat$last_macro  fixed bin (15) ext,
 233           cg_stat$text_pos    fixed bin (18) ext;
 234 
 235 dcl       1 instruction_info_$instruction_info
 236                               (0:1023) aligned ext static,
 237             2 changes         unaligned,
 238               3 a             unal bit (1),
 239               3 q             unal bit (1),
 240               3 indicators    unal bit (1),
 241               3 b             (1:6) unal bit (1),
 242               3 x             (0:7) unal bit (1),
 243               3 dr            unal bit (1),
 244             2 directable      unal bit (1),
 245             2 fixed_pt        unal bit (1),
 246             2 float_pt        unal bit (1),
 247             2 some_base       unal bit (1),
 248             2 pad             unal bit (5),
 249             2 num_words       unal fixed bin (7),
 250             2 double_ins      unal bit (1);
 251 
 252 dcl       instruction_info_$operators
 253                               aligned ext static;
 254 
 255 dcl       macro_table_$macro_count
 256                               fixed bin ext,
 257           macro_table_$macro_table
 258                               (1000) bit (72) ext static;
 259 
 260 /* based */
 261 
 262 dcl       1 operator_info     aligned based (addr (instruction_info_$operators)),
 263             2 n_entries       fixed bin,
 264             2 entry           (1 refer (operator_info.n_entries)),
 265               3 first         fixed bin (18) uns unal,
 266               3 last          fixed bin (18) uns unal,
 267               3 info          aligned like instruction_info_$instruction_info;
 268 
 269 dcl       arg                 (num_args) ptr based (p);
 270 
 271 dcl       1 macro_def         aligned based (p),
 272             2 rel_ptr         unaligned bit (18),           /* rel ptr to body if size > 0 */
 273             2 op_code         unaligned bit (10),           /* op_code if size = 0 */
 274             2 size            unaligned bit (8),            /* size of body if multi instructions */
 275             2 erase           unaligned bit (15),           /* which registers unaltered */
 276             2 no_al           unaligned bit (1),            /* "1"b if no AL modification allowed */
 277             2 no_ql           unaligned bit (1),            /* "1"b if no QL modification allowed */
 278             2 perm            unaligned bit (1),            /* "1"b if arg1 should be made perm addressable */
 279             2 cat             unaligned bit (1),            /* "1"b if target length should be taken from source length */
 280             2 length_in_q     unaligned bit (1),            /* "1"b if length for move is in q register */
 281             2 compare         unaligned bit (1),            /* "1"b if macro is an EIS comparison */
 282             2 xec_eis         unaligned bit (1);            /* "1"b if macro xec's EIS instruction */
 283 
 284 dcl       1 arg_word          aligned based (p),
 285             2 dummy           unaligned bit (3),
 286             2 number          unaligned bit (3),            /* arg number */
 287             2 increment       unaligned bit (12),           /* add this to arg offset */
 288             2 ignored         unaligned bit (12),
 289             2 modifier        unaligned bit (6);
 290 
 291 dcl       1 instruction       aligned based (p),
 292             2 base            unaligned bit (3),
 293             2 offset          unaligned bit (15),
 294             2 op_code         unaligned bit (10),
 295             2 flag            unaligned bit (1),
 296             2 ext_base        unaligned bit (1),
 297             2 tag             unaligned bit (6);
 298 
 299 dcl       1 ic_instruction    based aligned,
 300             2 offset          unaligned bit (18),
 301             2 op_code         unaligned bit (10),
 302             2 flag            unaligned bit (1),
 303             2 ext_base        unaligned bit (1),
 304             2 tag             unaligned bit (6);
 305 
 306 dcl       1 forward_ref       based aligned,
 307             2 eis_flag        unaligned bit (1),
 308             2 offset          unaligned bit (17),
 309             2 pad             unaligned bit (18);
 310 
 311 dcl       full_word           bit (36) aligned based;
 312 
 313 dcl       1 reloc             aligned based,
 314             2 skip1           unal bit (12),
 315             2 left_rel        unal bit (6),
 316             2 skip2           unal bit (12),
 317             2 right_rel       unal bit (6);
 318 
 319 dcl       1 half_word         aligned based,
 320             2 left            unaligned bit (18),
 321             2 right           unaligned bit (18);
 322 
 323 dcl       fix_bin             fixed bin based;
 324 
 325 dcl       1 packed_ptr_st     based aligned,
 326             2 packedptr       ptr unal;
 327 
 328 /* include files */
 329 
 330 %include operator_names;
 331 %include machine_state;
 332 %include nodes;
 333 %include cg_reference;
 334 %include symbol;
 335 %include operator;
 336 %include data_types;
 337 %include boundary;
 338 %include cgsystem;
 339 %include relocation_bits;
 340 %include bases;
 341 ^L
 342 /* program */
 343 
 344           k = 0;
 345 
 346           p = arg_pt;
 347           if p -> reference.temp_ref
 348           then do;
 349                     if p -> reference.data_type ^= real_fix_bin_1
 350                     then goto set_one;
 351 
 352                     if p -> reference.value_in.storage
 353                     then goto set_one;
 354                     if p -> reference.array_ref
 355                     then goto set_one;
 356                     if p -> reference.aggregate
 357                     then goto set_one;
 358 
 359                     if macro = stfx1
 360                     then goto set_one;
 361                     if macro = zero_mac
 362                     then goto set_one;
 363                     if macro = load_pt
 364                     then goto set_one;
 365                     if macro >= load_ab & macro <= load_sb
 366                     then go to set_one;
 367                     if macro >= sxl0 & macro <= sxl7
 368                     then goto set_one;
 369                     if macro >= stx0 & macro <= stx7
 370                     then goto set_one;
 371                     if macro = quick_desc_mac
 372                     then goto set_one;
 373                     if macro = get_desc_size
 374                     then goto set_one;
 375 
 376 /* have reference to single precision fixed binary temp without
 377                   value in storage.  if value is in an index register, we'll
 378                   transfer it to storage or the q register */
 379 
 380                     call save_temp;
 381                     if macro = ldfx1
 382                     then return;
 383                end;
 384 
 385           goto set_one;
 386 
 387 expmac$many:
 388      entry (macro, arg_pt, arg_cnt);
 389 
 390 dcl       arg_cnt             fixed bin;                    /* number of arguments */
 391 
 392           if arg_cnt <= 0
 393           then return;
 394           arg_blk = arg_pt;
 395           num_args = arg_cnt;
 396 
 397           do i = 1 to num_args;
 398                p = arg_blk -> arg (i);
 399                if ^p -> reference.perm_address
 400                then call m_a (p, "0"b);
 401           end;
 402 
 403 normal:
 404           mac = macro;
 405           goto join;
 406 
 407 expmac$one:
 408      entry (macro, arg_pt, double);
 409 
 410 dcl       double              fixed bin;                    /* non-zero if double length operand */
 411 
 412           k = double;
 413 
 414 set_one:
 415           num_args = 1;
 416 
 417           ref_pt = arg_pt;
 418           if ^ref_pt -> reference.perm_address
 419           then call m_a (ref_pt, k ^= 0);
 420 
 421           arg_blk = addr (ref_pt);
 422 
 423           if k = 0
 424           then goto normal;
 425           if ref_pt -> reference.even
 426           then mac = macro + 2;
 427           else mac = macro + 1;
 428 
 429 join:
 430           if mac < 1
 431           then goto unknown;
 432 
 433           if mac > macro_table_$macro_count
 434           then do;
 435 unknown:
 436                     call cg_error (302, mac);
 437                     return;
 438                end;
 439 
 440           cg_stat$last_macro = mac;
 441 
 442           mac_pt = addr (macro_table_$macro_table (mac));
 443           if mac_pt -> full_word = "0"b
 444           then return;
 445 
 446           do i = 1 to num_args;
 447                p = arg_blk -> arg (i);
 448                if ^p -> reference.shared
 449                then if p -> reference.ref_count = 1
 450                     then call need_temp (p, "11"b);
 451           end;
 452 
 453           erase = mac_pt -> macro_def.erase;
 454 
 455           if erase
 456           then call state_man$erase_reg (erase);
 457 
 458           not_constant = "1"b;
 459           count_arg = (7)"0"b;
 460 
 461           first_pos, text_pos = cg_stat$text_pos;
 462 
 463 /* check for no AL modification allowed */
 464 
 465           if mac_pt -> macro_def.no_al
 466           then do;
 467                     p = arg_blk -> arg (1);
 468                     if substr (p -> address.tag, 3, 4) = "0101"b
 469                                                             /* al */
 470                     then do;
 471                               substr (p -> address.tag, 3, 4) = "1000"b;
 472                                                             /* x0 */
 473                               addrel (cg_stat$text_base, text_pos) -> full_word = eax0_0_al;
 474                               text_pos = text_pos + 1;
 475                          end;
 476                end;
 477 
 478           if mac_pt -> macro_def.perm
 479           then do;
 480                     made_perm_addressable = "1"b;
 481                     hold_perm_address = arg_blk -> arg (1) -> reference.perm_address;
 482                     arg_blk -> arg (1) -> reference.perm_address = "1"b;
 483                end;
 484 
 485           text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
 486           reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
 487           sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);
 488 
 489           size = fixed (mac_pt -> macro_def.size, 8);
 490           if size = 0
 491           then do;
 492 
 493 /* macro is just an op_code, use of arg_1 is implied */
 494 
 495                     p = arg_blk -> arg (1);
 496                     output_pt -> full_word = string (p -> reference.address);
 497                     output_pt -> instruction.op_code = mac_pt -> macro_def.op_code;
 498 
 499                     q2 = p -> reference.symbol;
 500                     if q2 ^= null
 501                     then sym_use_pt -> packedptr = q2;
 502 
 503                     inst = output_pt -> instruction.op_code;
 504                     mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);
 505 
 506                     if p -> reference.ic_ref
 507                     then do;
 508                               inc = 0;
 509                               call text_ref;
 510                          end;
 511 
 512                     reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
 513                     reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);
 514 
 515                     if ^p -> reference.shared & ^substr (count_arg, 1, 1)
 516                     then substr (count_arg, 1, 1) = "1"b;
 517 
 518 /* eliminate instructions which are effectively nop's -- if they really are ! */
 519 
 520                     fw = output_pt -> full_word;
 521 
 522                     if reloc_pt -> left_rel = rc_a
 523                     then do;
 524                               if fw = eppbp_bp_up_zero
 525                               then goto done;
 526                               if fw = epplp_lp_up_zero
 527                               then goto done;
 528                               if fw = eppab_ab_up_zero
 529                               then go to done;
 530                               if fw = eppbb_bb_up_zero
 531                               then go to done;
 532                               if fw = epplb_lb_up_zero
 533                               then go to done;
 534                               if fw = eppsb_sb_up_zero
 535                               then go to done;
 536                          end;
 537                     if fw = ora_0_dl
 538                     then goto done;
 539                     if fw = adq_0_dl
 540                     then goto done;
 541                     if fw = sbq_0_dl
 542                     then goto done;
 543                     if fw = mpy_1_dl
 544                     then if cg_stat$cur_node -> operand (1) -> reference.data_type = real_fix_bin_1
 545                          then go to done;
 546                     if fw = div_1_dl
 547                     then goto done;
 548 
 549                     rhs = output_pt -> right;
 550                     q = addrel (output_pt, -1);
 551 
 552 /* the following section attempts to remove code from the
 553                   sequences generated for string assignments and conversion
 554                   from bit to fixed.  Let N be the shift amount of the LRL,
 555                   if the preceding instruction is an lda which referecnes
 556                   a direct constant, the code attempts to shift the constant
 557                   reference and delete the lrl instruction.
 558                   if the preceding instruction is
 559                               anaq      ap|2*(72-N)         (72-n)"1"b
 560                   the anaq instruction is removed.  if the preceding word is
 561                               als       N
 562                   the two shift instructions are replaced by the instruction
 563                               anaq      ap|144+2*N          (N)"0"b || (72-N)"1"b
 564                   if the preceding word is
 565                               als       N-36
 566                   and the instruction before that is an lda, the
 567                   lda is changed to an ldq, the als and the lrl are
 568                   replaced by the instruction
 569                               anaq      ap|144+2*N          (N)"0"b || (72-N)"1"b
 570                   Finally, if the preceding instruction is
 571                               lls       N
 572                   it and the lrl are replaced by the same anaq as above */
 573 
 574                     if rhs = lrl | rhs = arl
 575                     then do;
 576                               shift_amount = fixed (output_pt -> left, 18);
 577 
 578                               if q -> right = lda_du
 579                               then do;
 580                                         const_string = q -> left;
 581                                         goto l7;
 582                                    end;
 583 
 584                               if q -> right = lda_dl
 585                               then do;
 586                                         const_string = (18)"0"b || q -> left;
 587 
 588 l7:
 589                                         b72 = "0"b;
 590                                         substr (b72, shift_amount + 1) = const_string;
 591                                         if substr (b72, 37, 36)
 592                                         then goto l1;
 593 
 594                                         if b72 = "0"b & rhs = lrl
 595                                         then do;
 596                                                   q -> full_word = fld_0_dl;
 597                                                   goto done;
 598                                              end;
 599 
 600                                         if substr (b72, 19, 18) = "0"b
 601                                         then do;
 602                                                   q -> left = b72;
 603                                                   q -> right = lda_du;
 604                                                   goto done;
 605                                              end;
 606 
 607                                         if substr (b72, 1, 18) = "0"b
 608                                         then do;
 609                                                   q -> left = substr (b72, 19, 18);
 610                                                   q -> right = lda_dl;
 611                                                   goto done;
 612                                              end;
 613 
 614                                         goto l1;
 615                                    end;
 616 
 617                               substr (anaq_ap, 1, 18) = bit (fixed (2 * (72 - shift_amount), 18), 18);
 618                               if q -> full_word = anaq_ap
 619                               then do;
 620                                         q -> full_word = fw;
 621                                         goto done;
 622                                    end;
 623 
 624                               substr (als_ins, 1, 18) = bit (shift_amount, 18);
 625                               if q -> full_word = als_ins
 626                               then goto ga;
 627 
 628                               if shift_amount < 37
 629                               then goto tls;
 630                               substr (als_ins, 1, 18) = bit (fixed (shift_amount - 36, 18), 18);
 631                               if q -> full_word = als_ins
 632                               then do;
 633                                         q2 = addrel (q, -1);
 634                                         if q2 -> instruction.op_code ^= lda
 635                                         then goto l1;
 636                                         q2 -> instruction.op_code = ldq;
 637                                         goto ga;
 638                                    end;
 639 
 640 tls:
 641                               substr (lls_ins, 1, 18) = bit (shift_amount, 18);
 642                               if q -> full_word ^= lls_ins
 643                               then goto l1;
 644 ga:
 645                               substr (anaq_ap, 1, 18) = bit (fixed (144 + 2 * shift_amount, 18), 18);
 646                               q -> full_word = anaq_ap;
 647                               goto done;
 648                          end;
 649 
 650                     if rhs = lrs
 651                     then do;
 652 
 653 /* check for anaq   ap|2*(72-N) */
 654 
 655                               shift_amount = fixed (output_pt -> left, 18);
 656                               substr (anaq_ap, 1, 18) = bit (fixed (2 * (72 - shift_amount), 18), 18);
 657                               if q -> full_word = anaq_ap
 658                               then do;
 659                                         q -> full_word = fw;
 660                                         go to done;
 661                                    end;
 662                          end;
 663 
 664                     if rhs = qls
 665                     then do;
 666                               if q -> right ^= qls
 667                               then goto l1;
 668 
 669 /* have two consecutive qls instructions, combine them */
 670 
 671                               q -> left = bit (fixed (fixed (q -> left, 18) + fixed (output_pt -> left, 18), 18), 18);
 672                               goto done;
 673                          end;
 674 
 675 /* the following section recognizes consecutive adq or sbq
 676                   instructions and attempts to combine constant terms */
 677 
 678                     if rhs = adq_dl
 679                     then s1 = 1;
 680                     else if rhs = sbq_dl
 681                     then s1 = -1;
 682                     else goto m1;
 683 
 684                     j = 0;
 685                     if q -> right = adq_dl
 686                     then s2 = 1;
 687                     else if q -> right = sbq_dl
 688                     then s2 = -1;
 689                     else do;
 690 
 691 /* if word before ldq has 2 in offset field, it may be
 692                             part of min | max macro so we'll skip the optimization */
 693 
 694                               if addrel (q, -1) -> left = "000000000000000010"b
 695                               then goto l1;
 696 
 697                               j = 2;
 698                               if q -> right = ldq_dl
 699                               then s2 = 1;
 700                               else if q -> right = lcq_dl
 701                               then s2 = -1;
 702                               else goto l1;
 703                          end;
 704 
 705 /* if we are in abs sequence, skip the optimization */
 706 
 707                     if addrel (q, -2) -> full_word = tpl_3_ic
 708                     then go to m1;
 709 
 710                     k = s1 * fixed (output_pt -> left, 18) + s2 * fixed (q -> left, 18);
 711 
 712                     if k = 0
 713                     then do;
 714                               if j ^= 0
 715                               then q -> full_word = ldq_0_dl;
 716                               else do;
 717                                         output_pt = q;
 718                                         reloc_pt = addrel (reloc_pt, -1);
 719                                         sym_use_pt = addrel (sym_use_pt, -1);
 720                                         text_pos = text_pos - 1;
 721                                    end;
 722                               goto done;
 723                          end;
 724 
 725                     if abs (k) > 111111111111111111b
 726                     then goto l1;
 727 
 728                     q -> right = dl_inst (j + fixed (k > 0, 1));
 729 
 730                     q -> left = bit (k, 18);
 731                     goto done;
 732 
 733 m1:
 734                     if not_constant
 735                     then goto l1;
 736 
 737 /* the follwing section first tries to optimize multiplications
 738                   with 2 constant operands, and then tries to replace
 739                   multipications by a constant power of two by a left shift
 740                   instruction */
 741 
 742                     if inst = mpy
 743                     then do;
 744                               if cg_stat$cur_node -> operand (1) -> reference.data_type ^= real_fix_bin_1
 745                               then goto l1;
 746 
 747                               if rhs = mpy_dl & (q -> right = ldq_dl | q -> right = lcq_dl)
 748                                    & addrel (q, -1) -> left ^= "000002"b3 & addrel (q, -2) -> full_word ^= tpl_3_ic
 749                               then do;
 750                                         k71 = fixed (output_pt -> left, 18) * fixed (q -> left, 18);
 751 
 752                                         if k71 <= 111111111111111111b
 753                                         then do;
 754                                                   q -> left = bit (fixed (k71, 18), 18);
 755                                                   go to done;
 756                                              end;
 757                                    end;
 758 
 759                               constant_value = fixed (const_string, 36);
 760                               k = power_of_two (constant_value);
 761                               if k = 0
 762                               then goto l1;
 763 
 764                               if q -> right = qls
 765                               then do;
 766                                         q -> left = bit (fixed (fixed (q -> left, 18) + k, 18), 18);
 767                                         goto done;
 768                                    end;
 769 
 770                               output_pt -> full_word = bit (k, 18) || qls;
 771                               goto l1;
 772                          end;
 773 
 774 l1:
 775                     text_pos = text_pos + 1;
 776                     goto done;
 777                end;
 778 
 779 /* have macro of size words, may have arguments used */
 780 
 781           mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);
 782           addressable = "1"b;
 783 
 784           do i = 0 to size - 1;
 785 
 786                call put_word;
 787           end;
 788 
 789 done:
 790           if count_arg
 791           then do i = 1 to num_args;
 792                     if substr (count_arg, i, 1)
 793                     then call adjust_ref_count (arg_blk -> arg (i), -1);
 794                end;
 795 
 796           if text_pos >= cg_stat$max_program_size
 797           then call cg_error (311, cg_stat$max_program_size);
 798 
 799           do i = first_pos to text_pos - 1;
 800 
 801                inst = text_pt -> instruction.op_code;
 802                mop = binary (substr (inst, 1, 9), 9) + 512 * binary (substr (inst, 10, 1), 1);
 803                info = instruction_info_$instruction_info (mop);
 804                PR = binary (text_pt -> instruction.base, 3);
 805 
 806 /* See if we have a reference to a pl1_operator_. Note that the following tests are
 807    carefully arranged in such a way as to make the code execute as quickly as possible.
 808    Needless to say, the following tests rely on knowledge of how the generated code
 809    addresses operators. Note that not all references use pr0, so we don't test that. */
 810 
 811                if text_pt -> instruction.ext_base & (text_pt -> instruction.tag = ""b)
 812                     & ((inst = tsx0) | (inst = tsp2) | (inst = tra) | (inst = tsp4) | (inst = tsp3))
 813                then do;
 814                          offset = binary (text_pt -> instruction.offset, 15);
 815 
 816                          if offset <= pl1_operator_names_$last
 817                          then substr (cg_stat$used_operator, offset, 1) = "1"b;
 818 
 819                          if (inst = tsx0) | (inst = tsp3)
 820                          then do;
 821 
 822 /* We have a normal or math operator. See how it affects the registers & indicators.
 823    A major assumption here is that an operator that modifies the Q or AQ
 824    also sets the ARITHMETIC indicators for that register. Most of the operators
 825    do just that. All operators that behave otherwise (i.e. set the LOGICAL
 826    indicators) must be in the operator_info table in instruction_info. */
 827 
 828                                    do j = lbound (operator_info.entry, 1) to hbound (operator_info.entry, 1)
 829                                         while (operator_info.entry (j).last < offset);
 830                                    end;
 831 
 832                                    if j <= hbound (operator_info.entry, 1)
 833                                    then if operator_info.entry (j).first <= offset
 834                                         then found = "1"b;
 835                                         else found = "0"b;
 836                                    else found = "0"b;
 837 
 838                                    if found
 839                                    then info = operator_info.entry (j).info;
 840                                    else do;
 841                                              string (info.changes) = substr (erase, 1, 2);
 842                                                             /* A, Q */
 843                                              info.changes.indicators = "1"b;
 844                                              info.fixed_pt = "1"b;
 845                                                             /* one of these must be true... */
 846                                              info.float_pt = "1"b;
 847                                                             /* ...all exceptions are in table */
 848 
 849                                              if substr (erase, 14, 1)
 850                                              then info.changes.b (1) = "1"b;
 851                                         end;
 852                               end;
 853                          else if inst = tsp4
 854                          then string (info.changes) = "111111111"b;
 855 
 856                     end;
 857 
 858                if eis & xec_eis
 859                then string (info.changes) = "001"b;
 860 
 861 /* The following statement should set the indicators to -1 (invalid), but we can't
 862    do so until all of the places that depend on the incorrect value have been
 863    fixed to set it to 0 themselves. Anybody that issues sztl-type instructions
 864    (for example) is affected. */
 865 
 866                if info.changes.indicators
 867                then machine_state.indicators = 0;
 868 
 869                if info.changes.q
 870                then do;
 871                          q_reg.changed = i;
 872                          q_reg.instruction = text_pt -> full_word;
 873                     end;
 874 
 875                if info.changes.a
 876                then do;
 877                          a_reg.changed = i;
 878                          a_reg.instruction = text_pt -> full_word;
 879                     end;
 880 
 881                if (info.fixed_pt | info.float_pt) & info.changes.q
 882                then machine_state.indicators = ind_arithmetic;
 883                else if info.changes.indicators & info.changes.a
 884                then machine_state.indicators = ind_logical;
 885 
 886                if info.some_base
 887                then call change_base_ (i, which_base (PR));
 888 
 889                else do PR = lbound (info.changes.b, 1) to hbound (info.changes.b, 1);
 890                          if info.changes.b (PR)
 891                          then call change_base_ (i, (PR));
 892                     end;
 893 
 894 
 895                do j = 0 to 7;
 896                     if info.changes.x (j)
 897                     then do;
 898                               index_regs (j).changed = i;
 899                               index_regs (j).instruction = text_pt -> full_word;
 900                               machine_state.indicators = ind_x (j);
 901                          end;
 902                end;
 903 
 904                if info.changes.dr
 905                then machine_state.indicators = ind_decimal_reg;
 906 
 907                text_pt = addrel (text_pt, 1);
 908 
 909 /* Next sequence skips over EIS descriptors if they exist */
 910 
 911                nwords = info.num_words - 1;
 912                if eis
 913                then if xec_eis
 914                     then nwords = 2;
 915 
 916                if nwords > 0
 917                then do;
 918 
 919 /* eis instruction */
 920 
 921                          if ^compare
 922                          then if machine_state.indicators = ind_known_refs
 923                               then do;
 924 
 925 /* we have set a value without setting the indicators,
 926                             remove it from the indicators */
 927 
 928                                         p = arg_blk -> arg (1);
 929                                         if p = indicators_ref (2)
 930                                         then machine_state.indicators = ind_invalid;
 931                                         else if p = indicators_ref (3)
 932                                         then machine_state.indicators = ind_invalid;
 933                                    end;
 934 
 935                          i = i + nwords;
 936                          text_pt = addrel (text_pt, nwords);
 937                     end;
 938 
 939           end;
 940 
 941           cg_stat$text_pos = text_pos;
 942 
 943           if made_perm_addressable
 944           then arg_blk -> arg (1) -> reference.perm_address = hold_perm_address;
 945 
 946           return;
 947 
 948 expmac$zero:
 949      entry (macro);
 950 
 951           cg_stat$last_macro, mac = macro;
 952 
 953           if mac < 1
 954           then goto unknown;
 955           if mac > macro_table_$macro_count
 956           then goto unknown;
 957 
 958           num_args = 0;
 959           count_arg = (7)"0"b;
 960 
 961           mac_pt = addr (macro_table_$macro_table (mac));
 962 
 963           if mac_pt -> full_word = "0"b
 964           then return;
 965 
 966           erase = mac_pt -> macro_def.erase;
 967 
 968           if erase
 969           then call state_man$erase_reg (erase);
 970 
 971           size = fixed (mac_pt -> macro_def.size, 8);
 972 
 973           first_pos, text_pos = cg_stat$text_pos;
 974           text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
 975           reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
 976 
 977 /* there must be a macro body if there are no args */
 978 
 979           if size = 0
 980           then do;
 981                     call cg_error (304, mac);
 982                     return;
 983                end;
 984 
 985           mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);
 986           do i = 0 to size - 1;
 987                output_pt -> full_word = mac_pt -> full_word;
 988                reloc_pt -> full_word = "0"b;
 989 
 990 /* convert the sequence
 991                               ldq       x
 992                               llr       36
 993                   into the instruction
 994                               lda       x         */
 995 
 996 /* We cannot do the optimization if the
 997                   q register could have been loaded via
 998                   more than 1 path (min or max bifs)*/
 999 
1000                if output_pt -> full_word = llr_36
1001                then if machine_state.indicators = ind_arithmetic
1002                     then do;
1003                               q = addrel (output_pt, -1);
1004                               if q -> instruction.op_code = ldq
1005                               then do;
1006                                         q -> instruction.op_code = lda;
1007                                         goto l4;
1008                                    end;
1009                          end;
1010 
1011 
1012                output_pt = addrel (output_pt, 1);
1013                reloc_pt = addrel (reloc_pt, 1);
1014                text_pos = text_pos + 1;
1015 
1016 l4:
1017                mac_pt = addrel (mac_pt, 1);
1018           end;
1019 
1020           goto done;
1021 
1022 expmac$abs:
1023      entry (blk_pt, blk_cnt);
1024 
1025 dcl       blk_pt              ptr,                          /* points at block to be appended */
1026           blk_cnt             fixed bin;                    /* number of words in block */
1027 
1028 dcl       blk                 (blk_cnt) fixed bin based;
1029 
1030           if blk_cnt <= 0
1031           then return;
1032 
1033           cg_stat$last_macro = 0;
1034 
1035 /* we use the fact that the relocation segment will be
1036              filled with zeros as its length grows */
1037 
1038           addrel (cg_stat$text_base, cg_stat$text_pos) -> blk = blk_pt -> blk;
1039 
1040           cg_stat$text_pos = cg_stat$text_pos + blk_cnt;
1041           if cg_stat$text_pos >= cg_stat$max_program_size
1042           then call cg_error (311, cg_stat$max_program_size);
1043 
1044           return;
1045 
1046 expmac$interpret:
1047      entry (macro_start, node_pt, refs, atom);
1048 
1049 /* This entry is called to interpret the macro sequence
1050              starting at "macro_start" */
1051 
1052 dcl       macro_start         fixed bin,                    /* start of sequence */
1053           node_pt             ptr,                          /* points at operator node */
1054           refs                (4) ptr,                      /* ref nodes for operands */
1055           atom                (4) bit (1) aligned;          /* ON if operand is atomic */
1056 
1057 dcl       (b1, b2, b3)        bit (1),
1058           (depth, code)       fixed bin,
1059           ref                 (4) ptr defined (refs),
1060           (
1061           stack               (10),
1062           rand                (4)
1063           )                   ptr;
1064 
1065 dcl       1 special_word      aligned based,
1066             2 part1           unal bit (18),
1067             2 op              unal bit (9),
1068             2 skip            unal bit (3),
1069             2 part2           unal bit (6);
1070 
1071 dcl       special_erase       bit (15) aligned based;
1072 
1073 dcl       sp_erase            bit (19) aligned;
1074 
1075           mac_pt = addr (macro_start);
1076           goto init;
1077 
1078 expmac$conditional:
1079      entry (macro, node_pt, refs, atom);
1080 
1081           mac_pt = addr (macro_table_$macro_table (macro));
1082 
1083           erase = mac_pt -> macro_def.erase;
1084 
1085           if erase
1086           then call state_man$erase_reg (erase);
1087 
1088           mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);
1089 
1090 /* initialize */
1091 
1092 init:
1093           first_pos, text_pos = cg_stat$text_pos;
1094           text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
1095           reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
1096           sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);
1097 
1098           num_args = node_pt -> operator.number;
1099 
1100           rand (2) = node_pt -> operand (2);
1101           rand (3) = node_pt -> operand (3);
1102           if num_args >= 4
1103           then rand (4) = node_pt -> operand (4);
1104 
1105           code = fixed (atom (2) || atom (3), 2);
1106 
1107           arg_blk = addr (refs);
1108           addressable = "0"b;
1109           count_arg = (7)"0"b;
1110 
1111           depth = 0;
1112 
1113 /* if bit 28 of word from macro table is off, this is ordinary instruction */
1114 
1115 loop:
1116           if ^mac_pt -> instruction.flag
1117           then do;
1118                     call put_word;
1119                     goto loop;
1120                end;
1121 
1122 /* have special control word */
1123 
1124           mop = fixed (mac_pt -> special_word.op, 9);
1125           s2 = fixed (mac_pt -> special_word.part2, 9);
1126           s1 = fixed (mac_pt -> special_word.part1, 18);
1127           k = fixed (mac_pt -> arg_word.number, 3);
1128           if k > 0
1129           then if k <= num_args
1130                then p = ref (k);
1131           goto sw (mop);
1132 
1133 /* end of macro sequence */
1134 
1135 sw (0):
1136           if depth = 0
1137           then goto done;
1138 
1139           mac_pt = stack (depth);
1140           depth = depth - 1;
1141           goto next;
1142 
1143 /* IF operator */
1144 
1145 sw (1):
1146           b2 = "1"b;
1147           goto test;
1148 
1149 /* IFNOT operator */
1150 
1151 sw (2):
1152           b2 = "0"b;
1153 
1154 test:
1155           if s2 = 1
1156           then b1 = ref (2) -> reference.value_in.q;
1157           else if s2 = 2
1158           then b1 = ref (3) -> reference.value_in.q;
1159           else if s2 = 3
1160           then b1 = ref (2) -> reference.value_in.a;
1161           else if s2 = 4
1162           then b1 = ref (3) -> reference.value_in.a;
1163           else if s2 = 5
1164           then b1 = ref (2) -> reference.value_in.complex_aq;
1165           else if s2 = 6
1166           then b1 = ref (3) -> reference.value_in.complex_aq;
1167           else if s2 = 7
1168           then b1 = constant_zero (ref (2));
1169           else if s2 = 8
1170           then b1 = constant_zero (ref (3));
1171           else if s2 = 9
1172           then b1 = atom (2);
1173           else if s2 = 10
1174           then b1 = atom (3);
1175           else if s2 = 11
1176           then b1 = atom (4);
1177           else b1 = expmac_test (s2, node_pt, refs, atom);
1178 
1179           if b1 = b2
1180           then do;
1181 
1182 /* test succeeded */
1183 
1184 next:
1185                     mac_pt = addrel (mac_pt, 1);
1186                     goto loop;
1187                end;
1188 
1189 /* test failed */
1190 
1191           goto sw (4);
1192 
1193 /* FLIPTO operator */
1194 
1195 sw (3):
1196           q = ref (2);
1197           ref (2) = ref (3);
1198           ref (3) = q;
1199 
1200           q = rand (2);
1201           rand (2) = rand (3);
1202           rand (3) = q;
1203 
1204           b1 = atom (2);
1205           atom (2) = atom (3);
1206           atom (3) = b1;
1207 
1208           code = fixed (atom (2) || atom (3), 2);
1209 
1210 /* JUMP operator */
1211 
1212 sw (4):
1213           if s1 = 0
1214           then goto done;
1215           mac_pt = ptr (mac_pt, s1);
1216           goto loop;
1217 
1218 /* PUT operator */
1219 
1220 sw (5):
1221           depth = depth + 1;
1222           stack (depth) = mac_pt;
1223           goto sw (4);
1224 
1225 /* FETCH operator */
1226 
1227 sw (6):
1228           b2 = "0"b;
1229 
1230 f1:
1231           b1 = atom (k);
1232           b3 = "0"b;
1233 
1234 f2:
1235           cg_stat$text_pos = text_pos;
1236 
1237           if b1
1238           then call load (ref (k), 0);
1239           else call compile_exp (rand (k));
1240 
1241           if b2 & ref (k) -> reference.data_type ^= real_fix_bin_2
1242           then call expmac$zero ((fx1_to_fx2));
1243 
1244           if b3
1245           then if ref (k) -> reference.value_in.complex_aq
1246                then do;
1247                          q = ref (k);
1248                          string (q -> reference.address) = string (cg_stat$complex_ac -> reference.address);
1249                          q -> reference.relocation = cg_stat$complex_ac -> reference.relocation;
1250                          q -> reference.perm_address = "1"b;
1251                     end;
1252                else ref (k) = rand (k) -> operand (1);
1253 
1254 f3:
1255           text_pos = cg_stat$text_pos;
1256           output_pt = addrel (cg_stat$text_base, text_pos);
1257           reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
1258           sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);
1259           goto next;
1260 
1261 /* GET_FX2 operator */
1262 
1263 sw (7):
1264           b2 = "1"b;
1265           goto f1;
1266 
1267 /* COMPILE operator */
1268 
1269 sw (8):
1270           b1, b2, b3 = "0"b;
1271           goto f2;
1272 
1273 /* CPLALT operator */
1274 
1275 sw (9):
1276           b3 = "1"b;
1277           b1, b2 = "0"b;
1278           goto f2;
1279 
1280 /* CPLSAVE operator */
1281 
1282 sw (10):
1283           cg_stat$text_pos = text_pos;
1284 
1285           ref (k) = compile_exp$save (rand (k));
1286 
1287           goto f3;
1288 
1289 /* LOAD operator */
1290 
1291 sw (11):
1292           b1 = "1"b;
1293           b2, b3 = "0"b;
1294           goto f2;
1295 
1296 /* ADD operator */
1297 
1298 sw (12):
1299           if p -> reference.no_address
1300           then call call_ma;
1301 
1302           output_pt -> full_word = string (p -> reference.address);
1303           output_pt -> instruction.op_code = add_op (p -> reference.data_type);
1304 
1305           q2 = p -> reference.symbol;
1306           if q2 ^= null
1307           then sym_use_pt -> packedptr = q2;
1308 
1309           reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
1310           reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);
1311 
1312           output_pt = addrel (output_pt, 1);
1313           reloc_pt = addrel (reloc_pt, 1);
1314           sym_use_pt = addrel (sym_use_pt, 1);
1315           text_pos = text_pos + 1;
1316           goto next;
1317 
1318 /* SWITCH operator */
1319 
1320 sw (13):
1321           if s2 = 1
1322           then n = code;
1323           else if s2 = 2
1324           then n = fixed (node_pt -> operator.op_code, 9);
1325           else if s2 = 3
1326           then n = ref (1) -> reference.data_type;
1327           else if s2 = 4
1328           then n = ref (2) -> reference.data_type;
1329           else if s2 = 5
1330           then n = ref (3) -> reference.data_type;
1331 
1332           mac_pt = addrel (mac_pt, n - s1 + 1);
1333           goto loop;
1334 
1335 /* ERASE operator */
1336 
1337 sw (14):
1338           cg_stat$text_pos = text_pos;
1339 
1340           sp_erase = mac_pt -> special_erase;
1341           call state_man$erase_reg (sp_erase);
1342           goto f3;
1343 
1344 /* BUMP operator */
1345 
1346 sw (15):
1347           if ^p -> reference.shared
1348           then p -> reference.ref_count = p -> reference.ref_count + 1;
1349 
1350           goto next;
1351 
1352 /* DROP operator */
1353 
1354 sw (16):
1355           if ^p -> reference.shared
1356           then call adjust_ref_count (p, -1);
1357 
1358           goto next;
1359 
1360 expmac$fill_usage:
1361      entry (val, last_use);
1362 
1363 dcl       (val, last_use, use, prev_use)
1364                               fixed bin (17);
1365 
1366           use = last_use;
1367           do while (use ^= 0);
1368                output_pt = addrel (cg_stat$text_base, use);
1369                prev_use = fixed (output_pt -> forward_ref.offset, 17);
1370 
1371                if output_pt -> forward_ref.eis_flag
1372                then do;
1373                          output_pt -> forward_ref.eis_flag = "0"b;
1374                          use = use - output_pt -> descriptor.char;
1375                          output_pt -> descriptor.char = 0;
1376                     end;
1377 
1378                call set_offset (val - use);
1379                use = prev_use;
1380           end;
1381 
1382           return;
1383 
1384 
1385 
1386 
1387 /* Macro expander for EIS instructions */
1388 
1389 expmac$eis:
1390      entry (macro, arg_pt);
1391 
1392 dcl       lreg                (3) bit (1) aligned;          /* "1"b if length is in a register */
1393 dcl       len                 (3) bit (4) aligned;          /* register containing length */
1394 dcl       count               (3) bit (1) aligned;          /* "1"b if reference count is to be decremented */
1395 
1396 dcl       cat                 bit (1) aligned;              /* "1"b if target length should be taken from source length */
1397 dcl       length_in_q         bit (1) aligned;              /* "1"b if length for move is in q register */
1398 dcl       compare             bit (1) aligned;              /* "1"b if macro is an EIS comparison */
1399 dcl       xec_eis             bit (1) aligned;              /* "1"b if macro xec's an EIS instruction */
1400 dcl       (nwords, type)      fixed bin;
1401 dcl       ichar               fixed bin (3);
1402 dcl       ibit                fixed bin (4);
1403 dcl       scale               fixed bin (6);
1404 dcl       ptarray             (2) ptr;
1405 
1406 dcl       mf                  (3) fixed bin (6) int static init (30, 12, 3);
1407                                                             /* location of modification factor */
1408 
1409 dcl       cg_stat$eis_temp    ptr ext;
1410 
1411 dcl       1 descriptor        based aligned,                /* layout of operand descr */
1412             2 word_address    bit (18) unal,
1413             2 char            fixed bin (2) uns unal,
1414             2 bit             fixed bin (4) uns unal,
1415             2 length          bit (12) unal;
1416 
1417 dcl       1 four_bit_descriptor
1418                               based aligned,                /* EIS 4-bit operand descriptor */
1419             2 word_address    bit (18) unal,
1420             2 char            fixed bin (3) uns unal,
1421             2 bit             fixed bin (3) uns unal,
1422             2 length          bit (12) unal;
1423 
1424 
1425 dcl       1 mod_factor        aligned,                      /* layout of modification_factor field */
1426             2 ext_base        bit (1) unal,
1427             2 tag             unal,
1428               3 length_in_reg bit (1),
1429               3 indirect_descriptor
1430                               bit (1),
1431               3 offset_reg    bit (4);
1432 
1433 dcl       copy_temp           entry (ptr) returns (ptr);
1434 dcl       make_n_addressable  entry (ptr, fixed bin);
1435 dcl       load_size$xr_or_aq  entry (ptr, bit (4) aligned);
1436 dcl       state_man$unlock    entry ();
1437 dcl       aq_man$lock         entry (ptr, fixed bin);
1438 
1439           num_args = 2;
1440           ptarray (1) = cg_stat$eis_temp;
1441           ptarray (2) = arg_pt;
1442           arg_blk = addr (ptarray);
1443           go to join_eis;
1444 
1445 expmac$one_eis:
1446      entry (macro, arg_pt);
1447 
1448           num_args = 1;
1449           arg_blk = addr (arg_pt);
1450           go to join_eis;
1451 
1452 expmac$two_eis:
1453      entry (macro, arg_pt, arg_pt2);
1454 
1455 dcl       arg_pt2             ptr;
1456 
1457           num_args = 2;
1458           ptarray (1) = arg_pt;
1459           ptarray (2) = arg_pt2;
1460           arg_blk = addr (ptarray);
1461           go to join_eis;
1462 
1463 expmac$many_eis:
1464      entry (macro, arg_pt, arg_cnt);
1465 
1466           if arg_cnt <= 0
1467           then return;
1468           arg_blk = arg_pt;
1469           num_args = arg_cnt;
1470 
1471 join_eis:
1472           eis = "1"b;
1473           count_arg = (7)"0"b;
1474 
1475 /* Check for short string temporaries not in storage.  If found, then store
1476    from aq */
1477 
1478           do i = 1 to num_args;
1479                p = arg_blk -> arg (i);
1480                if p -> reference.temp_ref
1481                then if ^p -> reference.value_in.storage & ^p -> reference.array_ref & ^p -> reference.aggregate
1482                     then if p -> reference.data_type >= char_string
1483                          then if ^p -> reference.long_ref & ^p -> reference.varying_ref
1484                               then if p -> reference.value_in.a
1485                                    then do;
1486                                              if p -> reference.shared
1487                                              then p, arg_blk -> arg (i) = copy_temp (p);
1488                                              p -> reference.ref_count = p -> reference.ref_count + 1;
1489                                              p -> reference.value_in.storage = "1"b;
1490                                              p -> reference.store_ins = bit (cg_stat$text_pos, 18);
1491                                              size = p -> reference.c_length * convert_size (p -> reference.data_type);
1492 
1493                                              call expmac$one ((sta), p, fixed (size > bits_per_word, 1));
1494                                         end;
1495                                    else call error315;
1496                               else ;
1497                          else if p -> reference.data_type > 0
1498                          then if p -> reference.data_type <= real_fix_bin_2
1499                               then if p -> reference.value_in.q
1500                                    then call aq_man$save_aq (p, 0);
1501                                    else call save_temp;
1502           end;
1503 
1504 /* Initialize */
1505 
1506           mac = macro;
1507 
1508           if macro <= 0
1509           then go to unknown;
1510           if macro > macro_table_$macro_count
1511           then go to unknown;
1512 
1513           mac_pt = addr (macro_table_$macro_table (mac));
1514           if mac_pt -> full_word = "0"b
1515           then return;
1516 
1517           cat = mac_pt -> macro_def.cat;
1518           length_in_q = mac_pt -> macro_def.length_in_q;
1519           compare = mac_pt -> macro_def.compare;
1520           xec_eis = mac_pt -> macro_def.xec_eis;
1521           if xec_eis
1522           then n = -num_args;
1523           else n = num_args;
1524           if length_in_q
1525           then call aq_man$lock (null, 2);
1526 
1527 /* Make all rands addressable */
1528 
1529           call make_n_addressable (arg_blk, n);
1530 
1531 /* Get lengths for all the rands and determine whose reference counts are
1532   to be decremented */
1533 
1534           do i = 1 to num_args;
1535                p = arg_blk -> arg (i);
1536 
1537                if length_in_q
1538                then do;
1539                          lreg (i) = "1"b;
1540                          len (i) = "0110"b;                 /* q */
1541                     end;
1542                else if cat & i = 1
1543                then ;
1544                else do;
1545                          lreg (i) =
1546                               p -> reference.length ^= null | p -> reference.c_length > 4095
1547                               | (p -> reference.varying_ref & p -> reference.c_length = 0) | xec_eis;
1548                          if lreg (i)
1549                          then call load_size$xr_or_aq (p, len (i));
1550                     end;
1551                count (i) =
1552                     ^(p -> reference.shared | (i = 1 & p -> reference.temp_ref & ^p -> reference.aggregate & ^compare));
1553                if count (i)
1554                then if p -> reference.ref_count = 1
1555                     then call need_temp (p, "01"b);
1556           end;
1557 
1558           if cat
1559           then do;
1560                     lreg (1) = lreg (2);
1561                     len (1) = len (2);
1562                end;
1563 
1564           erase = mac_pt -> macro_def.erase;
1565           if erase
1566           then call state_man$erase_reg (erase);
1567 
1568           cg_stat$last_macro = mac;
1569 
1570           text_pos, first_pos = cg_stat$text_pos;
1571           text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
1572           reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
1573           sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);
1574 
1575           size = fixed (mac_pt -> macro_def.size, 8);
1576 
1577           mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);
1578 
1579 /* Start filling in the text */
1580 
1581           output_pt -> full_word = mac_pt -> full_word;
1582           reloc_pt -> full_word = "0"b;
1583 
1584           inc = 0;
1585           inst = output_pt -> instruction.op_code;
1586 
1587           if ^xec_eis
1588           then do;
1589                     mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);
1590                     nwords = instruction_info_$instruction_info (mop).num_words;
1591                end;
1592           else nwords = 3;
1593 
1594 /* Loop to fill in the operand descriptors */
1595 
1596           do i = 1 to nwords - 1;
1597 
1598                output_pt = addrel (output_pt, 1);
1599                reloc_pt = addrel (reloc_pt, 1);
1600                sym_use_pt = addrel (sym_use_pt, 1);
1601 
1602                mac_pt = addrel (mac_pt, 1);
1603 
1604                k = fixed (mac_pt -> arg_word.number, 3);
1605                if mac_pt -> instruction.base
1606                then k = 0;
1607 
1608 /* Check for use of argument */
1609 
1610                if k ^= 0
1611                then do;
1612 
1613                          if k <= num_args
1614                          then p = arg_blk -> arg (k);
1615                          else do;
1616                                    call cg_error (303, macro);
1617                                    go to step;
1618                               end;
1619 
1620                          q2 = p -> reference.symbol;
1621                          if q2 ^= null
1622                          then sym_use_pt -> packedptr = q2;
1623 
1624                          output_pt -> full_word = string (p -> reference.address);
1625                          type = mac_pt -> descriptor.bit;
1626 
1627 /* See if we must build a descriptor */
1628 
1629 /* Meanings of values of type (operand types of macros in macro_table.table) */
1630 /* 0 = address         */
1631 /* 1 = decimal         */
1632 /* 2 = 8-bit character */
1633 /* 3 = bit             */
1634 /* 4 = 4-bit character */
1635 
1636                          if type > 0
1637                          then do;
1638                                    string (mod_factor) = substr (string (p -> reference.address), 30, 7);
1639                                    mod_factor.length_in_reg = lreg (k);
1640 
1641                                    if lreg (k)
1642                                    then output_pt -> descriptor.length = "00000000"b || len (k);
1643                                    else do;
1644                                              q = p;
1645                                              if cat
1646                                              then if k = 1
1647                                                   then q = arg_blk -> arg (2);
1648                                              if mac_pt -> descriptor.length = (12)"0"b
1649                                              then output_pt -> descriptor.length =
1650                                                        bit (fixed (q -> reference.c_length, 12), 12);
1651                                              else output_pt -> descriptor.length = mac_pt -> descriptor.length;
1652                                         end;
1653 
1654                                    if ^xec_eis
1655                                    then substr (text_pt -> full_word, mf (i), 7) = string (mod_factor);
1656 
1657                                    if type <= 2 | type = 4
1658                                    then do;
1659                                              ichar = p -> reference.c_f_offset;
1660                                              ibit = 0;
1661                                         end;
1662                                    else do;
1663                                              ichar = divide (p -> reference.c_f_offset, bits_per_char, 2, 0);
1664                                              ibit = mod (p -> reference.c_f_offset, bits_per_char);
1665                                         end;
1666 
1667                                    if ichar > 0
1668                                    then if q2 ^= null & type = 1
1669                                         then if q2 -> symbol.unaligned & q2 -> symbol.decimal
1670                                              then output_pt -> four_bit_descriptor.char = ichar;
1671                                              else output_pt -> descriptor.char = ichar;
1672                                         else output_pt -> descriptor.char = ichar;
1673                                    if ibit > 0
1674                                    then output_pt -> descriptor.bit = ibit;
1675 
1676                                    if type = 1
1677                                    then do;
1678                                              if p -> reference.data_type = complex_fix_dec
1679                                                   | p -> reference.data_type = complex_flt_dec
1680                                              then output_pt -> descriptor.length =
1681                                                        bit (divide (p -> reference.c_length, 2, 12, 0), 12);
1682                                              if p -> reference.data_type = real_fix_dec
1683                                                   | p -> reference.data_type = complex_fix_dec
1684                                              then do;
1685                                                        if q2 ^= null
1686                                                        then if q2 -> symbol.unaligned & q2 -> symbol.decimal
1687                                                             then output_pt -> four_bit_descriptor.bit = 5;
1688                                                             else output_pt -> descriptor.bit = 1;
1689                                                        else output_pt -> descriptor.bit = 1;
1690                                                        if q2 ^= null
1691                                                        then do;
1692                                                                  scale = q2 -> symbol.scale;
1693                                                                  if scale > max_dec_scale | scale < min_dec_scale
1694                                                                  then scale = 0;
1695                                                                  else scale = -scale;
1696                                                                  if scale < 0
1697                                                                  then scale = scale + 64;
1698                                                                  if scale ^= 0
1699                                                                  then substr (output_pt -> descriptor.length, 1, 6) =
1700                                                                            bit (scale, 6);
1701                                                             end;
1702                                                   end;
1703                                              else if q2 ^= null
1704                                              then if q2 -> symbol.unaligned & q2 -> symbol.decimal
1705                                                   then output_pt -> four_bit_descriptor.bit = 4;
1706                                                             /* 4-bit float decimal */
1707 
1708                                              if k = 1
1709                                              then if instruction_info_$instruction_info (mop).changes.dr
1710                                                   then do;
1711                                                             p -> reference.value_in.decimal_aq = "1"b;
1712                                                             decimal_reg.variable = p;
1713                                                        end;
1714                                         end;
1715                                    else if type = 4
1716                                    then do;
1717                                              output_pt -> four_bit_descriptor.bit = 4;
1718                                              output_pt -> four_bit_descriptor.char = ichar;
1719                                         end;
1720                               end;
1721 
1722                          if p -> reference.ic_ref
1723                          then call text_ref;
1724 
1725                          reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
1726                          reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);
1727 
1728                          if count (k)
1729                          then call adjust_ref_count (p, -1);
1730                     end;
1731 
1732                else do;
1733                          output_pt -> full_word = mac_pt -> full_word;
1734                          reloc_pt -> full_word = "0"b;
1735                     end;
1736 step:
1737           end;
1738 
1739 /* Unlock all registers locked for this instruction */
1740 
1741           call state_man$unlock;
1742 
1743           text_pos = text_pos + nwords;
1744 
1745 /* See if we have non-EIS sequence following EIS instruction.  If so, put_word will handle it */
1746 
1747           if size > nwords
1748           then do;
1749                     output_pt = addrel (output_pt, 1);
1750                     reloc_pt = addrel (reloc_pt, 1);
1751                     sym_use_pt = addrel (sym_use_pt, 1);
1752                     mac_pt = addrel (mac_pt, 1);
1753                     eis = "0"b;
1754                     do i = nwords to size - 1;
1755                          call put_word;
1756                     end;
1757                end;
1758 
1759           go to done;
1760 
1761 
1762 
1763 put_word:
1764      proc;
1765 
1766 dcl       inc_orig            fixed bin;
1767 
1768 /* check for use of argument */
1769 
1770           k = fixed (mac_pt -> arg_word.number, 3);
1771           if mac_pt -> instruction.tag
1772           then k = 0;
1773           if mac_pt -> instruction.base
1774           then k = 0;
1775 
1776           inst = mac_pt -> instruction.op_code;
1777           mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);
1778 
1779 /* check for use of argument */
1780 
1781           if k ^= 0
1782           then do;
1783 
1784                     if k <= num_args
1785                     then p = arg_blk -> arg (k);
1786                     else do;
1787                               call cg_error (303, macro);
1788                               return;
1789                          end;
1790 
1791 /* check for base register being loaded */
1792 
1793                     if inst = eapbp
1794                     then do;
1795                               call call_base_man;
1796                               goto l3;
1797                          end;
1798 
1799 /* make sure arg is addressable */
1800 
1801                     if ^addressable
1802                     then call call_ma;
1803 
1804                     fw = string (p -> reference.address);
1805 
1806                     inc, inc_orig = fixed (mac_pt -> arg_word.increment, 12);
1807 
1808 /* if macro word is of form
1809                               op argk+inc
1810                        and the corresponding argument has indirection,
1811                        we must either load value of inc into an index,
1812                        or we must load base register with address */
1813 
1814                     if inc = 0
1815                     then goto copy;
1816 
1817                     if substr (p -> address.tag, 1, 2) = "00"b
1818                     then goto copy;
1819 
1820                     if p -> address.tag = "010000"b         /* * */
1821                     then do;
1822 
1823 /* have simple case, just load value of inc into x0 */
1824 
1825                               output_pt -> left = bit (fixed (inc, 18), 18);
1826                               output_pt -> right = eax0;
1827 
1828                               substr (fw, 31, 6) = "111000"b;
1829                                                             /* *0 */
1830 
1831                               output_pt = addrel (output_pt, 1);
1832                               reloc_pt = addrel (reloc_pt, 1);
1833                               sym_use_pt = addrel (sym_use_pt, 1);
1834                               text_pos = text_pos + 1;
1835                               inc = 0;
1836                          end;
1837                     else do;
1838                               call adjust_ref_count (p, 1);
1839                               call call_base_man;
1840                               fw = string (p -> reference.address);
1841                          end;
1842 
1843 /* copy word from macro table into output */
1844 
1845 copy:
1846                     output_pt -> full_word = mac_pt -> full_word;
1847 
1848 /* combine kth arg with macro word */
1849 
1850                     output_pt -> left = "0"b;
1851                     output_pt -> full_word = output_pt -> full_word | fw;
1852 
1853                     q2 = p -> reference.symbol;
1854                     if q2 ^= null
1855                     then sym_use_pt -> packedptr = q2;
1856 
1857                     if p -> reference.ic_ref
1858                     then call text_ref;
1859                     else if inc > 0
1860                     then if output_pt -> instruction.ext_base
1861                          then output_pt -> instruction.offset =
1862                                    bit (fixed (fixed (output_pt -> instruction.offset, 15) + inc, 15), 15);
1863                          else output_pt -> left = bit (fixed (fixed (output_pt -> left, 18) + inc, 18), 18);
1864 
1865                     reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
1866                     reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);
1867 
1868                     if ^p -> reference.shared & inc_orig = 0 & ^substr (count_arg, k, 1)
1869                     then substr (count_arg, k, 1) = "1"b;
1870 
1871                end;
1872 
1873           else do;
1874                     output_pt -> full_word = mac_pt -> full_word;
1875                     p = null;
1876                     reloc_pt -> full_word = "0"b;
1877                end;
1878 
1879           if reloc_pt -> left_rel = rc_a
1880           then do;
1881                     if output_pt -> full_word = eppbp_bp_up_zero
1882                     then goto l3;
1883                     if output_pt -> full_word = epplp_lp_up_zero
1884                     then goto l3;
1885                     if output_pt -> full_word = eppab_ab_up_zero
1886                     then go to l3;
1887                     if output_pt -> full_word = eppbb_bb_up_zero
1888                     then go to l3;
1889                     if output_pt -> full_word = epplb_lb_up_zero
1890                     then go to l3;
1891                     if output_pt -> full_word = eppsb_sb_up_zero
1892                     then go to l3;
1893                end;
1894 
1895           q = addrel (output_pt, -1);
1896 
1897 /* following section flushes sequence
1898                               fld       x
1899                               fst       x
1900                   which may arise in some complex arithmetic sequences */
1901 
1902           if inst = fst
1903           then do;
1904                     fw = output_pt -> full_word;
1905                     substr (fw, 19, 10) = fld;
1906                     if q -> full_word = fw
1907                     then goto prev;
1908                end;
1909 
1910           if i > 0
1911           then goto l2;
1912 
1913           if output_pt -> right = adq_dl
1914           then s1 = 1;
1915           else if output_pt -> right = sbq_dl
1916           then s1 = -1;
1917           else goto l2;
1918 
1919           j = 0;
1920           if q -> right = adq_dl
1921           then s2 = 1;
1922           else if q -> right = sbq_dl
1923           then s2 = -1;
1924           else do;
1925 
1926 /* if word before ldq has 2 in offset field, it may be
1927                             part of min | max macro so we'll skip the optimization */
1928 
1929                     if addrel (q, -1) -> left = "000000000000000010"b
1930                     then goto l2;
1931 
1932                     j = 2;
1933                     if q -> right = ldq_dl
1934                     then s2 = 1;
1935                     else if q -> right = lcq_dl
1936                     then s2 = -1;
1937                     else goto l2;
1938                end;
1939 
1940 /* if we are in abs  sequence, skip optimization */
1941 
1942           if addrel (q, -2) -> full_word = tpl_3_ic
1943           then go to l2;
1944 
1945           k = s1 * fixed (output_pt -> left, 18) + s2 * fixed (q -> left, 18);
1946 
1947           if k = 0
1948           then do;
1949                     if j ^= 0
1950                     then q -> full_word = ldq_0_dl;
1951                     else do;
1952 prev:
1953                               output_pt = q;
1954                               reloc_pt = addrel (reloc_pt, -1);
1955                               sym_use_pt = addrel (sym_use_pt, -1);
1956                               text_pos = text_pos - 1;
1957                          end;
1958                     goto l3;
1959                end;
1960 
1961           if abs (k) > 111111111111111111b
1962           then goto l2;
1963 
1964           q -> right = dl_inst (j + fixed (k > 0, 1));
1965 
1966           q -> left = bit (k, 18);
1967           goto l3;
1968 
1969 l2:
1970           output_pt = addrel (output_pt, 1);
1971           reloc_pt = addrel (reloc_pt, 1);
1972           sym_use_pt = addrel (sym_use_pt, 1);
1973           text_pos = text_pos + 1;
1974 
1975 l3:
1976           mac_pt = addrel (mac_pt, 1);
1977      end;
1978 
1979 call_base_man:
1980      proc;
1981 
1982 dcl       hold_perm_address   bit (1) aligned;
1983 
1984           cg_stat$text_pos = text_pos;
1985 
1986           if addressable
1987           then do;
1988                     hold_perm_address = p -> reference.perm_address;
1989                     p -> reference.perm_address = "1"b;
1990                end;
1991 
1992           call base_man$load_var (2, p, 1);
1993 
1994           if addressable
1995           then p -> reference.perm_address = hold_perm_address;
1996 
1997           text_pos = cg_stat$text_pos;
1998           output_pt = addrel (cg_stat$text_base, text_pos);
1999           reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
2000           sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);
2001 
2002      end;
2003 
2004 call_ma:
2005      proc;
2006 
2007           cg_stat$text_pos = text_pos;
2008 
2009           call m_a (p, "0"b);
2010 
2011           text_pos = cg_stat$text_pos;
2012           output_pt = addrel (cg_stat$text_base, text_pos);
2013           reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
2014           sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);
2015 
2016      end;
2017 
2018 set_offset:
2019      proc (off_val);
2020 
2021 dcl       pt                  ptr,
2022           off_val             fixed bin (18);
2023 
2024           pt = output_pt;
2025 
2026           if off_val >= 0
2027           then pt -> ic_instruction.offset = bit (off_val, 18);
2028           else pt -> ic_instruction.offset = bit (fixed (262144 + off_val, 18), 18);
2029 
2030      end;
2031 
2032 text_ref:
2033      proc;
2034 
2035 dcl       (q, s)              ptr,
2036           offset              fixed bin (18),
2037           temp                fixed bin (35);
2038 
2039           offset = text_pos;
2040 
2041           if p -> reference.defined_ref
2042           then s = p -> reference.qualifier;
2043           else s = p;
2044           s = s -> reference.symbol;
2045           if s = null
2046           then goto so2;
2047           if s -> node.type = label_node
2048           then goto so1;
2049 
2050           if s -> symbol.label
2051           then goto so1;
2052           if s -> symbol.entry
2053           then goto so1;
2054           if ^s -> symbol.constant
2055           then goto so;
2056 
2057           not_constant = "0"b;
2058 
2059           q = s -> symbol.initial;
2060           if q = null
2061           then goto so1;
2062 
2063           if p -> reference.c_offset ^= 0
2064           then if p -> reference.units ^= word_
2065                then goto so;
2066 
2067           if p -> reference.forward_ref
2068           then q = addrel (q, inc + p -> reference.c_offset);
2069           else q = addrel (cg_stat$text_base, inc + fixed (substr (string (p -> reference.address), 1, 18), 18));
2070 
2071           const_string = q -> full_word;
2072 
2073           if instruction_info_$instruction_info (mop).directable
2074           then do;
2075 
2076                     if eis
2077                     then do;
2078                               if i = 2
2079                               then if q -> right = "0"b
2080                                    then do;
2081                                              output_pt -> left = q -> left;
2082                                              substr (text_pt -> full_word, 15, 4) = "0011"b;
2083                                                             /* du */
2084                                              return;
2085                                         end;
2086                               go to so;
2087                          end;
2088 
2089                     if q -> left = "0"b
2090                     then do;
2091 is_dl:
2092                               output_pt -> left = q -> right;
2093                               output_pt -> instruction.tag = "000111"b;
2094                                                             /* dl */
2095                               return;
2096                          end;
2097 
2098                     if q -> right = "0"b
2099                     then do;
2100                               output_pt -> left = q -> left;
2101                               output_pt -> instruction.tag = "000011"b;
2102                                                             /* du */
2103                               return;
2104                          end;
2105 
2106                     if q -> fix_bin > 0
2107                     then goto so;
2108 
2109                     temp = -q -> fix_bin;
2110                     q = addr (temp);
2111 
2112                     if (18)"0"b || q -> right ^= q -> full_word
2113                     then goto so;
2114 
2115                     if inst = ldq
2116                     then inst = lcq;
2117                     else if inst = adq
2118                     then inst = sbq;
2119                     else if inst = sbq
2120                     then inst = adq;
2121                     else if inst = lcq
2122                     then inst = ldq;
2123                     else goto so;
2124 
2125                     output_pt -> instruction.op_code = inst;
2126                     mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);
2127                     goto is_dl;
2128 
2129                end;
2130 
2131 so:
2132           s -> symbol.allocate = "1"b;
2133 
2134 so1:
2135           if p -> reference.forward_ref
2136           then do;
2137                     if s -> symbol.location > max_obj_seg_size
2138                     then do;
2139                               call cg_error (333, max_obj_seg_size);
2140                               return;
2141                          end;
2142                     output_pt -> forward_ref.offset = bit (fixed (s -> symbol.location, 17), 17);
2143                     if eis
2144                     then do;
2145                               output_pt -> forward_ref.eis_flag = "1"b;
2146                               s -> symbol.location = offset + i;
2147                               output_pt -> descriptor.char = i;
2148                          end;
2149                     else s -> symbol.location = offset;
2150                end;
2151           else do;
2152 so2:
2153                     call set_offset (fixed (output_pt -> ic_instruction.offset, 18) + inc - offset);
2154                end;
2155      end;
2156 
2157 
2158 save_temp:
2159      proc;
2160 
2161 dcl       i                   fixed bin (18);
2162 dcl       mac                 fixed bin (15);
2163 
2164 /* have reference to fixed binary temp without value in storage.
2165                   if value is in an index register, we'll transfer it to storage
2166                   or the q register.  If value is in q, we'll store it unless
2167                   the original macro was ldfx1, in which case we have an error. */
2168 
2169           if p -> reference.value_in.q
2170           then do;
2171                     if macro = ldfx1
2172                     then call error315;
2173                     else do;
2174                               p -> reference.value_in.storage = "1"b;
2175                               p -> reference.ref_count = p -> reference.ref_count + 1;
2176                               call expmac (stfx1, p);
2177                          end;
2178                     return;
2179                end;
2180 
2181           if string (p -> reference.value_in.x) = "0"b
2182           then do;
2183                     call error315;
2184                     return;
2185                end;
2186 
2187           do i = 0 to 7 while (^p -> reference.value_in.x (i));
2188           end;
2189 
2190           if macro = ldfx1
2191           then do;
2192                     if p -> reference.symbol -> symbol.c_dcl_size > default_fix_bin_p
2193                     then mac = xr18_to_q;
2194                     else mac = xr_to_q;
2195                     q = c_a (i, 8);                         /* 0,i */
2196                     call expmac (mac, q);
2197                     call adjust_ref_count (p, -1);
2198                     return;
2199                end;
2200 
2201           p -> reference.value_in.storage = "1"b;
2202           p -> reference.ref_count = p -> reference.ref_count + 2;
2203           call expmac ((zero_mac), p);
2204           call expmac (sxl0 + i, p);
2205 
2206      end;
2207 
2208 
2209 error315:
2210      proc;
2211 
2212           call error (315, cg_stat$cur_statement, p);
2213 
2214      end;
2215 
2216 change_base_:
2217      procedure (insx, base);
2218 declare   insx                fixed bin (18);
2219 declare   base                fixed bin;
2220 declare   k                   fixed bin;
2221 declare   q                   ptr;
2222 
2223           if insx <= base_regs (base).changed
2224           then return;
2225 
2226           base_regs (base).changed = insx;
2227           base_regs (base).instruction = text_pt -> full_word;
2228 
2229           q = base_regs (base).variable;
2230           k = base_regs (base).type;
2231           if q = null
2232           then k = 0;
2233 
2234           if k = 1
2235           then q -> reference.value_in.b (base) = "0"b;
2236           else if k = 2
2237           then q -> reference.address_in.b (base) = "0"b;
2238 
2239           base_regs (base).type = 0;
2240 
2241      end change_base_;
2242 
2243      end;