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-04-21,RWaters), approve(89-04-21,MCR8101), audit(89-04-27,Huen),
  17      install(89-06-16,MR12.3-1059):
  18      Reset the indicators after a call to size_check_fx1/size_check_uns_fx1.
  19   2) change(89-07-10,RWaters), approve(89-07-10,MCR8121), audit(89-08-09,Vu),
  20      install(89-09-22,MR12.3-1073):
  21      Print warning when constants occure on LHS of assignment stmt.
  22                                                    END HISTORY COMMENTS */
  23 
  24 
  25 /* format: style2,^indattr,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */
  26 /* This procedure is called to process the assign operator
  27 %page;
  28    Initial Version: 15 September 1971 by BLW
  29           Modified: 12 February 1973 by BLW
  30           Modified: 16 February 1973 by RAB
  31           Modified: 18 June 1973 by RAB for EIS
  32           Modified: 26 November 1974 by RAB for opt of const bit assmt
  33           Modified: 26 May 1975 by RAB for assign_round
  34           Modified: 21 August 1975 by RAB to fix 1399
  35           Modified: 16 October 1976 by RAB to improve vs = vs || char1;
  36           Modified: 10 November 1976 by RAB to fix 1549
  37           Modified: 25 February 1977 by RAB to fix 1585
  38           Modified: 9 March 1977 by RAB to fix 1593
  39           Modified: 19 March 1977 by RAB for aq_man$left_shift
  40                     and aq_man$right_shift
  41           Modified: 6 May 1977 by RAB to fix 1617 and use load for A(5)'s all_zeros case
  42           Modified: 15 May 1977 by RAB to fix 1621
  43           Modified: 1 September 1977 by RAB to fix 1664 by calling state_man$flush_sym
  44           Modified: 14 September 1977 by RAB to fix 1653
  45           Modified: 10 November 1977 by RAB to make minor string assignment improvement
  46           Modified: 2 December 1977 by RAB to fix 1692
  47           Modified: 16 July 1978 by PCK for unsigned binary
  48           Modified: 11 August 1978 by RAB to fix 1729 & 1754
  49           Modified: 30 November 1978 by RAB to fix 1799 (vs = substr(a,length(vs),b))
  50           Modified: 18 Dec 1978 by RAB to fix 1805 (vs = vs ||vsfun(); for stack frames > 16k)
  51           Modified: 79/04/23 by PCK to implement fixed decimal
  52           Modified: 28 May 1979 by RAB to fix 1827 (vs = substr(a,length(vs)+1))
  53           Modified: 30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
  54                     See prepare_operand for details.
  55           Modified 830118 BIM to copy_temp ptr temps on the LHS. See
  56                    pointer_builtins for more explanation.
  57           Modified 890304 by RWaters to reset the indicators after a call
  58                     to size_check_fx1, and size_check_uns_fx1.
  59           Modified 890715 by RWaters reformatted; print a warning message when
  60                     an options(constant) occures on the LHS of an assignment.
  61 */
  62 %page;
  63 assign_op:
  64      proc (pt);
  65 
  66 /* parameters */
  67           dcl      pt ptr parameter;                        /* points at operator node */
  68 
  69 /* automatic */
  70           dcl      (p, p1, p2, s1, s2, b2, q, q1, q2) ptr;
  71           dcl      exp_pt ptr;
  72           dcl      arg (3) ptr;
  73           dcl      top ptr;
  74           dcl      (a, b, i, type1, type2, k, size1, size2) fixed bin;
  75           dcl      (length1, length2, aq_used, scale1, scale2) fixed bin;
  76           dcl      (prec1, prec2, ds, d, dt, cfo, orig_count, units_per_wrd) fixed bin;
  77           dcl      (atomic, all_blanks, all_ones, all_zeros, all_same) bit (1) aligned;
  78           dcl      (loaded, last_macro, hard1, hard2, here_before) bit (1) aligned;
  79           dcl      (load_it, right_constant, check_size, no_store) bit (1) aligned;
  80           dcl      (pack_char_pic, always_round, refs_are_same) bit (1) aligned;
  81           dcl      base bit (3) aligned;
  82           dcl      tag bit (4) aligned;
  83           dcl      op_code bit (9) aligned;
  84           dcl      full_word bit (36) aligned;
  85           dcl      c_length fixed bin (24);
  86           dcl      word bit (36) aligned based;
  87           dcl      double_string bit (72) aligned;
  88           dcl      (m1, m2, macro, bump_mac, size_ck_macro) fixed bin (15);
  89 
  90 /* external */
  91           dcl      cg_stat$cur_level fixed bin external;
  92           dcl      cg_stat$cur_statement ptr external;
  93           dcl      cg_stat$cur_tree ptr ext;
  94           dcl      cg_stat$null_value bit (72) aligned external;
  95           dcl      cg_stat$packed_null_value fixed bin external;
  96           dcl      cg_stat$save_exp_called bit (1) external;
  97           dcl      cg_stat$temp_ref ptr external;
  98           dcl      cg_stat$text_base ptr external;
  99           dcl      cg_stat$text_pos fixed bin external;
 100 
 101 /* entries */
 102           dcl      adjust_ref_count entry (ptr, fixed bin);
 103 
 104           dcl      aq_man$check_strings entry (fixed bin);
 105           dcl      aq_man$left_shift entry (fixed bin (8), bit (1) aligned);
 106           dcl      aq_man$lock entry (ptr, fixed bin);
 107           dcl      aq_man$right_shift entry (fixed bin (8), bit (1) aligned);
 108           dcl      aq_man$trim_aq entry (fixed bin);
 109 
 110           dcl      base_to_core entry (fixed bin, ptr);
 111           dcl      base_man$load_any_var entry (fixed bin, ptr) returns (bit (3) aligned);
 112           dcl      base_man$load_packed entry (ptr, fixed bin);
 113           dcl      base_man$load_var entry (fixed bin, ptr, fixed bin);
 114           dcl      base_man$store_ptr_to entry (ptr, ptr);
 115           dcl      base_man$update_base entry (fixed bin, ptr, fixed bin);
 116 
 117           dcl      compile_exp entry (ptr);
 118           dcl      compile_exp$save entry (ptr) returns (ptr);
 119           dcl      compile_exp$save_exp entry (ptr) returns (ptr);
 120           dcl      copy_temp entry (ptr) returns (ptr);
 121           dcl      compare_expression entry (ptr, ptr) reducible returns (bit (1) aligned);
 122           dcl      convert_chars entry (ptr, ptr, bit (1) aligned, bit (1) aligned);
 123           dcl      convert_arithmetic entry (ptr, ptr, bit (1) aligned, bit (1) aligned);
 124           dcl      c_a entry (fixed bin, fixed bin) returns (ptr);
 125           dcl      decimal_op$get_float_temp entry (fixed bin (24), bit (1) aligned) returns (ptr);
 126           dcl      error entry (fixed bin, ptr, ptr);
 127           dcl      expmac entry (fixed bin (15), ptr);
 128           dcl      expmac$one entry (fixed bin (15), ptr, fixed bin);
 129           dcl      expmac$zero entry (fixed bin (15));
 130           dcl      expmac$many entry (fixed bin (15), ptr, fixed bin);
 131           dcl      expmac$many_eis entry (fixed bin (15), ptr, fixed bin);
 132           dcl      expmac$one_eis entry (fixed bin (15), ptr);
 133           dcl      expmac$two_eis entry (fixed bin (15), ptr, ptr);
 134 
 135           dcl      fixed_to_float entry (ptr);
 136           dcl      float_to_fixed entry (ptr);
 137           dcl      generate_constant entry (bit (*) aligned, fixed bin) returns (ptr);
 138           dcl      generate_constant$real_fix_bin_1 entry (fixed bin) returns (ptr);
 139           dcl      generate_constant$bit_string entry (bit (*) aligned, fixed bin) returns (ptr);
 140           dcl      generate_constant$char_string entry (char (*) aligned, fixed bin) returns (ptr);
 141           dcl      get_imaginary entry (ptr) returns (ptr);
 142           dcl      get_single_ref entry (ptr) returns (ptr);
 143           dcl      load entry (ptr, fixed bin);
 144           dcl      load$for_store entry (ptr, fixed bin);
 145           dcl      load$long_string entry (ptr);
 146           dcl      load$short_string entry (ptr, fixed bin);
 147           dcl      load_prog entry (ptr, fixed bin) variable;
 148           dcl      load_size entry (ptr);
 149           dcl      load_size$xr_or_aq entry (ptr, bit (4) aligned);
 150           dcl      long_op$one_eis entry (ptr, fixed bin, fixed bin (15));
 151           dcl      long_op$extend_stack entry (ptr, fixed bin (15));
 152           dcl      make_n_addressable entry (ptr, fixed bin);
 153           dcl      m_a entry (ptr, bit (2) aligned);
 154           dcl      make_both_addressable entry (ptr, ptr, bit (1) aligned);
 155           dcl      need_temp entry (ptr, bit (2) aligned);
 156           dcl      move_data$move_block entry (ptr, ptr, fixed bin);
 157           dcl      picture_op entry (ptr);
 158           dcl      prepare_operand entry (ptr, fixed bin, bit (1) aligned) returns (ptr);
 159           dcl      stack_temp$assign_temp entry (ptr);
 160           dcl      state_man$erase_reg entry (bit (19) aligned);
 161           dcl      state_man$flush_ref entry (ptr);
 162           dcl      state_man$flush_sym entry (ptr);
 163           dcl      store entry (ptr);
 164           dcl      store$all_ones entry (ptr);
 165           dcl      store$force entry (ptr);
 166           dcl      store$save_string_temp entry (ptr);
 167           dcl      xr_man$load_const entry (fixed bin, fixed bin);
 168 
 169 /* builtins */
 170           dcl      (abs, addr, addrel, bit, divide, fixed, max, min, mod, null, string, substr, verify) builtin;
 171 
 172 /* other stuff */
 173           dcl      assign_info$assign_info (14, 14) fixed bin ext,
 174                    1 assign_info aligned based,             /* image of ext structure */
 175                      2 act_a unal bit (6),
 176                      2 act_b unal bit (6),
 177                      2 macro_1 unal bit (12),
 178                      2 macro_2 unal bit (12);
 179 
 180           dcl      (
 181                    assign_label_to_int init (379),
 182                    rflb1_to_cflb1 init (390),
 183                    set_label_const (2) init (315, 285),
 184                    ldfl1 init (9),
 185                    alloc_char_temp init (89),
 186                    chars_move init (420),
 187                    chars_move_vt init (444),
 188                    cat_move_chars init (218),
 189                    sbfx1 init (22),
 190                    aos_mac init (309),
 191                    incr_mac init (310),
 192                    lda init (1),
 193                    ansa init (43),
 194                    longbs_to_fx2 init (132),
 195                    cpfx1 init (136),
 196                    lrl init (62),
 197                    lrs init (492),
 198                    lls init (63),
 199                    move_chars init (98),
 200                    oraq init (48),
 201                    stfx1 init (15),
 202                    sta init (4),
 203                    fx1_to_bs init (293),
 204                    blank_cs init (472),
 205                    zero_bs init (468),
 206                    one_bs init (469),
 207                    zero_cs init (419),
 208                    one_cs init (484),
 209                    zero_cs_q init (479),
 210                    b2c_mac init (108),
 211                    size_check_fx1 init (553),
 212                    chars_move_ck init (555),
 213                    signal_stringsize init (563),
 214                    size_ck_varying init (566),
 215                    size_ck_suffix init (567),
 216                    size_ck_decimal init (582),
 217                    cmp_suffix_1 init (220),
 218                    size_ck_suffix_1 init (698),
 219                    left_shift (2) init (515, 63),
 220                    truncate (2) init (520, 521),
 221                    min_fx1 init (247),
 222                    zero_mac init (308),
 223                    zero_mac_p_1 init (307),
 224                    move_decimal init (438),
 225                    multiply_decimal init (450),
 226                    make_lv init (173),
 227                    store_lv init (174),
 228                    size_check_uns_fx1 init (731),
 229                    uns_fx1_to_bs init (733)
 230                    ) fixed bin (15) int static options (constant);
 231 
 232           dcl      ptr_convert (23:24, 23:24) fixed bin (15) int static init (0, 407, 408, 0);
 233 
 234           dcl      based_bs bit (size2) aligned based,
 235                    based_cs char (length2) aligned based;
 236 
 237           dcl      1 instruction based aligned,             /* layout of first word of EIS instruction */
 238                      2 fill char (1) unal,                  /* fill character -- can be set by assign_op */
 239                      2 enablefault bit (1) unal,
 240                      2 pad1 bit (1) unal,
 241                      2 mf2 bit (7) unal,
 242                      2 opcode bit (10) unal,
 243                      2 inhibit bit (1) unal,
 244                      2 mf1 bit (7) unal;
 245 
 246           dcl      1 exponent aligned,                      /* layout of floating decimal exponent character */
 247                      2 pad bit (1) unal,
 248                      2 value fixed bin (7) unal;
 249 
 250           dcl      exponent_char char (1) based (addr (exponent)) aligned;
 251 
 252 /* CONSTANTS */
 253 
 254           dcl      TRUE bit (1) aligned int static options (constant) init ("1"b);
 255           dcl      FALSE bit (1) aligned int static options (constant) init ("0"b);
 256 
 257 %page;
 258 %include cgsystem;
 259 %page;
 260 %include statement;
 261 %page;
 262 %include operator;
 263 %page;
 264 %include reference;
 265 %page;
 266 %include symbol;
 267 %page;
 268 %include block;
 269 %page;
 270 %include nodes;
 271 %page;
 272 %include bases;
 273 %page;
 274 %include data_types;
 275 %page;
 276 %include machine_state;
 277 %page;
 278 %include op_codes;
 279 %page;
 280 %include boundary;
 281 %page;
 282 /* program */
 283 
 284           load_prog = load$for_store;
 285 
 286           all_blanks, all_ones, all_zeros, all_same, loaded, here_before, full_word, no_store, pack_char_pic, last_macro =
 287                FALSE;
 288 
 289           p = pt;
 290           op_code = p -> operator.op_code;
 291           check_size = (op_code = assign_size_ck);
 292           always_round = (op_code = assign_round);
 293 
 294           p1 = prepare_operand ((p -> operand (1)), 1, atomic);
 295           orig_count = p1 -> reference.ref_count;
 296 
 297           exp_pt, p2 = p -> operand (2);
 298           if p2 -> node.type = operator_node | p2 -> node.type = label_node | ^p2 -> reference.temp_ref then
 299                p2 = prepare_operand (p2, 1, atomic);
 300           else
 301                atomic = TRUE;
 302 
 303 gt:
 304           s1 = p1 -> reference.symbol;
 305           s2 = p2 -> reference.symbol;
 306 
 307           scale1 = s1 -> symbol.scale;
 308           prec1 = s1 -> symbol.c_dcl_size;
 309 
 310           right_constant = FALSE;
 311 
 312           type2 = p2 -> reference.data_type;
 313 
 314           if s2 -> node.type = label_node then do;
 315                type1 = p1 -> reference.data_type;
 316                goto lab_or_ent;
 317           end;
 318 
 319           scale2 = s2 -> symbol.scale;
 320           prec2 = s2 -> symbol.c_dcl_size;
 321 
 322           if s1 -> symbol.storage_block & ^here_before then do;
 323                type1, p1 -> reference.data_type = type2;
 324                p1 -> reference.c_length = p2 -> reference.c_length;
 325                if type1 = char_string | type2 = bit_string then
 326                     p1 -> reference.long_ref = p1 -> reference.c_length * convert_size (type1) > bits_per_two_words;
 327           end;
 328           else
 329                type1 = p1 -> reference.data_type;
 330 
 331           here_before = TRUE;
 332 
 333           dt = type1 - char_string;
 334 
 335           if type2 ^= bit_string then
 336                if type2 ^= char_string then
 337                     goto chk_temp;
 338 
 339           length2 = p2 -> reference.c_length;
 340           size2 = length2 * convert_size (type2);
 341 
 342           if op_code = pack then
 343                if type2 = char_string then
 344                     if substr (cg_stat$cur_statement -> statement.prefix, 5, 1) then
 345                          pack_char_pic = TRUE;
 346 
 347           if atomic then do;
 348                if ^s2 -> symbol.constant then
 349                     goto chk_temp;
 350                if s2 -> symbol.varying then
 351                     goto chk_temp;
 352                if s2 -> symbol.dimensioned then
 353                     goto chk_temp;
 354                if p2 -> reference.offset ^= null then
 355                     goto chk_temp;
 356                if p2 -> reference.length ^= null then
 357                     goto chk_temp;
 358                if p2 -> reference.c_offset ^= 0 then
 359                     goto chk_temp;
 360                if p2 -> reference.temp_ref then
 361                     goto chk_temp;
 362 
 363                right_constant = TRUE;
 364 
 365                q = s2 -> symbol.initial;
 366 
 367                if type2 = char_string then do;
 368                     if length2 > 0 then do;
 369                          all_same = verify (q -> based_cs, substr (q -> based_cs, 1, 1)) = 0;
 370                          if all_same then
 371                               all_blanks = substr (q -> based_cs, 1, 1) = " ";
 372                     end;
 373                     else
 374                          all_same, all_blanks = TRUE;
 375                end;
 376                else do;
 377                     all_ones = (^q -> based_bs = FALSE);
 378                     all_zeros = (q -> based_bs = FALSE);
 379                end;
 380           end;
 381 
 382 chk_temp:
 383           if ^p1 -> reference.temp_ref then
 384                goto get_info;
 385           if p1 -> reference.defined_ref then
 386                goto get_info;
 387           if p1 -> reference.aggregate then
 388                goto get_info;
 389 
 390 /* have temporary on left of assignment */
 391 
 392           if p1 -> reference.length = null then do;
 393 
 394                load_prog = load;
 395 
 396                if p1 -> reference.allocate then do;
 397                     if ^p1 -> reference.allocated then
 398                          call stack_temp$assign_temp (p1);
 399                     if p1 -> reference.ref_count = 1 then
 400                          p1 -> reference.ref_count = 2;
 401                     goto get_info;
 402                end;
 403 
 404                if ^p1 -> reference.long_ref then do;
 405                     no_store = TRUE;
 406                     goto get_info;
 407                end;
 408 
 409           end;
 410 
 411 /* have long (string) temp = something */
 412 
 413           if type1 ^= type2 then do;
 414                p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
 415                call long_op$extend_stack (p1, alloc_char_temp + dt);
 416                call store$save_string_temp (p1);
 417                goto get_info;
 418           end;
 419 
 420           if ^atomic then
 421                p2 = compile_exp$save (exp_pt);
 422 
 423           call long_op$extend_stack (p1, alloc_char_temp + dt);
 424           if cg_stat$save_exp_called then
 425                call store$save_string_temp (p1);
 426           call expmac$two_eis (move_chars + dt, p1, p2);
 427 
 428           goto done;
 429 
 430 get_info:
 431           if atomic then
 432                goto gi;
 433 
 434           if type2 <= real_flt_bin_2 then
 435                k = 1;
 436           else do;
 437                if type2 ^= type1 then
 438                     goto gi;
 439                if type2 < char_string then
 440                     goto gi;
 441                if type2 > bit_string then
 442                     goto gi;
 443 
 444                if pack_char_pic then
 445                     goto gi;
 446                if p1 -> reference.varying_ref then
 447                     goto gi;
 448                if p1 -> reference.length ^= null then
 449                     goto gi;
 450 
 451                k = 0;
 452           end;
 453 
 454 /* if the right hand side is another assign operator which only changes the
 455  * precision of its operand(2) (case k = 1) or another assignment to a
 456  * string temporary (case k = 0) we'll try to eliminate the extra assign
 457  */
 458 
 459           if exp_pt -> node.type ^= operator_node then
 460                goto gi;
 461           if exp_pt -> operator.op_code ^= assign then
 462                goto gi;
 463           if exp_pt -> operator.operand (1) -> reference.ref_count > 1 then
 464                goto gi;
 465 
 466           if k = 0 then do;
 467                if p2 -> reference.varying_ref then
 468                     goto gi;
 469                if p2 -> reference.length ^= null then
 470                     goto gi;
 471 
 472 /* we can eliminate assignment if length of right side temporary
 473  * is equal to length of left side temp
 474  */
 475                if p1 -> reference.c_length = p2 -> reference.c_length then
 476                     goto elim;
 477           end;
 478 
 479 /* we have to restore the original value of the data type field
 480  * of operand(2) if it is a reference because if we dont, prepare_operand
 481  * will get confused and not evaluate the offset expression (if any)
 482  */
 483 
 484           q2 = exp_pt -> operand (2);
 485           if q2 -> node.type = operator_node then
 486                q2 = q2 -> operand (1);
 487 
 488           m1 = q2 -> reference.data_type;
 489 
 490           q2 = prepare_operand (q2, 0, atomic);
 491 
 492           m2 = q2 -> reference.data_type;
 493           q2 -> reference.data_type = m1;
 494 
 495           if k = 0 then do;
 496                if p1 -> reference.c_length < p2 -> reference.c_length then
 497                     if type2 ^= m2 then
 498                          goto repair;
 499                     else
 500                          goto elim;
 501 
 502 /* must have p1 -> c_length > p2 -> c_length */
 503 
 504 /* q2 -> reference.c_length won't be in the same units as for p2,
 505  * but it still gives a reasonable indication of safety unless q2
 506  * is decimal.  This fixes 1653
 507  */
 508                if type2 ^= m2 then
 509                     if m2 >= real_fix_dec & m2 <= complex_flt_dec then
 510                          goto repair;
 511 
 512                if q2 -> reference.varying_ref then
 513                     goto repair;
 514                if q2 -> reference.length ^= null then
 515                     goto repair;
 516 
 517                if p2 -> reference.c_length < q2 -> reference.c_length then
 518                     goto repair;
 519 
 520 /* eliminate the assignment */
 521 
 522 elim:
 523                p2, exp_pt = exp_pt -> operand (2);
 524                if k = 0 then do;
 525                     p2 = prepare_operand (p2, 1, atomic);
 526                     goto gt;
 527                end;
 528                p2 = prepare_operand (p2, 1, atomic);
 529                goto gi;
 530           end;
 531 
 532 /* k = 1 at this point */
 533 
 534           if type2 = m2 then
 535                goto elim;
 536 
 537 repair:
 538           atomic = FALSE;
 539 
 540 gi:
 541           if type2 > bit_string then
 542                goto LABEL_ENTRY_OR_PTR;
 543 
 544           q = addr (assign_info$assign_info (type1, type2));
 545           a = fixed (q -> assign_info.act_a, 6);
 546           b = fixed (q -> assign_info.act_b, 6);
 547           m1 = fixed (q -> assign_info.macro_1, 12);
 548           m2 = fixed (q -> assign_info.macro_2, 12);
 549 
 550           if pack_char_pic then do;
 551                a = 2;
 552                b = 2;
 553           end;
 554 
 555 /* MR12.3: print a sev 2 warning about assignments to an
 556  * options(constant) variable
 557  */
 558           if p1 -> reference.symbol -> symbol.alloc_in_text then
 559                call error (134, cg_stat$cur_statement, null);
 560 
 561           goto A (a);
 562 %page;
 563 /* unimplemented conversion */
 564 
 565 A (0):
 566           call error (331, cg_stat$cur_statement, null);
 567           goto done;
 568 %page;
 569 /* ordinary arithmetic assignment */
 570 
 571 A (1):
 572           if p1 -> reference.aligned_for_store_ref then do;
 573 A1a:
 574                if atomic then
 575                     call load_prog (p2, 0);
 576                else
 577                     call compile_exp (exp_pt);
 578                goto B (b);
 579           end;
 580 
 581 /* have assignment to packed arithmetic value */
 582 
 583           if type1 ^= type2 then
 584                goto A1a;
 585 
 586           if ^atomic then
 587                if exp_pt -> node.type = operator_node then
 588                     goto A1a;
 589 
 590           if p2 -> reference.ref_count > 1 then
 591                goto A1a;
 592 
 593           if check_size then
 594                if type1 = real_fix_bin_1 then
 595                     if prec1 < prec2 then
 596                          goto A1a;
 597 
 598 /* have atom on right */
 599 
 600           size1 = p1 -> reference.c_length;
 601 
 602           if type1 = real_fix_bin_1 then do;
 603 
 604                if s2 -> symbol.constant then do;
 605 
 606                     if s2 -> symbol.packed & ^p2 -> reference.aligned_ref then
 607                          goto fake_bit;
 608 
 609                     if p2 -> reference.offset ^= null then
 610                          goto A1b;
 611                     if p2 -> reference.c_offset ^= 0 then
 612                          goto A1b;
 613 
 614                     p2 = generate_constant$bit_string (
 615                          substr (s2 -> symbol.initial -> word, bits_per_word - size1 + 1, size1), size1);
 616 
 617 /* now treat assignment as if we were assigning bit strings */
 618 
 619 fake_bit:
 620                     check_size = FALSE;
 621 
 622                     if prec1 = prec2 then
 623                          if s1 -> symbol.unsigned = s2 -> symbol.unsigned then
 624                               if p1 -> reference.hard_to_load | p2 -> reference.hard_to_load then do;
 625                                    dt = 1;
 626                                    goto short_eis;
 627                               end;
 628 
 629                     call load$for_store (p2, 0);
 630 
 631                     aq_used = a_reg.offset + a_reg.size;
 632 
 633                     k = size1 - a_reg.size;
 634                     if k < 0 then do;                       /* right side is larger than we need */
 635                          call aq_man$check_strings (aq_used + k);
 636                          a_reg.offset = a_reg.offset - k;
 637                     end;
 638                     else if k > 0 then do;                  /* right side has less precision than we need */
 639                          if a_reg.offset > 0 then
 640                               call aq_man$left_shift (a_reg.offset, "0"b);
 641 
 642                          if s2 -> symbol.unsigned then
 643                               macro = lrl;
 644                          else
 645                               macro = lrs;
 646 
 647                          call expmac (macro, c_a (k, 1));
 648 
 649                     end;
 650 
 651                     a_reg.size = size1;
 652                     p1 -> reference.data_type = bit_string;
 653                     goto l1;
 654                end;
 655 
 656 A1b:
 657                if p2 -> reference.aligned_ref then
 658                     goto A1a;
 659                if p2 -> reference.value_in.q then
 660                     goto A1a;
 661 
 662                if scale1 ^= scale2 then
 663                     goto A1a;
 664 
 665 /* have packed fixed single on right, too */
 666 
 667                p2 -> reference.data_type = bit_string;
 668                goto fake_bit;
 669           end;
 670 
 671           if p2 -> reference.value_in.q then
 672                goto A1a;
 673 
 674           if type1 = real_flt_bin_1 | type1 = real_flt_bin_2 then do;
 675                type1, p1 -> reference.data_type, p2 -> reference.data_type = bit_string;
 676 
 677                call load_prog (p2, type2 - real_flt_bin_1);
 678 
 679                size2 = p2 -> reference.c_length;
 680                goto string_store_check;
 681           end;
 682 
 683           goto A1a;
 684 %page;
 685 /* char string and decimal conversion */
 686 
 687 A (2):
 688           if ^atomic then
 689                p2 = compile_exp$save_exp (exp_pt);
 690           goto B (b);
 691 %page;
 692 /* left side is complex */
 693 
 694 A (3):
 695           if atomic then do;
 696                call expmac (m2, p2);
 697                goto l1;
 698           end;
 699 
 700           call compile_exp (exp_pt);
 701           m2 = 0;
 702           goto B (b);
 703 %page;
 704 /* right side is complex float single binary */
 705 
 706 A (4):
 707           if ^atomic then do;
 708                p2 = compile_exp$save_exp (exp_pt);
 709                if exp_pt -> node.type ^= operator_node then
 710                     goto B (4);
 711           end;
 712 
 713           if type1 = complex_flt_bin_1 then do;
 714                call load_prog (p2, 0);
 715                goto l1;
 716           end;
 717 
 718           call expmac ((ldfl1), p2);
 719           loaded = TRUE;
 720           if scale1 ^= 0 then
 721                b = 7;
 722           goto B (b);
 723 %page;
 724 /* have string = string */
 725 
 726 A (5):
 727           length1 = p1 -> reference.c_length;
 728           size1 = length1 * convert_size (type1);
 729           d = fixed (size1 > bits_per_word, 1);
 730 
 731           all_same = all_same & ((length1 = length2 & p1 -> reference.length = null) | all_blanks);
 732           all_ones = all_ones & (length1 = length2 & p1 -> reference.length = null);
 733 
 734           hard1 = p1 -> reference.hard_to_load;
 735           hard2 = p2 -> reference.hard_to_load;
 736           if ^hard2 then
 737                if p2 -> reference.long_ref then
 738                     if p2 -> reference.units < word_ then
 739                          hard2 = size1 > bits_per_word;
 740 
 741           if ^check_size then
 742                goto A5a;
 743           if p1 -> reference.length ^= null then
 744                goto A5a;
 745           if p2 -> reference.length ^= null then
 746                goto A5a;
 747 
 748           call check_stringsize;
 749 
 750 /* the following code tries to improve string assignments by using
 751  * an MLR or ldaq-staq seq
 752  */
 753 
 754 A5a:
 755           if p1 -> reference.varying_ref then
 756                goto A5c;
 757           if p1 -> reference.length ^= null then
 758                goto A5c;
 759           if ^p1 -> reference.aligned_for_store_ref then
 760                goto A5c;
 761 
 762           if no_store then
 763                goto A5c;
 764 
 765           if ^p2 -> reference.aligned_ref then
 766                goto A5c;
 767           if p2 -> reference.varying_ref then
 768                goto A5c;
 769           if p2 -> reference.length ^= null then
 770                goto A5c;
 771           if ^p2 -> reference.long_ref then
 772                goto A5c;
 773 
 774           if all_same | all_ones | all_zeros then
 775                if size1 > break_even_bits then
 776                     goto A5c;
 777 
 778           if length1 > length2 then
 779                goto A5c;
 780 
 781           if ^(mod (size1, bits_per_word) = 0 | p1 -> reference.long_ref) then
 782                goto A5c;
 783 
 784           if mod (size1, bits_per_word) = 0 | p1 -> reference.padded_for_store_ref then do;
 785 
 786                if ^atomic then
 787                     call compile_exp (exp_pt);
 788 
 789                call move_data$move_block (p1, p2, divide (size1 + bits_per_word - 1, bits_per_word, 17, 0));
 790                goto done;
 791           end;
 792 
 793 A5c:
 794           if atomic then do;
 795 
 796 A5ca:
 797                if ^p1 -> reference.varying_ref then
 798                     goto chk;
 799 
 800 /* have varying string on left */
 801 
 802                if p2 -> reference.length ^= null then
 803                     goto l9;
 804                if p2 -> reference.varying_ref then
 805                     goto l9;
 806 
 807                if length2 = 0 then do;
 808                     p1 -> reference.c_offset = p1 -> reference.c_offset - 1;
 809                     call expmac ((zero_mac), p1);
 810                     p1 -> reference.c_offset = p1 -> reference.c_offset + 1;
 811                     call state_man$flush_ref (p1);          /* p1 might have been in indicators */
 812                     goto done;
 813                end;
 814 
 815                if p1 -> reference.length ^= null then
 816                     goto l9;
 817 
 818                load_prog = load;
 819 
 820                if ^hard2 then do;
 821                     if ^p2 -> reference.long_ref then do;
 822                          call load_prog (p2, d);
 823                          goto string_store_work;
 824                     end;
 825 
 826                     if ^p1 -> reference.long_ref then do;
 827                          call load$short_string (p2, d);
 828                          goto string_store_work;
 829                     end;
 830                end;
 831 
 832                goto l9;
 833 
 834 chk:
 835                if p1 -> reference.long_ref then do;
 836 
 837 l9:
 838 lg:
 839                     if ^p1 -> reference.varying_ref then do;
 840                          call state_man$flush_sym ((p1 -> reference.symbol));
 841                          call eis_move;
 842                          goto done;
 843                     end;
 844 
 845 /* have varying string on left, must set cur length */
 846 
 847                     if p1 -> reference.length ^= p2 -> reference.length then
 848                          arg (1) = get_length_in_storage (p1);
 849                     else
 850                          arg (1) = get_length (p1);
 851 
 852                     if p2 -> reference.varying_ref then do;
 853 
 854                          call load_size (p2);
 855 
 856                          if arg (1) = null then
 857                               if s2 -> symbol.c_dcl_size <= length1 & s2 -> symbol.dcl_size = null then
 858                                    goto l11;
 859                               else
 860                                    arg (1) = generate_constant$real_fix_bin_1 (length1);
 861 
 862                          goto l10;
 863                     end;
 864 
 865                     arg (2) = get_length (p2);
 866 
 867                     if arg (1) = null then
 868                          if arg (2) = null then do;
 869                               call load (generate_constant$real_fix_bin_1 (min (length1, length2)), 0);
 870                               goto l11;
 871                          end;
 872                          else
 873                               arg (1) = generate_constant$real_fix_bin_1 (length1);
 874                     else if arg (2) = null then
 875                          arg (2) = generate_constant$real_fix_bin_1 (length2);
 876 
 877                     call load (arg (2), 0);
 878 
 879                     if arg (1) = arg (2) then do;
 880                          if ^arg (1) -> reference.shared then
 881                               arg (1) -> reference.ref_count = arg (1) -> reference.ref_count - 1;
 882                          goto l11;
 883                     end;
 884 
 885 l10:
 886                     if p2 -> reference.ref_count = 1 then
 887                          call need_temp (p2, "01"b);
 888                     if check_size then
 889                          macro = size_ck_varying;
 890                     else
 891                          macro = min_fx1;
 892                     if arg (1) -> reference.data_type = real_fix_bin_2 then
 893                          arg (1) = get_single_ref (arg (1));
 894                     call expmac (macro, arg (1));
 895 
 896 l11:
 897                     refs_are_same = compare_refs (p1, p2);
 898 
 899                     if ^refs_are_same & p2 -> reference.offset ^= null then do;
 900 
 901 /* the offset of p2 may be length(p1) (either as a
 902  * reference node or as an operator node), so we
 903  * should be careful to see that it is loaded before
 904  * the length(p1) is changed.  We use aq_man$lock
 905  * and make_n_addressable to ensure that registers
 906  * stay locked.  Fixes 1799 and 1827.
 907  */
 908 
 909                          call aq_man$lock (null, 2);
 910                          arg (1) = p2;
 911                          call make_n_addressable (addr (arg), 1);
 912                     end;
 913 
 914                     call expmac_length_of_varying (stfx1, p1);
 915 
 916                     if ^refs_are_same then
 917                          call expmac$two_eis (chars_move_vt + dt, p1, p2);
 918                     else do;
 919                          if ^p2 -> reference.shared then
 920                               call adjust_ref_count (p2, -1);
 921                          if ^p1 -> reference.shared then
 922                               call adjust_ref_count (p1, -1);
 923                     end;
 924 
 925                     goto done;
 926                end;
 927 
 928 /* string on left is short */
 929 
 930                if p2 -> reference.varying_ref then
 931                     goto short_eis;
 932 
 933                if hard1 | hard2 then
 934                     goto short_eis;
 935 
 936                if p2 -> reference.long_ref then
 937                     if p2 -> reference.length = null then
 938                          call load$short_string (p2, d);
 939                     else do;
 940 short_eis:
 941                          if no_store then
 942                               p1 = copy_temp (p1);
 943 
 944                          if p1 -> reference.aligned_for_store_ref then
 945                               if mod (size1, bits_per_word) ^= 0 then do;
 946                                    if size1 < bits_per_word then
 947                                         macro = zero_mac;
 948                                    else
 949                                         macro = zero_mac_p_1;
 950                                    if ^p1 -> reference.shared then
 951                                         p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
 952                                    call expmac (macro, p1);
 953                               end;
 954 
 955                          call state_man$flush_sym ((p1 -> reference.symbol));
 956 
 957                          call eis_move;
 958 
 959                          if p1 -> reference.temp_ref then
 960                               if cg_stat$save_exp_called then
 961                                    call adjust_ref_count (p1, -1);
 962                               else if cg_stat$cur_tree ^= p then do;
 963                                    if ^no_store then
 964                                         p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
 965                                    call load (p1, d);
 966                               end;
 967 
 968                          goto done;
 969                     end;
 970                else if all_zeros then do;
 971 
 972                     if p1 -> reference.temp_ref then do;
 973                          call load_prog (p2, d);
 974                          goto string_store_work;
 975                     end;
 976 
 977                     if p1 -> reference.aligned_for_store_ref then
 978                          if size1 <= bits_per_word then
 979                               goto zm;
 980                          else do;
 981                               call load_prog (p2, d);
 982                               goto string_store_work;
 983                          end;
 984 
 985 /* we'll zero the string by generating an and to storage
 986  * macro using a mask with 0's in the field occupied
 987  * by the string
 988  */
 989 
 990                     call state_man$flush_ref (p1);
 991                     double_string = (72)"1"b;
 992                     cfo = mod (p1 -> reference.c_offset * convert_offset (p1 -> reference.units), bits_per_word);
 993                     substr (double_string, cfo + 1, size1) = "0"b;
 994 
 995                     d = fixed (cfo + size1 > bits_per_word, 1);
 996                     p2 = generate_constant (double_string, d + 1);
 997                     call load (p2, d);
 998                     call expmac$one ((ansa), p1, d);
 999                     goto done;
