1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 
  15 /****^  HISTORY COMMENTS:
  16   1) change(89-02-28,RWaters), approve(89-02-28,MCR8068), audit(89-09-07,Vu),
  17      install(89-09-19,MR12.3-1068):
  18      Fix bug 1899.
  19                                                    END HISTORY COMMENTS */
  20 
  21 
  22 /* Program to make a reference addressable
  23 
  24    Initial Version: 16 April 1971 by BLW for Version II
  25           Modified: 10 May 1973 by RAB for multiple base regs
  26           Modified: 19 June 1973 by RAB for EIS
  27           Modified: 4 June 1975 by RAB for separate_static
  28           Modified: 27 November 1975 by RAB to fix 1431
  29           Modified: 11 May 1976 by RAB to fix 1496
  30           Modified: 2 Oct 1976 by RAB to fix 1530
  31           Modified: 9 Mar 1977 by RAB to eliminate mod_word operator
  32           Modified: 11 Jan 1978 by RAB to set base_regs(i).used
  33           Modified: 11 Aug 1978 by RAB to fix 1734
  34           Modified: 31 Dec 1978 by RAB to fix 1807 (bad code for internal
  35                     file constants if linkage section >16k)
  36           Modified: 14 Dec 1988 by RW null pointer with defined references.
  37 */
  38 /* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
  39 %page;
  40 m_a:
  41      proc (pt, bits);
  42 
  43 dcl      pt ptr,                                            /* points at ref node to be made addressable */
  44          bits aligned bit (2),                              /* 2 bits as follows: */
  45          no_ind aligned bit (1),                            /* "1"b if no indirection allowed */
  46          eis aligned bit (1);                               /* "1"b if addressing for EIS instruction */
  47 
  48 dcl      (
  49          cg_stat$cur_block,
  50          cg_stat$cur_statement,
  51          cg_stat$long_string_temp
  52          ) ptr ext,
  53          cg_stat$extended_stack bit (1) ext,
  54          cg_stat$text_pos fixed bin (18) ext,
  55          cg_stat$cur_level fixed bin ext;
  56 
  57 dcl      ref ptr,                                           /* points at ref node to be made addressable */
  58          r1 ptr;                                            /* points at ref node from which addressing info
  59                                            is obtained.  r1 starts off equal to ref. */
  60 
  61 dcl      (p1, p2, ro, s1, q, vwo) ptr,
  62          (i, k) fixed bin,
  63          xr fixed bin (3),
  64          base bit (3),
  65          (dont_load, have_loaded, useless) bit (1) aligned,
  66          (word_offset, save_word_offset, off, delta) fixed bin (15),
  67          (fract_offset, save_fract_offset, fo) fixed bin (6),
  68          (ind_word, multiple) fixed bin (18),
  69          base_offset fixed bin (24),
  70          locked bit (1) aligned,
  71          fok bit (1) aligned,
  72          (tag, tagind) bit (6) aligned,
  73          reloc bit (12) aligned,
  74          op_code bit (9) aligned;
  75 
  76 dcl      (abs, bit, divide, fixed, mod, null, string, substr) builtin;
  77 
  78 dcl      m_a entry (ptr, bit (2) aligned);
  79 dcl      expmac entry (fixed bin (15), ptr);
  80 dcl      base_man$load_arg_ptr entry (fixed bin, ptr, fixed bin) returns (bit (3) aligned);
  81 dcl      base_man$load_stack_indirect entry (fixed bin (18)) returns (bit (3) aligned);
  82 dcl      base_man$load_display entry (fixed bin) returns (bit (3) aligned);
  83 dcl      base_man$load_link_indirect entry (fixed bin, bit (12) aligned) returns (bit (3) aligned);
  84 dcl      base_man$load_controlled entry (fixed bin, fixed bin (15)) returns (bit (3) aligned);
  85 dcl      base_man$load_linkage entry returns (bit (3) aligned);
  86 dcl      base_man$load_static entry returns (bit (3) aligned);
  87 dcl      base_man_link_or_static entry returns (bit (3) aligned) variable;
  88 dcl      base_man$load_any_var entry (fixed bin, ptr) returns (bit (3) aligned);
  89 dcl      base_man$load_arg entry (fixed bin, ptr) returns (bit (3) aligned);
  90 dcl      base_man$load_var entry (fixed bin, ptr, fixed bin),
  91          stack_temp$free_temp entry (ptr),
  92          stack_temp$assign_temp entry (ptr),
  93          stack_temp$assign_block entry (ptr, fixed bin),
  94          stack_temp$assign_aggregate entry (ptr),
  95          stack_temp$assign_return_value entry (ptr),
  96          copy_temp entry (ptr) returns (ptr),
  97          cg_error entry (fixed bin, fixed bin),
  98          error entry (fixed bin, ptr, ptr),
  99          prepare_operand entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
 100          aq_man$load_any_const entry (fixed bin (24), fixed bin (2)),
 101          aq_man$load_any_var entry (ptr, fixed bin (2), fixed bin (24)),
 102          xr_man$lock entry (ptr, fixed bin (3)),
 103          xr_man$unlock entry (fixed bin (3)),
 104          xr_man$load_any_const entry (fixed bin (18), fixed bin (3)),
 105          xr_man$load_any_var entry (ptr, fixed bin (3), fixed bin (18));
 106 
 107 dcl      (
 108          r_mod init ("001"b),
 109          ri_mod init ("011"b),
 110          ir_mod init ("111"b)
 111          ) bit (3) int static;
 112 
 113 dcl      (
 114          aq_mod init ("0001"b),
 115          iaq_mod init ("1101"b)
 116          ) bit (4) int static;
 117 
 118 dcl      fix_bin fixed bin (15) based;
 119 
 120 dcl      (
 121          first_base init (1),
 122          last_base init (6)
 123          ) fixed bin int static;
 124 
 125 dcl      load_pt init (60) fixed bin (15) int static;
 126 
 127 %page;
 128 %include cgsystem;
 129 %page;
 130 %include nodes;
 131 %page;
 132 %include cg_reference;
 133 %page;
 134 %include symbol;
 135 %page;
 136 %include temporary;
 137 %page;
 138 %include operator;
 139 %page;
 140 %include block;
 141 %page;
 142 %include relocation_bits;
 143 %page;
 144 %include op_codes;
 145 %page;
 146 %include bases;
 147 %page;
 148 %include machine_state;
 149 %page;
 150 %include boundary;
 151 %page;
 152 /* program */
 153 
 154           no_ind = substr (bits, 1, 1);
 155           eis = substr (bits, 2, 1);
 156 
 157           ref, r1 = pt;
 158           if ^ref -> reference.no_address then
 159                if ref -> reference.perm_address then
 160                     if no_ind then
 161                          goto test1;
 162                     else
 163                          return;
 164 
 165           dont_load, ref -> reference.even, ref -> reference.forward_ref, ref -> reference.ic_ref,
 166                ref -> reference.relocation, string (ref -> reference.address) = "0"b;
 167 
 168           ref -> reference.c_f_offset = 0;
 169 
 170           s1 = ref -> reference.symbol;
 171 
 172 /* check for address already in a base register
 173              (we skip this code for temporaries so that
 174               store$save_string_temp works)               */
 175 
 176           if ^ref -> reference.temp_ref then do;
 177 
 178                if string (ref -> reference.address_in.b) then
 179                     do i = first_base to last_base;
 180                          if ref -> reference.address_in.b (i) then do;
 181                               ref -> reference.base = bases (i);
 182                               ref -> reference.ext_base = "1"b;
 183                               base_regs (i).used = cg_stat$text_pos;
 184                               return;
 185                          end;
 186                     end;
 187 
 188           end;
 189 
 190           locked, reloc = "0"b;
 191 
 192 /* get variable word offset */
 193 
 194           call get_vwo (ref);
 195 
 196           word_offset, fract_offset = 0;
 197           call get_c_offset;
 198 
 199           if ^eis then
 200                fok = "1"b;
 201           else
 202                fok = fract_offset = 0 & ^(no_ind & vwo ^= null);
 203 
 204           if ref -> reference.temp_ref then do;
 205 
 206 temp:
 207                if r1 -> reference.aggregate then do;
 208                     if s1 -> symbol.varying then
 209                          word_offset = word_offset + 1;
 210 
 211 /* if the temp aggregate is a structure, we want to allocate
 212                        the level 1 temporary instead of the descendant */
 213 
 214                     p1 = s1;
 215                     do while (p1 -> symbol.father ^= null);
 216                          p1 = p1 -> symbol.father;
 217                     end;
 218 
 219                     if p1 -> symbol.initial = null then
 220                          call stack_temp$assign_aggregate (p1);
 221 
 222                     p2 = p1 -> symbol.initial;
 223 
 224                     if p1 -> symbol.word_size = null then do;
 225                          word_offset = word_offset + p2 -> temporary.location;
 226                          goto lv;
 227                     end;
 228 
 229                     call load_vwo;
 230 
 231                     if word_offset = 0 & fok & abs (p2 -> temporary.location) < 16384 then do;
 232                          tag = tagind;
 233                          word_offset = p2 -> temporary.location;
 234                          goto t1;
 235                     end;
 236 
 237                     ref -> address.base = base_man$load_stack_indirect (p2 -> temporary.location);
 238                     goto so1;
 239                end;
 240 
 241                if r1 -> reference.address_in.storage then do;
 242                     if r1 -> reference.allocated then
 243                          if r1 -> reference.qualifier ^= null then
 244                               ind_word = r1 -> reference.qualifier -> temporary.location;
 245                          else
 246                               goto err330;
 247                     else if r1 -> reference.value_in.string_aq then
 248                          ind_word = fixed (cg_stat$long_string_temp -> address.offset, 15);
 249                     else do;
 250 err330:
 251                          call error (330, cg_stat$cur_statement, r1);
 252                          return;
 253                     end;
 254                     if word_offset = 0 & fok then do;
 255                          r1 -> reference.even = "1"b;
 256                          word_offset = ind_word;
 257                          call load_vwo;
 258                          tag = tag | substr (ri_mod, 1, 2);
 259                          goto t1;
 260                     end;
 261                     else do;
 262                          call load_vwo;
 263                          ref -> address.base = base_man$load_stack_indirect (ind_word);
 264                          goto so;
 265                     end;
 266                end;
 267 
 268                if ^r1 -> reference.allocated then do;
 269                     if ^r1 -> reference.allocate then
 270                          ref, r1, pt = copy_temp (r1);
 271                     call stack_temp$assign_temp (r1);
 272                end;
 273                else if r1 -> reference.qualifier = null then do;
 274                     call error (316, cg_stat$cur_statement, r1);
 275                     return;
 276                end;
 277 
 278                word_offset = word_offset + r1 -> reference.qualifier -> temporary.location;
 279                goto lv;
 280           end;
 281 
 282           p1 = ref -> reference.qualifier;
 283 
 284           if s1 -> node.type ^= symbol_node then
 285                goto dr;
 286 
 287           if s1 -> symbol.return_value then do;
 288 
 289                do p2 = s1 repeat p2 -> symbol.father while (p2 -> symbol.father ^= null);
 290                end;
 291 
 292                p1 = p2 -> symbol.initial;
 293 
 294                if p1 ^= null /* not 1st reference */ then do;
 295                     if s1 -> symbol.varying then
 296                          if s1 -> symbol.dimensioned | s1 -> symbol.member then
 297                               word_offset = word_offset + 1;
 298                     call load_vwo;
 299 
 300                     if word_offset = 0 & fok & abs (p1 -> temporary.location) < 16384 then do;
 301                          word_offset = p1 -> temporary.location;
 302                          tag = tagind;
 303                     end;
 304                     else do;
 305                          ref -> address.base = base_man$load_stack_indirect (p1 -> temporary.location);
 306                          goto so1;
 307                     end;
 308 
 309                end;
 310                else do;                                     /* p1 is NULL */
 311 
 312 /* 1st reference, get 2 word slot to hold ptr to datum */
 313 
 314                     call stack_temp$assign_return_value (p2);
 315                     p1 = p2 -> symbol.initial;
 316                     word_offset = p1 -> temporary.location;
 317                     call load_vwo;
 318 
 319 /* the stack will get extended when call is made to the procedure
 320 returning the star extent value, so turn the bit on now */
 321 
 322                     cg_stat$extended_stack = "1"b;
 323                end;
 324 
 325                goto t1;
 326           end;
 327 
 328 dr:
 329           if ref -> reference.defined_ref then do;
 330                if p1 = null then do;                        /* write file (afile) from (thing); where "thing" is a defined  structure */
 331                     p1 = s1 -> symbol.reference -> reference.qualifier;
 332                end;
 333 
 334                r1 = p1;
 335 
 336 l0:
 337                if r1 -> node.type = operator_node then
 338                     r1 = r1 -> operand (1);
 339 
 340                if r1 -> reference.defined_ref then do;
 341                     r1 = r1 -> reference.qualifier;
 342                     goto l0;
 343                end;
 344 
 345                if s1 -> symbol.varying & s1 -> symbol.member then
 346                     word_offset = word_offset + 1;
 347 
 348 l0b:
 349                s1 = r1 -> reference.symbol;
 350 
 351                if r1 -> reference.temp_ref & r1 -> reference.address_in.storage then
 352                     goto l0a;
 353 
 354                if s1 -> symbol.return_value then
 355                     goto l0a;
 356 
 357                if vwo = null & ref -> reference.units = r1 -> reference.units then
 358                     call get_vwo (r1);
 359                else if r1 -> reference.offset ^= null then do;
 360 l0a:
 361                     if ^r1 -> reference.shared then
 362                          r1 -> reference.ref_count = r1 -> reference.ref_count + 1;
 363                     ref -> address.base = base_man$load_any_var (2, r1);
 364                     call load_vwo;
 365                     goto so1;
 366                end;
 367 
 368                call get_c_offset;
 369 
 370                if r1 -> reference.temp_ref then
 371                     goto temp;
 372 
 373                p1 = r1 -> reference.qualifier;
 374           end;
 375 
 376           if p1 ^= null then
 377                goto have_qual;
 378 
 379           if s1 -> node.type = label_node then
 380                goto lv;
 381 
 382           if s1 -> symbol.constant then do;
 383                if s1 -> symbol.varying then
 384                     word_offset = word_offset + 1;
 385                if s1 -> symbol.file & s1 -> symbol.internal then
 386                     word_offset = word_offset + s1 -> symbol.location;
 387                goto lv;
 388           end;
 389 
 390           if s1 -> symbol.parameter | s1 -> symbol.param_desc then do;
 391                p1 = s1 -> symbol.reference -> reference.qualifier;
 392                goto have_qual;
 393           end;
 394 
 395           if r1 -> reference.temp_ref then
 396                word_offset = word_offset + r1 -> reference.qualifier -> temporary.location;
 397           else if ^(s1 -> symbol.static & s1 -> symbol.external | s1 -> symbol.controlled) then
 398                word_offset = word_offset + s1 -> symbol.location;
 399 
 400           if s1 -> symbol.varying then
 401                if s1 -> symbol.auto | s1 -> symbol.static | s1 -> symbol.controlled then
 402                     word_offset = word_offset + 1;
 403 
 404 /* load variable word offset into an index register and reduce
 405              word offset to a value less than 16384 */
 406 
 407 lv:
 408           call load_vwo;
 409 
 410           if s1 ^= null then
 411                if s1 -> node.type = label_node then
 412                     goto l3a;
 413 
 414           if r1 -> reference.temp_ref then do;
 415 t1:
 416                ref -> address.base = sp;
 417                goto so;
 418           end;
 419 
 420           if s1 -> symbol.auto then do;
 421 
 422                k = cg_stat$cur_level - s1 -> symbol.block_node -> block.level;
 423                if k = 0 then
 424                     goto t1;
 425 
 426 /* load ptr to display(k) level back */
 427 
 428                ref -> address.base = base_man$load_display (k);
 429 
 430 so:
 431                if tag = "000000"b then
 432                     ref -> reference.even = mod (word_offset, 2) = 0;
 433 
 434 so1:
 435                ref -> address.offset = bit (word_offset, 15);
 436                if eis then
 437                     ref -> reference.c_f_offset = fract_offset;
 438 
 439                ref -> address.tag = tag;
 440                ref -> reference.relocation = reloc;
 441 
 442 seteb1:
 443                ref -> address.ext_base = "1"b;
 444 
 445 /* if no indirection is permitted, we may have to generate a
 446                   ptr to the reference in a base register */
 447 
 448                if no_ind then do;
 449 
 450 test1:
 451                     if substr (ref -> address.tag, 1, 2) = "00"b then
 452                          return;
 453 
 454 /* we have to load pointer to reference into a base to get rid
 455                        of indirection, but we don't want to count this as a reference */
 456 
 457                     ref -> reference.perm_address = "1"b;
 458 
 459 call_baseman:
 460                     if ^ref -> reference.shared then
 461                          ref -> reference.ref_count = ref -> reference.ref_count + 1;
 462 
 463                     base = base_man$load_any_var (2, ref);
 464 
 465                     ref -> address.ext_base = "1"b;
 466                     ref -> address.base = base;
 467 
 468                     ref -> reference.c_f_offset = 0;
 469                     ref -> address.tag, ref -> address.offset, ref -> reference.perm_address = "0"b;
 470 
 471                end;
 472 
 473                return;
 474           end;
 475 
 476           if s1 -> symbol.static then do;
 477 
 478                if s1 -> symbol.internal then do;
 479 is:
 480                     reloc = rc_is15;
 481                     ref -> address.base = base_man$load_static ();
 482                     goto so;
 483                end;
 484 
 485 /* external static or reference to link */
 486 
 487 lr:
 488                reloc = rc_lp15;
 489                base_man_link_or_static = base_man$load_linkage;
 490 
 491 lr1:
 492                if word_offset = 0 & fok then do;
 493 
 494                     off = s1 -> symbol.location;
 495                     if off >= 16384 then do;
 496                          if tag ^= (6)"0"b then
 497                               goto gen;
 498 
 499                          multiple = off - mod (off, 16384);
 500                          call xr_man$load_any_const (multiple, xr);
 501                          tagind = ri_mod || bit (xr, 3);
 502 
 503                          off = off - multiple;
 504                     end;
 505 
 506                     ref -> address.base = base_man_link_or_static ();
 507                     ref -> reference.relocation = reloc;
 508                     ref -> address.offset = bit (fixed (off, 15), 15);
 509 es:
 510                     ref -> reference.tag = tagind;
 511                     goto seteb1;
 512                end;
 513 
 514 /* generate an instruction of the form
 515                               eapbp     lp|k,*
 516                   where 'k' is offset of link */
 517 
 518 gen:
 519                ref -> address.base = base_man$load_link_indirect ((s1 -> symbol.location), reloc);
 520                reloc = "0"b;
 521                goto so1;
 522           end;
 523 
 524           if s1 -> symbol.constant then do;
 525 
 526                if s1 -> symbol.entry then
 527                     if s1 -> symbol.initial ^= null | s1 -> symbol.internal then
 528                          goto l3a;
 529                     else
 530                          goto lr;
 531 
 532                if s1 -> symbol.external then
 533                     goto lr;
 534 
 535                if s1 -> symbol.file then
 536                     goto is;
 537 
 538                if s1 -> symbol.equivalence ^= null then
 539                     s1 = s1 -> symbol.equivalence;
 540 
 541 l3a:
 542                if ^s1 -> symbol.allocated then do;
 543                     ref -> reference.forward_ref = "1"b;
 544 
 545                     if tag ^= "000000"b | word_offset ^= 0 then do;
 546                          p1 = s1 -> symbol.reference;
 547                          if p1 -> reference.data_type = 0 then
 548                               p1 = prepare_operand (p1, 0, useless);
 549                          ref -> address.base = base_man$load_any_var (2, p1);
 550                          goto so1;
 551                     end;
 552 
 553                     if s1 -> node.type = symbol_node then
 554                          if s1 -> symbol.c_word_size = 2 | s1 -> symbol.boundary = mod2_ then
 555                               ref -> reference.even = "1"b;
 556 
 557                     goto l3b;
 558                end;
 559 
 560 /* the constant reference occurs earlier in text section */
 561 
 562                word_offset = word_offset + s1 -> symbol.location;
 563 
 564                if tag = "000000"b then do;
 565                     ref -> reference.even = mod (word_offset, 2) = 0;
 566 l3b:
 567                     ref -> reference.ic_ref = "1"b;
 568                     ref -> address.tag = "000100"b;         /* IC */
 569                end;
 570                else do;
 571                     ref -> reference.relocation = rc_t;
 572                     ref -> address.tag = tag;
 573                end;
 574 
 575 /* put an 18 bit offset into the address */
 576 
 577                substr (string (ref -> reference.address), 1, 18) = bit (fixed (word_offset, 18), 18);
 578                if eis then
 579                     ref -> reference.c_f_offset = fract_offset;
 580                return;
 581           end;
 582 
 583           if s1 -> symbol.controlled then do;
 584 
 585                if tag = "0"b then
 586                     ref -> reference.even = mod (word_offset, 2) = 0;
 587 
 588                if s1 -> symbol.internal then do;
 589                     reloc = rc_is15;
 590                     base_man_link_or_static = base_man$load_static;
 591                     goto lr1;
 592                end;
 593 
 594 /* external controlled */
 595 
 596                delta = 2 * fixed (s1 -> symbol.arg_descriptor, 1);
 597 
 598                if word_offset = 0 & fok then do;
 599                     ref -> address.base = base_man$load_link_indirect ((s1 -> symbol.location), (rc_lp15));
 600                     ref -> address.offset = bit (delta, 15);
 601                     ref -> address.tag = tagind;
 602                end;
 603                else do;
 604                     ref -> address.base = base_man$load_controlled ((s1 -> symbol.location), delta);
 605                     ref -> address.offset = bit (word_offset, 15);
 606                     ref -> address.tag = tag;
 607                     if eis then
 608                          ref -> reference.c_f_offset = fract_offset;
 609                end;
 610 
 611                goto seteb1;
 612           end;
 613 
 614 /* ERROR */
 615 
 616           call cg_error (305, fixed (string (s1 -> symbol.storage_class), 10));
 617           goto t1;
 618 
 619 /* have a qualifier */
 620 
 621 have_qual:
 622           if s1 -> symbol.varying then
 623                if s1 -> symbol.based | (s1 -> symbol.auto & s1 -> symbol.exp_extents) | s1 -> symbol.member then
 624                     word_offset = word_offset + 1;
 625 
 626           if eis then
 627                if ref -> reference.units = word_ then
 628                     if abs (word_offset) >= 16384 then
 629                          goto call_baseman;
 630 
 631           if p1 -> node.type = reference_node then
 632                goto l5;
 633 
 634           op_code = p1 -> operator.op_code;
 635 
 636           if op_code = addr_fun then do;
 637                if p1 -> operand (1) -> reference.evaluated then
 638                     goto l4a;
 639 
 640                r1 = p1 -> operand (2);
 641 
 642                if r1 -> reference.varying_ref then
 643                     word_offset = word_offset - 1;
 644 
 645                if r1 -> reference.defined_ref then
 646                     goto l0a;
 647                goto l0b;
 648           end;
 649 
 650           if op_code = param_ptr then do;
 651                i = 0;                                       /* load arg ptr */
 652                goto l4;
 653           end;
 654 
 655           if op_code = param_desc_ptr then do;
 656                i = 1;                                       /* load desc ptr */
 657 
 658 l4:
 659                call load_vwo;
 660 
 661                q = p1 -> operand (3);
 662                k = p1 -> operand (2) -> reference.symbol -> symbol.initial -> fix_bin;
 663 
 664                if word_offset = 0 & fok & ^no_ind then do;
 665                     ref -> address.base = base_man$load_arg (i, q);
 666                     ref -> address.offset = bit (fixed (2 * (k - i), 15), 15);
 667                     goto es;
 668                end;
 669 
 670                ref -> address.base = base_man$load_arg_ptr (i, q, k);
 671                goto so1;
 672           end;
 673 
 674 /* the operator is not a special one, so it must have been
 675              evaluated by prepare_operand, pick up the temporary */
 676 
 677 l4a:
 678           p1 = p1 -> operand (1);
 679 
 680 l5:
 681           if ^p1 -> reference.shared then
 682                p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
 683 
 684 /* check to see if the value of the qualifier is in a base */
 685 
 686           do i = first_base to last_base;
 687                if p1 -> reference.value_in.b (i) then do;
 688 
 689 /* value is in base, load vwo into an xr and
 690                        see if value of qualifier is still in base;
 691                        if so, we're home free! */
 692 
 693                     call load_vwo;
 694 
 695                     if p1 -> reference.value_in.b (i) then do;
 696                          ref -> address.base = bases (i);
 697                          base_regs (i).used = cg_stat$text_pos;
 698 
 699                          if ^p1 -> reference.shared then
 700                               p1 -> reference.ref_count = p1 -> reference.ref_count - 1;
 701                          goto so1;
 702                     end;
 703 
 704 /* the qualifier got forced out of the base by
 705    the process of making the variable word offset
 706    addressable, so go lock the offset in the index */
 707 
 708                     goto lock;
 709                end;
 710 
 711           end;
 712 
 713 /* if the variable word offset and qualifier are not both automatic
 714              variables declared in the current stack frame, we may have a
 715              conflict such that the base register(s) needed to address the
 716              offset may conflict with the base register(s) needed to address
 717              the qualifier.  We resolve this problem by loading the offset
 718              into the index register before making the pointer addressable
 719              rather than afterwards, and call a special entry to "lock"
 720              the value into the index register.  (Note that if the ref has a "big"
 721              offset, loading it requires the a or q, which could affect
 722              the qualifier's offset.) */
 723 
 724           if ^ro -> reference.big_offset then do;
 725                if vwo = null then
 726                     goto l6;
 727 
 728                p2 = vwo -> reference.symbol;
 729                if p2 -> symbol.temporary then
 730                     goto l6;
 731 
 732                if p2 -> symbol.auto then
 733                     if p2 -> symbol.block_node = cg_stat$cur_block then
 734                          goto l6;
 735 
 736                if p1 -> reference.temp_ref then
 737                     goto l6;
 738 
 739                p2 = p1 -> reference.symbol;
 740                if p2 -> symbol.auto then
 741                     if p2 -> symbol.block_node = cg_stat$cur_block then
 742                          goto l6;
 743           end;
 744 
 745 /* may have the conflict */
 746 
 747           call load_vwo;
 748 
 749 lock:
 750           if xr >= 0 then do;
 751                call xr_man$lock (vwo, xr);
 752                locked = "1"b;
 753           end;
 754 
 755           word_offset = save_word_offset;
 756           fract_offset = save_fract_offset;
 757 
 758 /* make the qualifier permanently addressable */
 759 
 760 l6:
 761           call m_a (p1, "00"b);
 762           p1 -> reference.perm_address = "1"b;
 763 
 764           if locked then do;
 765                if vwo -> reference.value_in.x (xr) then
 766                     dont_load = "1"b;
 767                call xr_man$unlock (xr);
 768                if base_offset ^= 0 then
 769                     vwo -> reference.value_in.x (xr) = "0"b;
 770           end;
 771 
 772           call load_vwo;
 773 
 774 /* we may be able to use the ptr via indirection if the qualified
 775              variable has a zero word offset and there is no subscript or
 776              indirection on the qualifier */
 777 
 778           if word_offset ^= 0 then
 779                goto l7;
 780 
 781           if ^fok then
 782                goto l7;
 783 
 784           if no_ind then
 785                goto l7;
 786 
 787           if tag then
 788                if substr (p1 -> reference.tag, 3, 4) then
 789                     goto l7;
 790 
 791           if substr (p1 -> reference.tag, 1, 2) then
 792                base = base_man$load_any_var (2, p1);
 793           else if ^p1 -> reference.shared then
 794                p1 -> reference.ref_count = p1 -> reference.ref_count - 1;
 795 
 796           string (ref -> address) = string (p1 -> address);
 797           ref -> reference.relocation = p1 -> reference.relocation;
 798 
 799           if tag then
 800                ref -> address.tag = tagind;
 801           else
 802                substr (ref -> address.tag, 1, 2) = ri_mod;
 803 
 804           p1 -> reference.perm_address = "0"b;
 805 
 806           goto seteb1;
 807 
 808 /* can't use the qualifier via indirection, have to load
 809              it into a base register */
 810 
 811 l7:
 812           ref -> address.base = base_man$load_any_var (1, p1);
 813           p1 -> reference.perm_address = "0"b;
 814 
 815           goto so1;
 816 
 817 %page;
 818 get_c_offset:
 819      proc ();
 820 
 821 dcl      word_off fixed bin (15);
 822 dcl      fract_off fixed bin (6);
 823 
 824           if r1 -> reference.c_offset = 0 then
 825                return;
 826 
 827           word_off = divide (r1 -> reference.c_offset, units_per_word (r1 -> reference.units), 15, 0);
 828           fract_off = mod (r1 -> reference.c_offset, units_per_word (r1 -> reference.units));
 829 
 830           if fract_off ^= 0 then
 831                if r1 -> reference.c_offset < 0 then
 832                     word_off = word_off - 1;
 833 
 834           word_offset = word_offset + word_off;
 835 
 836           if ref -> reference.units = r1 -> reference.units then do;
 837                fract_offset = fract_offset + fract_off;
 838 
 839                if fract_offset >= units_per_word (r1 -> reference.units) then do;
 840                     fract_offset = fract_offset - units_per_word (r1 -> reference.units);
 841                     word_offset = word_offset + 1;
 842                end;
 843           end;
 844 
 845      end get_c_offset;
 846 
 847 
 848 %page;
 849 /* vwo takes on two different meanings depending on the value of eis.  When
 850    eis is "0"b, vwo means variable_word_offset.  However, when eis is "1"b,
 851    vwo refers to variable offset instead of variable_word_offset unless
 852    reference.modword_in_offset is ON.  The EIS instructions take their offsets
 853    in the reference units rather than in word units like the other instructions. */
 854 
 855 get_vwo:
 856      proc (rp);
 857 
 858 dcl      rp ptr parameter;
 859 
 860           have_loaded = "0"b;
 861 
 862           ro = rp;
 863 
 864           vwo = rp -> reference.offset;
 865 
 866           if vwo ^= null then do;
 867                if rp -> reference.units = word_ | rp -> reference.modword_in_offset then do;
 868                     if eis then
 869                          goto call_baseman;
 870                end;
 871                else if ^eis then
 872                     goto print;
 873 
 874                if vwo -> node.type = operator_node then
 875                     vwo = vwo -> operand (1);
 876 
 877                if ^vwo -> reference.shared then
 878                     vwo -> reference.ref_count = vwo -> reference.ref_count + 1;
 879           end;
 880 
 881           return;
 882 
 883 print:
 884           call error (312, cg_stat$cur_statement, rp);
 885           vwo = null;
 886      end get_vwo;
 887 %page;
 888 load_vwo:
 889      proc ();
 890 
 891 dcl      bxr bit (3) aligned;
 892 dcl      aq fixed bin (2);
 893 dcl      baq bit (2) aligned;
 894 
 895 dcl      max_num (18) fixed bin (18) int static
 896               init (1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767, 65535, 131071, 262143);
 897 
 898           xr = -1;
 899 
 900           save_word_offset = word_offset;
 901           save_fract_offset = fract_offset;
 902           base_offset = 0;
 903 
 904           if s1 ^= null then do;
 905                if s1 -> node.type ^= symbol_node then
 906                     goto vwo_1;
 907                if s1 -> symbol.constant & ^ro -> reference.temp_ref & ^(s1 -> symbol.internal & s1 -> symbol.file) then
 908                     goto vwo_1;
 909           end;
 910 
 911           if abs (word_offset) >= 16384 then do;
 912                base_offset = word_offset - mod (word_offset, 16384);
 913                word_offset = word_offset - base_offset;
 914           end;
 915 
 916 vwo_1:
 917           if eis then do;
 918                if base_offset ^= 0 then
 919                     if ro -> reference.units = word_ then
 920                          goto call_baseman;
 921                     else
 922                          base_offset = base_offset * units_per_word (ro -> reference.units);
 923                if ^no_ind then do;
 924                     base_offset = base_offset + fract_offset;
 925                     fract_offset = 0;
 926                     fok = "1"b;
 927                end;
 928           end;
 929 
 930           if dont_load then
 931                goto vwo_3;
 932 
 933           if vwo ^= null then do;
 934 
 935                if eis then do;
 936                     if ro -> reference.big_offset then
 937                          goto large;
 938                     if base_offset > 0 then
 939                          if base_offset + max_num (vwo -> reference.symbol -> symbol.c_dcl_size)
 940                               > max_index_register_value then
 941                               goto large;
 942                end;
 943 
 944                if have_loaded then
 945                     if ^vwo -> reference.shared then
 946                          vwo -> reference.ref_count = vwo -> reference.ref_count + 1;
 947 
 948                have_loaded = "1"b;
 949 
 950 /* can use QL | AL modification if value of offset is in Q|A register
 951                        and we don't have complex data type */
 952 
 953                if s1 -> node.type = symbol_node then
 954                     if s1 -> symbol.complex then
 955                          goto vwo_1a;
 956 
 957                if base_offset ^= 0 then
 958                     goto vwo_1a;
 959 
 960                if vwo -> reference.value_in.q then do;
 961                     tag = "000110"b;                        /* ql */
 962                     tagind = "110110"b;                     /* *ql */
 963 
 964 vwo_1b:
 965                     if ^vwo -> reference.shared then
 966                          vwo -> reference.ref_count = vwo -> reference.ref_count - 1;
 967 
 968                     goto vwo_3;
 969                end;
 970 
 971                if vwo -> reference.value_in.a then do;
 972                     tag = "000101"b;                        /* al */
 973                     tagind = "110101"b;                     /* *al */
 974                     goto vwo_1b;
 975                end;
 976 
 977 vwo_1a:
 978                call xr_man$load_any_var (vwo, xr, (base_offset));
 979                goto vwo_2;
 980           end;
 981 
 982           if base_offset ^= 0 then do;
 983                if base_offset >= 262144 then do;
 984                     call aq_man$load_any_const (base_offset, aq);
 985                     goto vwo_4;
 986                end;
 987                call xr_man$load_any_const ((base_offset), xr);
 988 vwo_2:
 989                bxr = bit (xr, 3);
 990                tag = r_mod || bxr;
 991                tagind = ir_mod || bxr;
 992           end;
 993           else do;
 994                tag = "000000"b;
 995                tagind = "010000"b;
 996           end;
 997 
 998 vwo_3:
 999           if word_offset < 0 then
1000                word_offset = word_offset + 262144;
1001 
1002           return;
1003 
1004 large:
1005           if have_loaded then
1006                goto vwo_3;
1007           call aq_man$load_any_var (vwo, aq, base_offset);
1008 vwo_4:
1009           baq = bit (aq, 2);
1010           tag = aq_mod || baq;
1011           tagind = iaq_mod || baq;
1012           have_loaded = "1"b;
1013           goto vwo_3;
1014 
1015      end load_vwo;
1016 
1017      end m_a;