1000                end;
1001                else if right_constant then do;
1002                     if p1 -> reference.aligned_for_store_ref then do;
1003                          call load_prog (p2, d);
1004                          goto string_store_work;
1005                     end;
1006 
1007 /* we have a string constant being assigned to a variable
1008  * with a non-zero offset, we'll generate another constant
1009  * which is already shifted
1010  */
1011 
1012                     cfo = mod (p1 -> reference.c_offset * convert_offset (p1 -> reference.units), bits_per_word);
1013                     if cfo + size1 > bits_per_two_words then do;
1014                          call load_prog (p2, d);
1015                          goto string_store_work;
1016                     end;
1017 
1018                     double_string = (72)"0"b;
1019                     substr (double_string, cfo + 1, size1) = s2 -> symbol.initial -> based_bs;
1020                     d = fixed (cfo + size1 > bits_per_word, 1);
1021                     p2 = generate_constant (double_string, d + 1);
1022 
1023                     call expmac$one ((lda), p2, d);
1024                     a_reg.offset = cfo;
1025                     a_reg.size = size2;
1026                     a_reg.length = bits_per_word * (d + 1);
1027                     goto string_store_work;
1028                end;
1029                else do;
1030                     call load_prog (p2, d);
1031                     goto string_store_work;
1032                end;
1033 
1034                goto string_store_work;
1035           end;
1036 
1037           if exp_pt -> node.type ^= operator_node then
1038                goto A5ca;
1039 
1040 /* string on right is not atomic */
1041 
1042           if ^p1 -> reference.varying_ref then
1043                goto l4;
1044 
1045 /* following code looks for the case
1046  *         vs = vs || something
1047  * where vs is a varying string.  note that we can't use
1048  * compare_expression directly because ref node for
1049  * vs on LHS has a length field and ref node on RHS has
1050  * 0 length field
1051  */
1052 
1053           if exp_pt -> operator.op_code ^= cat_string then
1054                goto l4;
1055 
1056           q = exp_pt -> operand (2);
1057           if q -> reference.c_length ^= 0 then
1058                goto l4;
1059           if q -> reference.length ^= null then
1060                goto l4;
1061 
1062           if ^compare_refs (p1, q) then
1063                goto l4;
1064 
1065 /* We have the case
1066  *             vs = vs || something;
1067  * so we can move something to the end of vs
1068  */
1069 
1070           q = prepare_operand (q, -1, atomic);
1071 
1072           q1 = prepare_operand ((exp_pt -> operand (3)), 1, atomic);
1073           if ^atomic then
1074                if q1 -> reference.long_ref then
1075                     call compile_exp ((exp_pt -> operand (3)));
1076                else
1077                     q1 = compile_exp$save_exp ((exp_pt -> operand (3)));
1078 
1079 /* We should bump down some reference counts for unneeded temps
1080  * associated with result of cat_string operator
1081  */
1082 
1083           call adjust_suff_temp ((exp_pt -> operand (1)));
1084 
1085 /* get a ptr to the operand to be used in the subsequent compare.
1086  * We make the call now because this operand may need to be unpacked
1087  * which would emit code.  This fixes 1754
1088  */
1089 
1090           if q1 -> reference.c_length ^= 1 then
1091                q2 = get_suffix_length (q1);
1092           else
1093                q2 = get_suffix_length (p1);
1094 
1095 /* make the varying string addressable without a tag */
1096 
1097           call m_a (p1, "10"b);
1098 
1099           if p1 -> address.tag then do;
1100                if ^p1 -> reference.shared then
1101                     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1102                base = base_man$load_any_var (2, p1);
1103                if p1 -> reference.ref_count = 1 then
1104                     call need_temp (p1, "10"b);
1105           end;
1106 
1107 /* erase and lock the q register and force both operands to be addressable,
1108  * erase and locking the involved registers
1109  */
1110 
1111           call state_man$erase_reg ("01"b);
1112           call aq_man$lock (null, 2);
1113           arg (1) = p1;
1114           arg (2) = q1;
1115           p1 -> reference.perm_address = TRUE;
1116           call make_n_addressable (addr (arg), 2);
1117           p1 -> reference.perm_address = FALSE;
1118 
1119           if q1 -> reference.c_length ^= 1 then do;         /* get the room left in the varying string for the move */
1120                call load_size (p1);
1121                call expmac_length_of_varying ((sbfx1), p1);
1122 
1123 /* compare the 2 lengths to decide how much we will move in ( result in q reg ) */
1124 
1125                if check_size then
1126                     macro = size_ck_suffix;
1127                else
1128                     macro = min_fx1;
1129                if q1 -> reference.varying_ref then
1130                     call expmac_length_of_varying (macro, q1);
1131                else
1132                     call expmac (macro, q2);
1133 
1134 /* load present size of varying string into a register other than q */
1135 
1136                call load_size$xr_or_aq (q, tag);
1137 
1138                bump_mac = incr_mac;
1139                macro = chars_move_vt + dt;
1140           end;
1141           else do;                                          /* compare present size with max length of target */
1142 
1143                call load_size (q);
1144 
1145                if check_size then
1146                     macro = size_ck_suffix_1;
1147                else
1148                     macro = cmp_suffix_1;
1149 
1150                call expmac (macro, q2);
1151 
1152                tag = "0110"b;                               /* ql */
1153 
1154                bump_mac = aos_mac;
1155                macro = cat_move_chars + dt;
1156           end;
1157 
1158           if ^q -> reference.shared then
1159                call adjust_ref_count (q, -1);
1160 
1161 /* update length field of varying string */
1162 
1163           call expmac_length_of_varying (bump_mac, p1);
1164 
1165 /* Use old size of varying string as the offset in the string for the target of the move */
1166 
1167           p1 -> address.tag = "00"b || tag;
1168           p1 -> reference.perm_address = TRUE;
1169           q1 -> reference.perm_address = TRUE;
1170           call expmac$two_eis (macro, p1, q1);
1171 
1172           if dt > 0 then
1173                machine_state.indicators = ind_invalid;
1174           goto done;
1175 %page;
1176 /* Have expression, will compile */
1177 
1178 l4:
1179           if ^p2 -> reference.long_ref & ^(p1 -> reference.varying_ref & p1 -> reference.length = null)
1180                & (p1 -> reference.long_ref | hard1) then
1181                p2 = compile_exp$save (exp_pt);
1182           else
1183                call compile_exp (exp_pt);
1184 
1185           if p1 -> reference.varying_ref then do;
1186                if p1 -> reference.length ^= null then
1187                     goto lg;
1188 
1189                if p2 -> reference.length = null then do;
1190                     if ^p2 -> reference.long_ref then
1191                          goto string_store_work;
1192                end;
1193                else
1194                     goto lg;
1195           end;
1196 
1197           if p1 -> reference.long_ref then
1198                goto lg;
1199 
1200 /* string on left is short */
1201 
1202           if hard1 then
1203                goto short_eis;
1204 
1205           if p2 -> reference.long_ref then do;
1206 
1207                if check_size then
1208                     goto short_eis;
1209 
1210                if p2 -> reference.length ^= null | size2 < bits_per_two_words then
1211                     goto short_eis;
1212 
1213                p2 -> reference.value_in.storage = TRUE;
1214 
1215                call load$short_string (p2, d);
1216                size2 = bits_per_word * (d + 1);
1217           end;
1218 
1219 /* we have size2 <= a_reg.size */
1220 
1221 string_store_work:
1222           if p1 -> reference.varying_ref then do;
1223 
1224                if ^p1 -> reference.shared then
1225                     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1226 
1227                call expmac$one ((sta), p1, fixed (min (size1, size2) > bits_per_word, 1));
1228                p2 = generate_constant$real_fix_bin_1 (min (length1, length2));
1229 
1230                if p1 -> address.tag = "000110"b then do;    /* ql */
1231                     call expmac ((lda), p2);
1232                     m2 = sta;
1233                end;
1234                else do;
1235                     call load (p2, 0);
1236                     m2 = stfx1;
1237                end;
1238 
1239                last_macro = TRUE;
1240                call expmac_length_of_varying (m2, p1);
1241 
1242                goto done;
1243           end;
1244 
1245 string_store_check:
1246           if size1 = a_reg.size then
1247                goto st;
1248 
1249           if size1 < a_reg.size then do;
1250                if no_store then
1251                     call aq_man$trim_aq (size1);
1252                goto st;
1253           end;
1254 
1255 /* have size2 <= a_reg.size < size1 */
1256 
1257           aq_used = a_reg.size + a_reg.offset;
1258 
1259           if type1 = bit_string then
1260                if a_reg.length = bits_per_two_words | a_reg.length - a_reg.offset >= size1 then
1261                     goto st;
1262                else
1263                     goto pad;
1264 
1265 /* we must pad the char string, check to see if new length
1266  * will fit with current offset
1267  */
1268 
1269           if size1 > bits_per_two_words - a_reg.offset then do;
1270 
1271 /* we can't extend far enough without shifting string
1272  * back to left end of aq
1273  */
1274                call aq_man$left_shift (a_reg.offset, "1"b);
1275                aq_used = a_reg.size;
1276           end;
1277 
1278           if size1 <= bits_per_word then
1279                k = size1 + a_reg.offset;
1280           else
1281                k = bits_per_two_words;
1282 
1283           if a_reg.length < k then do;
1284 pad:
1285                call aq_man$trim_aq (aq_used);
1286                a_reg.length = 72;
1287           end;
1288 
1289           if type1 = bit_string then
1290                goto st;
1291 
1292           call expmac ((oraq), c_a (aq_used, 6));
1293 
1294           if mod (k, bits_per_word) ^= 0 then do;
1295                call aq_man$trim_aq (k);
1296                a_reg.length = bits_per_two_words;
1297           end;
1298 
1299           a_reg.size = k - a_reg.offset;
1300 
1301 st:
1302           if (size1 = size2) & all_ones then
1303                call store$all_ones (p1);
1304           else
1305                call store (p1);
1306 
1307           if a_reg.size + a_reg.offset > bits_per_two_words then
1308                a_reg.size = bits_per_two_words - a_reg.offset;
1309 
1310           goto done;
1311 %page;
1312 /* something (not char string) = bit string */
1313 
1314 A (6):
1315           if p2 -> reference.long_ref | p2 -> reference.varying_ref then do;
1316 
1317                if ^atomic then
1318                     call compile_exp (exp_pt);
1319                call load$long_string (p2);
1320 
1321                call expmac$zero ((longbs_to_fx2));
1322 
1323 /* now have real_fix_bin_2 in aq register */
1324 
1325 now_fx2:
1326                type2 = real_fix_bin_2;
1327 
1328                q = addr (assign_info$assign_info (type1, type2));
1329                m1 = fixed (q -> assign_info.macro_1, 12);
1330                m2 = fixed (q -> assign_info.macro_2, 12);
1331                goto B (fixed (q -> assign_info.act_b, 6));
1332           end;
1333 
1334           if all_zeros then
1335                if type1 = real_fix_bin_1 & ^p1 -> reference.temp_ref & p1 -> reference.aligned_for_store_ref then do;
1336 zm:
1337                     call state_man$flush_ref (p1);
1338                     call expmac ((zero_mac), p1);
1339                     goto done;
1340                end;
1341 
1342           if atomic then
1343                call load (p2, 1);
1344           else
1345                call compile_exp (exp_pt);
1346 
1347           dt = a_reg.offset;
1348           if a_reg.number ^= 0 then do;
1349                q = a_reg.variable (1);
1350                if q -> reference.temp_ref & q -> reference.ref_count > 0 then
1351                     call state_man$erase_reg ("1"b);
1352           end;
1353 
1354           if size2 < bits_per_two_words then do;
1355                k = bits_per_two_words - size2;
1356                if k > dt then
1357                     call aq_man$right_shift (k - dt, "1"b);
1358           end;
1359 
1360           if scale1 ^= 0 then
1361                call state_man$erase_reg ("1"b);
1362 
1363           goto now_fx2;
1364 %page;
1365 /* bit_string = arithmetic */
1366 
1367 A (7):
1368           if ^atomic then do;
1369                call compile_exp (exp_pt);
1370 
1371                loaded = TRUE;
1372           end;
1373 
1374           goto B (b);
1375 %page;
1376 /* ordinary arithmetic assignment */
1377 
1378 B (1):
1379           if m1 ^= 0 then
1380                call expmac$zero (m1);
1381 
1382 l0:
1383           if m2 ^= 0 then
1384                call expmac$zero (m2);
1385 
1386 l1:
1387           if check_size & s1 -> symbol.fixed then do;
1388                if type1 > real_fix_bin_1 then
1389                     dt = 1;
1390                else if type2 > real_fix_bin_1 then
1391                     dt = 1;
1392                else
1393                     dt = 0;
1394                call xr_man$load_const (-s1 -> symbol.c_dcl_size * (dt + 1), 7);
1395 
1396                if s1 -> symbol.unsigned then
1397                     size_ck_macro = size_check_uns_fx1 + dt;
1398                else
1399                     size_ck_macro = size_check_fx1 + dt;
1400 
1401                call expmac$zero (size_ck_macro);
1402 
1403 /* RW 89
1404  * The above load_const destroyed the indicators we needed.
1405  */
1406                machine_state.indicators = ind_invalid;
1407 
1408           end;
1409 
1410           call store (p1);
1411 
1412 done:
1413           cg_stat$temp_ref = p1;
1414 
1415           if p1 -> reference.temp_ref then
1416                p1 -> reference.ref_count = min (p1 -> reference.ref_count, orig_count);
1417 
1418           if ^p1 -> reference.shared then
1419                p1 -> reference.evaluated = TRUE;
1420 
1421           return;
1422 %page;
1423 /* have conversion to or from char string */
1424 
1425 B (2):
1426           if p1 -> reference.temp_ref & p1 -> reference.shared & p1 -> reference.length = null then do;
1427                p1, p -> operand (1) = copy_temp (p1);
1428                orig_count = 1;
1429           end;
1430 
1431           load_it =
1432                p1 -> reference.temp_ref & ^cg_stat$save_exp_called & cg_stat$cur_tree ^= p & ^p1 -> reference.long_ref
1433                & ^s1 -> symbol.decimal;
1434 
1435           if op_code = pack | op_code = unpack then
1436                call picture_op (p);
1437           else do;
1438                call convert_chars (p1, p2, check_size, always_round);
1439 
1440                if p2 ^= null then do;                       /* conversion was done into temp which we must still assign */
1441                     atomic = TRUE;
1442                     length2 = p2 -> reference.c_length;
1443                     size2 = bits_per_char * length2;
1444                     type2 = char_string;
1445                     goto A (5);
1446                end;
1447           end;
1448 
1449 B2b:
1450           if type1 = bit_string then
1451                machine_state.indicators = ind_invalid;
1452 
1453           if load_it then do;
1454                p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1455                call load (p1, fixed (type1 >= char_string, 1));
1456           end;
1457           goto done;
1458 %page;
1459 /* have bit string = arithmetic */
1460 
1461 B (3):
1462           size1, length1 = p1 -> reference.c_length;
1463 
1464           if type2 <= real_fix_bin_2 & scale2 ^= 0 then do;
1465                if ^loaded then
1466                     call load (p2, 0);
1467 
1468                call scaler (-scale2, type2);
1469 
1470                prec2 = max (prec2 - scale2, 0);
1471                goto B3b;
1472           end;
1473 
1474           if ^loaded then
1475                if type2 > real_fix_bin_2 | ^p2 -> reference.aligned_ref then
1476                     call load (p2, 0);
1477                else do;
1478                     d = type2 - real_fix_bin_1;
1479                     k = bits_per_word * (d + 1);
1480 
1481                     arg (1) = p2;
1482                     arg (2) = c_a (k - prec2, 1);
1483 
1484                     if s2 -> symbol.unsigned then
1485                          macro = uns_fx1_to_bs;
1486                     else
1487                          macro = fx1_to_bs;
1488 
1489                     call expmac$many (macro + d, addr (arg), 2);
1490 
1491                     a_reg.length = k;
1492                     goto B3a;
1493                end;
1494 
1495 B3b:
1496           if ^s2 -> symbol.unsigned then do;
1497                if machine_state.indicators ^= ind_arithmetic then do;
1498                     call expmac (cpfx1 - real_fix_bin_1 + type2, c_a (0, 5));
1499                     machine_state.indicators = ind_arithmetic;
1500                end;
1501 
1502                if m1 ^= 0 then
1503                     call expmac$zero (m1);
1504                if m2 ^= 0 then
1505                     call expmac$zero (m2);
1506           end;
1507 
1508           call expmac ((lls), c_a (bits_per_two_words - prec2, 1));
1509 
1510           a_reg.length = bits_per_two_words;
1511 
1512 B3a:
1513           a_reg.size, size2, length2 = prec2;
1514           a_reg.offset = 0;
1515 
1516           if p1 -> reference.long_ref & ^(p1 -> reference.varying_ref & p1 -> reference.length = null) then do;
1517                p2 = c_a (46, 4);                            /* store in double_temp */
1518                p2 -> reference.c_length = length2;
1519                p2 -> reference.temp_ref = TRUE;
1520                p2 -> reference.data_type = bit_string;
1521                p2 -> reference.ref_count = 2;
1522                p2 -> reference.value_in.storage = TRUE;
1523                call expmac$one ((sta), p2, fixed (length2 > bits_per_word, 1));
1524                goto lg;
1525           end;
1526           else do;
1527                if check_size then
1528                     call check_stringsize;
1529                goto string_store_work;
1530           end;
1531 
1532 LABEL_ENTRY_OR_PTR:
1533           orig_count = p1 -> reference.ref_count;
1534           if type2 < unpacked_ptr then
1535                goto lab_or_ent;
1536 
1537 /* following check allows for initialization of file constants */
1538 
1539           if type1 = local_label_variable then
1540                type1, p1 -> reference.data_type = unpacked_ptr;
1541 
1542           if type2 = unpacked_ptr then do;
1543 
1544 /* NOTE:  All assignments of unpacked ptrs must be done through the pointer
1545  *        registers in order to validate the pointers' ring numbers
1546  */
1547 
1548                if ^atomic then do;
1549                     if type1 = unpacked_ptr then
1550                          if ^p2 -> reference.allocate then do;
1551                                                             /* slide the LHS in as the target of the operator */
1552                               exp_pt -> operand (1) = p1;
1553                               call compile_exp (exp_pt);    /* and compile */
1554                               goto done;
1555                          end;
1556 
1557 
1558                     call compile_exp (exp_pt);              /* leave the temp in the machine state */
1559                     p2 = exp_pt -> operator.operand (1);    /* and use it */
1560                     goto CONVERT_UNPACKED_PTR_TO_SOMETHING;
1561                end;
1562 
1563                if s2 -> symbol.constant then do;
1564 
1565 /* right side of assignment is a constant, it must be null ptr.
1566  * if left side is packed ptr, use packed representation of null
1567  */
1568                     if type1 = packed_ptr then do;
1569                          p2, p -> operand (2) = generate_constant$real_fix_bin_1 (cg_stat$packed_null_value);
1570                          type2, p2 -> reference.data_type = packed_ptr;
1571                     end;
1572                end;
1573           end;
1574 
1575           if p2 -> reference.temp_ref then
1576                if ^p1 -> reference.temp_ref then
1577                     do i = 1 to 6;
1578                          if p2 -> reference.value_in.b (i) then do;
1579                               if p1 -> reference.aligned_for_store_ref then
1580                                    if ^p2 -> reference.shared then
1581                                         call adjust_ref_count (p2, -1);
1582 
1583                               call base_to_core (i, p1);
1584 
1585 /* have to decrement count after base_to_core rather
1586  * than before for unaligned refs so that temp can
1587  * be used for intermediate saving by base_to_core
1588  */
1589 
1590                               if ^p1 -> reference.aligned_for_store_ref then
1591                                    if ^p2 -> reference.shared then
1592                                         call adjust_ref_count (p2, -1);
1593                               goto done;
1594                          end;
1595                     end;
1596 
1597 CONVERT_UNPACKED_PTR_TO_SOMETHING:
1598           if type1 < type2 | (type2 = packed_ptr & p1 -> reference.temp_ref) then do;
1599                call base_man$load_packed (p, i);
1600                if ^p1 -> reference.temp_ref | p1 -> reference.aggregate | cg_stat$save_exp_called then
1601                     call base_to_core (i, p1);
1602                goto done;
1603           end;
1604           else if type2 = unpacked_ptr then
1605                if p1 -> reference.temp_ref | ^s2 -> symbol.constant then
1606                     if p1 -> reference.aligned_for_store_ref | p1 -> reference.hard_to_load then do;
1607                          if ^p2 -> reference.shared & p2 -> reference.temp_ref then
1608                               call adjust_ref_count (p2, +1);
1609                                                             /* base man will hit ref count even though the reference is evaluated already, potentially */
1610                          base = base_man$load_any_var (1, p2);
1611                          i = which_base (fixed (base, 3));
1612                          if ^p1 -> reference.temp_ref | p1 -> reference.aggregate | cg_stat$save_exp_called then
1613                               call base_to_core (i, p1);
1614                          else
1615                               call base_man$update_base (1, p1, i);
1616                          goto done;
1617                     end;
1618 
1619           call load (p2, 0);
1620 
1621           m2 = ptr_convert (type2, type1);
1622           goto l0;
1623 %page;
1624 /* have conversion to or from decimal or complex */
1625 
1626 B (4):
1627           if s1 -> symbol.complex ^= s2 -> symbol.complex then
1628                goto B4b;
1629           if type1 ^= type2 then
1630                goto B4a;
1631           if scale1 ^= scale2 then
1632                goto B4a;
1633           if p1 -> reference.c_length ^= p2 -> reference.c_length then
1634                goto B4a;
1635 
1636           if p1 -> reference.aligned_for_store_ref & p2 -> reference.aligned_ref
1637                & s1 -> symbol.unaligned = s2 -> symbol.unaligned then do;
1638                if s2 -> symbol.decimal then
1639                     if s2 -> symbol.unaligned then do;
1640                          units_per_wrd = packed_digits_per_word;
1641                          if s2 -> symbol.complex then
1642                               c_length =
1643                                    p2 -> reference.c_length + 2 * mod (divide (p2 -> reference.c_length, 2, 24, 0), 2);
1644                          else
1645                               c_length = p2 -> reference.c_length;
1646                     end;
1647                     else do;
1648                          units_per_wrd = chars_per_word;
1649                          c_length = p2 -> reference.c_length;
1650                     end;
1651                else do;
1652                     units_per_wrd = bits_per_word;
1653                     c_length = p2 -> reference.c_length;
1654                end;
1655 
1656                call move_data$move_block (p1, p2, divide (c_length + units_per_wrd - 1, units_per_wrd, 17, 0));
1657                goto done;
1658           end;
1659 
1660 B4a:
1661           if s1 -> symbol.decimal then
1662                if s2 -> symbol.decimal then do;
1663                     macro = move_decimal;
1664 
1665                     if max (scale1, scale2) <= max_dec_scale & min (scale1, scale2) >= min_dec_scale then
1666                          call assign_decimal;
1667 
1668                     else if type1 = type2 then do;
1669                          if abs (scale1 - scale2) <= max_dec_scale - min_dec_scale then do;
1670                               if scale1 > scale2 then
1671                                    i = min_dec_scale;
1672                               else
1673                                    i = max_dec_scale;
1674                               s1 -> symbol.scale = i + (scale1 - scale2);
1675                               s2 -> symbol.scale = i;
1676                          end;
1677                          else do;
1678                               macro = multiply_decimal;
1679                               exponent.pad = "0"b;
1680                               exponent.value = scale1 - scale2;
1681                               s1 -> symbol.scale = 0;
1682                               s2 -> symbol.scale = 0;
1683                          end;
1684 
1685                          call assign_decimal;
1686 
1687                          s1 -> symbol.scale = scale1;
1688                          s2 -> symbol.scale = scale2;
1689                     end;
1690                     else do;
1691                          macro = multiply_decimal;
1692                          exponent.pad = "0"b;
1693 
1694                          if scale1 > max_dec_scale | scale1 < min_dec_scale then
1695                               exponent.value = scale1;
1696                          else
1697                               exponent.value = -scale2;
1698 
1699                          call assign_decimal;
1700                     end;
1701 
1702                     goto done;
1703                end;
1704 
1705 B4b:
1706           if p1 -> reference.temp_ref & p1 -> reference.shared then do;
1707                p1, p -> operand (1) = copy_temp (p1);
1708                orig_count = 1;
1709           end;
1710 
1711           load_it =
1712                p1 -> reference.temp_ref & ^cg_stat$save_exp_called & cg_stat$cur_tree ^= p
1713                & ^(s1 -> symbol.decimal | s1 -> symbol.complex);
1714 
1715           call convert_arithmetic (p1, p2, check_size, always_round);
1716 
1717           goto B2b;
1718 %page;
1719 /* have fixed binary = fixed binary */
1720 
1721 B (5):
1722           if m1 ^= 0 then
1723                call expmac$zero (m1);
1724 
1725           ds = scale1 - scale2;
1726 
1727           if ds ^= 0 then do;
1728                k = max (type1, type2);
1729                call scaler (ds, k);
1730           end;
1731 
1732           goto l1;
1733 %page;
1734 /* have float binary = fixed binary */
1735 
1736 B (6):
1737           if scale2 = 0 then
1738                goto B (1);
1739 
1740           call fixed_to_float (p2);
1741           if type1 = complex_flt_bin_1 then
1742                call expmac$zero (rflb1_to_cflb1);
1743           goto l1;
1744 %page;
1745 /* have fixed binary = float binary */
1746 
1747 B (7):
1748           if scale1 = 0 then
1749                goto B (1);
1750 
1751           call float_to_fixed (p1);
1752           goto l1;
1753 %page;
1754 lab_or_ent:
1755           if p1 -> reference.temp_ref & ^cg_stat$save_exp_called then
1756                p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1757 
1758           if type1 = real_fix_bin_1 then do;
1759                arg (1) = p1;
1760                arg (2) = p2;
1761                call expmac$many ((assign_label_to_int), addr (arg), 2);
1762                goto done;
1763           end;
1764 
1765           if type1 = unpacked_ptr then do;
1766                call base_man$store_ptr_to (p2, p1);
1767                goto done;
1768           end;
1769 
1770           if type2 = ext_entry_in | type2 = ext_entry_out then do;
1771                call base_man$load_var (2, p2, 1);
1772 
1773                if ^p1 -> reference.shared then
1774                     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1775 
1776                p1 -> reference.data_type = unpacked_ptr;
1777                call base_to_core (1, p1);
1778 
1779                p2 = generate_constant$bit_string (cg_stat$null_value, (bits_per_two_words));
1780                p2 -> reference.data_type = unpacked_ptr;
1781                call load (p2, 0);
1782                call m_a (p1, "1"b);                         /* can't have indirection in address */
1783                p1 -> reference.perm_address = TRUE;
1784 
1785                p1 -> address.offset = bit (fixed (fixed (p1 -> address.offset, 15) + 2, 15), 15);
1786                call store$force (p1);
1787                p1 -> reference.perm_address = FALSE;
1788                p1 -> reference.data_type = type1;
1789                goto done;
1790           end;
1791 
1792           b2 = s2 -> symbol.block_node;
1793 
1794           if type2 ^= label_constant then
1795                if type2 ^= int_entry then
1796                     goto le_1;
1797 
1798           if b2 -> block.level ^= cg_stat$cur_level then
1799                goto le_2;
1800 
1801           call m_a (p1, "1"b);
1802           p1 -> reference.perm_address = TRUE;
1803           k = 1 + fixed (p1 -> address.base = bp, 1);
1804           call base_man$load_var (2, p2, k);
1805           call expmac ((set_label_const (k)), p1);
1806           goto done;
1807 
1808 le_1:
1809           if type2 > entry_variable then do;
1810 le_2:
1811                arg (1) = p2;
1812                arg (2) = c_a (cg_stat$cur_level - b2 -> block.level, 2);
1813                call expmac$many ((make_lv), addr (arg), 2);
1814 
1815                call m_a (p1, "0"b);
1816                p1 -> reference.perm_address = TRUE;
1817                call expmac ((store_lv), p1);
1818           end;
1819 
1820           else do;
1821                if ^p1 -> reference.shared then
1822                     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1823                if ^p2 -> reference.shared then
1824                     p2 -> reference.ref_count = p2 -> reference.ref_count + 1;
1825                call base_man$update_base (0, null, 1);
1826                call make_both_addressable (p1, p2, "1"b);
1827 
1828                do i = 1 to 2;
1829                     p1 -> reference.perm_address = TRUE;
1830                     p2 -> reference.perm_address = TRUE;
1831                     call base_man$load_var (1, p2, 1);
1832                     call base_to_core (1, p1);
1833                     call state_man$flush_ref (p2);
1834                     if i = 1 then do;
1835                          p1 -> address.offset = bit (fixed (fixed (p1 -> address.offset, 15) + 2, 15), 15);
1836                          substr (p2 -> address.tag, 1, 2) = "00"b;
1837                          p2 -> address.offset = bit (fixed (fixed (p2 -> address.offset, 15) + 2, 15), 15);
1838                     end;
1839                end;
1840 
1841                p1 -> reference.perm_address = FALSE;
1842                p2 -> reference.perm_address = FALSE;
1843           end;
1844 
1845           goto done;
1846 %page;
1847 /*
1848  *
1849  */
1850 assign_op$length_of_varying:
1851      entry (pt, source);
1852 
1853           dcl      source ptr parameter;
1854 
1855           last_macro = FALSE;
1856           call load (source, 0);
1857           call expmac_length_of_varying ((stfx1), pt);
1858           return;
1859 %page;
1860 /*
1861  * entry to convert fixed decimal scaled input whose scale is out
1862  * of range to float decimal output
1863  */
1864 assign_op$fix_dec_scaled:
1865      entry (pt);
1866 
1867           always_round, check_size = FALSE;
1868           p2 = pt;
1869           s2 = p2 -> reference.symbol;
1870           p1 = decimal_op$get_float_temp (s2 -> symbol.c_dcl_size, (s2 -> symbol.complex));
1871           s1 = p1 -> reference.symbol;
1872           macro = multiply_decimal;
1873           exponent.pad = "0"b;
1874           exponent.value = -s2 -> symbol.scale;
1875           call assign_decimal;
1876           pt = p1;
1877           return;
1878 %page;
1879 /*
1880  * entry to convert float decimal input to fixed decimal scaled output
1881  * whose scale is out of hardware range
1882  */
1883 assign_op$to_dec_scaled:
1884      entry (pt, source);
1885 
1886           always_round, check_size = FALSE;
1887           p2 = source;
1888           p1 = pt;
1889           s1 = p1 -> reference.symbol;
1890           s2 = p2 -> reference.symbol;
1891           macro = multiply_decimal;
1892           exponent.pad = "0"b;
1893           exponent.value = s1 -> symbol.scale;
1894           call assign_decimal;
1895           if ^p1 -> reference.shared then
1896                p1 -> reference.evaluated = TRUE;
1897           return;
1898 %page;
1899 /*
1900  * procedure to generate assignment macro for strings
1901  */
1902 eis_move:
1903      proc;
1904 
1905           if p1 -> reference.temp_ref then
1906                p1 -> reference.value_in.storage = TRUE;
1907 
1908           if ^(check_size & p1 -> reference.length ^= null) then do;
1909                if all_same then do;
1910                     call expmac$one_eis ((blank_cs), p1);
1911                     if length2 > 0 then
1912                          addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> instruction.fill =
1913                               substr (s2 -> symbol.initial -> based_cs, 1, 1);
1914                     return;
1915                end;
1916 
1917                if all_ones then do;
1918                     if p1 -> reference.aligned_for_store_ref then
1919                          if mod (size1, bits_per_char) = 0 then do;
1920                               m1 = one_cs;
1921                               call long_op$one_eis (p1, divide (size1 + bits_per_char - 1, bits_per_char, 17, 0), m1);
1922                               return;
1923                          end;
1924 
1925                     m1 = one_bs;
1926                     call expmac$one_eis (m1, p1);
1927                     return;
1928                end;
1929 
1930                if all_zeros then do;
1931                     if p1 -> reference.aligned_for_store_ref then
1932                          if p1 -> reference.length = null then do;
1933                               if p1 -> reference.padded_for_store_ref | mod (size1, bits_per_char) = 0 then do;
1934                                    m1 = zero_cs;
1935                                    call long_op$one_eis (p1, divide (size1 + bits_per_char - 1, bits_per_char, 17, 0), m1)
1936                                         ;
1937                                    return;
1938                               end;
1939                          end;
1940                          else if p1 -> reference.padded_for_store_ref then do;
1941                               call load_size (p1);
1942                               if p1 -> reference.ref_count = 1 then
1943                                    call need_temp (p1, "01"b);
1944                               call expmac$zero ((b2c_mac));
1945                               call expmac$one_eis ((zero_cs_q), p1);
1946                               return;
1947                          end;
1948 
1949                     m1 = zero_bs;
1950                     call expmac$one_eis (m1, p1);
1951                     return;
1952                end;
1953           end;
1954 
1955           if check_size then
1956                macro = chars_move_ck;
1957           else
1958                macro = chars_move;
1959 
1960           call expmac$two_eis (macro + dt, p1, p2);
1961      end eis_move;
1962 %page;
1963 /*
1964  * this procedure gets the length expression of a string and increments
1965  * reference count preparatory to its use in a macro
1966  */
1967 get_length:
1968      proc (pt) returns (ptr);
1969 
1970           dcl      pt ptr parameter;
1971           dcl      (q, q1) ptr;
1972 
1973           q = pt -> reference.length;
1974 
1975           if q ^= null then do;
1976                if q -> node.type = operator_node then do;
1977                     q1 = q -> operand (1);
1978                     if q1 -> reference.shared then
1979                          q -> operand (1) = copy_temp (q1);
1980                     q = q -> operand (1);
1981                end;
1982 
1983                if ^q -> reference.shared then
1984                     q -> reference.ref_count = q -> reference.ref_count + 1;
1985           end;
1986 
1987           return (q);
1988      end get_length;
1989 %page;
1990 /*
1991  * this procedure  gets the length of a reference such that it can be
1992  * used in storage by a fullword instruction. This routine may emit code.
1993  * This routine was written to fix 1754.
1994  */
1995 get_length_in_storage:
1996      proc (pt) returns (ptr);
1997 
1998           dcl      pt ptr parameter;
1999           dcl      p ptr;
2000 
2001           p = get_length ((pt));
2002 
2003           if p ^= null then
2004                if ^p -> reference.aligned_ref then
2005                     p = compile_exp$save (p);
2006 
2007           return (p);
2008 
2009      end get_length_in_storage;
2010 %page;
2011 /*
2012  * this procedure gets the length needed by the section that handles
2013  *        vs = vs || expr;
2014  * this MAY emit code.
2015  */
2016 get_suffix_length:
2017      proc (pt) returns (ptr);
2018 
2019           dcl      pt ptr parameter;
2020           dcl      (p, q) ptr;
2021 
2022           p = pt;
2023 
2024           q = get_length_in_storage (p);
2025 
2026           if q = null then do;
2027                if p -> reference.c_length ^= 0 | ^p -> reference.varying_ref then
2028                     q = generate_constant$real_fix_bin_1 ((p -> reference.c_length));
2029           end;
2030           else if q -> reference.data_type = real_fix_bin_2 then
2031                q = get_single_ref (q);
2032 
2033           return (q);
2034 
2035      end get_suffix_length;
2036 %page;
2037 /*
2038  *  this procedure executes a macro on the length word of a varying string
2039  */
2040 expmac_length_of_varying:
2041      proc (macro, pt);
2042 
2043           dcl      macro fixed bin (15) parameter;
2044           dcl      pt ptr parameter;
2045 
2046           dcl      p ptr;
2047           dcl      addr_hold bit (36) aligned;
2048           dcl      reloc_hold bit (12) aligned;
2049 
2050           p = pt;
2051 
2052           if string (p -> reference.address_in.b) ^= "0"b & ^p -> reference.temp_ref then do;
2053                                                             /* same restriction on temp_ref as in m_a */
2054                if p -> address.offset ^= (15)"0"b | p -> reference.no_address then
2055                     call m_a (p, "00"b);
2056                p -> address.offset = (15)"1"b;
2057           end;
2058           else do;
2059                addr_hold = string (p -> reference.address);
2060                reloc_hold = p -> reference.relocation;
2061                p -> reference.c_offset = p -> reference.c_offset - 1;
2062                call m_a (p, "00"b);
2063                p -> reference.c_offset = p -> reference.c_offset + 1;
2064           end;
2065 
2066           p -> reference.perm_address = TRUE;
2067 
2068           if ^last_macro then
2069                if ^p -> reference.shared then
2070                     p -> reference.ref_count = p -> reference.ref_count + 1;
2071 
2072           call expmac (macro, p);
2073 
2074           p -> reference.perm_address = FALSE;
2075 
2076           if string (p -> reference.address_in.b) ^= "0"b & ^p -> reference.temp_ref then
2077                p -> address.offset = (15)"0"b;
2078           else do;
2079                string (p -> reference.address) = addr_hold;
2080                p -> reference.relocation = reloc_hold;
2081           end;
2082 
2083      end expmac_length_of_varying;
2084 %page;
2085 /*
2086  *
2087  */
2088 scaler:
2089      proc (amt, type);
2090 
2091           dcl      (amt, type) fixed bin parameter;
2092 
2093           if amt < 0 then do;
2094                call xr_man$load_const (abs (amt), 2);
2095                call expmac$zero ((truncate (type)));
2096           end;
2097           else
2098                call expmac ((left_shift (type)), c_a (amt, 1));
2099 
2100      end scaler;
2101 %page;
2102 /*
2103  * this procedure compares two references ignoring the two length fields
2104  */
2105 compare_refs:
2106      proc (p1, p2) reducible returns (bit (1) aligned);
2107 
2108           dcl      (p1, p2) ptr parameter;
2109 
2110           if p1 -> reference.symbol ^= p2 -> reference.symbol then
2111                return (FALSE);
2112           else if p1 -> reference.c_offset ^= p2 -> reference.c_offset then
2113                return (FALSE);
2114           else if ^compare_expression ((p1 -> reference.offset), (p2 -> reference.offset)) then
2115                return (FALSE);
2116           else if ^compare_expression ((p1 -> reference.qualifier), (p2 -> reference.qualifier)) then
2117                return (FALSE);
2118           else
2119                return (TRUE);
2120 
2121      end compare_refs;
2122 %page;
2123 /*
2124  *
2125  */
2126 adjust_suff_temp:
2127      proc (pt);
2128 
2129           dcl      pt ptr parameter;
2130           dcl      p ptr;
2131 
2132           p = pt;
2133           top = p -> reference.length;
2134           call adjust_suff_op (top);
2135           call adjust_ref_count (p, -1);
2136 
2137      end adjust_suff_temp;
2138 %page;
2139 /*
2140  *
2141  */
2142 adjust_suff_op:
2143      proc (pt);
2144 
2145           dcl      pt ptr parameter;
2146           dcl      (p, q) ptr;
2147           dcl      i fixed bin;
2148 
2149           p = pt;
2150 
2151           if p -> node.type = operator_node then do;
2152                q = p -> operand (1);
2153                if ^q -> reference.evaluated then
2154                     if q -> reference.ref_count <= 1 then
2155                          do i = 2 to p -> operator.number;
2156                               if p -> operand (i) ^= null then
2157                                    call adjust_suff_op ((p -> operand (i)));
2158                          end;
2159           end;
2160           else
2161                q = p;
2162 
2163           if p ^= top then
2164                if q -> node.type = reference_node then
2165                     if ^q -> reference.shared then
2166                          call adjust_ref_count (q, -1);
2167 
2168           return;
2169 
2170      end adjust_suff_op;
2171 %page;
2172 /*
2173  * this issues macro(s) to effect the assignment of a decimal variable
2174  */
2175 assign_decimal:
2176      proc;
2177 
2178           dcl      (mac, ninst) fixed bin (15);
2179           dcl      arg (2, 3) ptr;
2180 
2181           mac = macro + fixed (s1 -> symbol.float | always_round, 1);
2182 
2183           if macro = multiply_decimal then do;
2184                arg (1, 3), arg (2, 3) = generate_constant$char_string ("+1" || exponent_char, 3);
2185                k = 3;
2186           end;
2187           else
2188                k = 2;
2189 
2190           ninst = fixed (s1 -> symbol.complex, 1) + 1;
2191 
2192           arg (1, 1) = p1;
2193           arg (1, 2) = p2;
2194 
2195           if ninst > 1 then do;
2196                arg (2, 1) = get_imaginary (p1);
2197                arg (2, 2) = get_imaginary (p2);
2198           end;
2199 
2200           do i = 1 to ninst;
2201                call expmac$many_eis (mac, addr (arg (i, 1)), k);
2202 
2203                if check_size then
2204                     if s1 -> symbol.fixed then
2205                          call expmac$zero ((size_ck_decimal));
2206           end;
2207 
2208      end assign_decimal;
2209 %page;
2210 /*
2211  * this issues warning about stringsize occuring at runtime
2212  * and generates unconditional signal of stringsize
2213  */
2214 check_stringsize:
2215      proc;
2216 
2217           if length1 < length2 then do;
2218                if ^cg_stat$cur_statement -> statement.suppress_warnings then
2219                     call error (319, cg_stat$cur_statement, null);
2220                call expmac$zero ((signal_stringsize));
2221           end;
2222 
2223      end check_stringsize;
2224      end assign_op;