1 /* ******************************************************
   2    *                                                    *
   3    *                                                    *
   4    * Copyright (c) 1972 by Massachusetts Institute of   *
   5    * Technology and Honeywell Information Systems, Inc. *
   6    *                                                    *
   7    *                                                    *
   8    ****************************************************** */
   9 
  10 /* format: style3 */
  11 
  12 /* program to compile expressions
  13 
  14    Initial Version:  9 April 1971 by BLW for Version II
  15           Modified: 25 January 1973 by BLW
  16           Modified: 16 February 1973 by RAB
  17           Modified: 27 June 1973 by RAB for EIS
  18           Modified: 10 Sept 1975 by RAB to fix 1417
  19           Modified: 25 Sept 1975 by RAB to fix 1423
  20           Modified: 5 Oct 1975 for repeat_fun optimization
  21           Modified: 1 Feb 1976 by RAB for reverse_fun optimization
  22           Modified: 1 Feb 1976 by RAB to fix 1458
  23           Modified: 10 Feb 1976 by RAB to fix 1464
  24           Modified: 15 June 1976 by RAB to fix 1501
  25           Modified: 23 June 1976 by RAB to centralize use of cg_stat$last_call
  26           Modified: 7 Dec 1976 by RAB to fix 1559
  27           Modified: 23 Dec 1976 by RAB for after,before,ltrim,rtrim
  28           Modified: 30 Dec 1976 by RAB for 9-bit translate, search, verify
  29           Modified 770619 by PG for clock, vclock, and stacq
  30           Modified: 12 July 1977 by RAB to change stacq definition
  31           Modified: 7 August 1978 by RAB to partially fix 1731
  32           Modified 780828 by PG to fix 1744 and remove pos_diff_fun
  33           Modified: 16 July 1979 by RAB to fix 1852 (abs(unal_auto) fails)
  34                     and to remove use of absfx1_atm for faster code.
  35           Modified: 25 July 1979 by PCK to implement rank and byte builtins
  36           Modified: 29 August 1979 by PCK to fix bug 1853
  37           Modified 791023 by PG to recognize substr(string_const,const,1) in several contexts by inventing
  38                     is_string_constant.
  39           Modified 791023 by PG to fix 1857 in which rank and byte didn't accept expressions.
  40           Modified 791026 by PG to use TCT tables in pl1_operators_ when possible.
  41           Modified December 1979 by BSG for reverse index, verify, search, 2 char reverse, and reverse bugs.
  42           Modified 800218 by PG to have math builtins update machine_state.indicators.
  43           Modified: 29 Feb 1980 to fix 1921
  44           Modified: 30 March 1980 by RAB for reference.(aligned padded)_for_store_ref.
  45                     See prepare_operand for details.
  46           Modified: 15 August 1980 by M. N. Davidoff to fix 2005.
  47           Modified: 16 September 1980 by M. N. Davidoff to fix 1985.
  48 */
  49 /* format: style3 */
  50 compile_exp:
  51      proc (pt);
  52 
  53 /* parameters */
  54 
  55 dcl       pt                  ptr;                          /* points at operator node */
  56 
  57 /* external static */
  58 
  59 dcl       (
  60           cg_stat$cur_node,
  61           cg_stat$temp_ref,
  62           cg_stat$eis_temp,
  63           cg_stat$complex_ac,
  64           cg_stat$text_base
  65           )                   ptr ext,
  66           (
  67           cg_stat$text_pos,
  68           cg_stat$offset_null_value
  69           )                   fixed bin ext,
  70           (
  71           cg_stat$save_exp_called,
  72           cg_stat$for_test_called,
  73           cg_stat$extended_stack
  74           )                   bit (1) ext;
  75 
  76 dcl       (
  77           opcode_info$opcode_info
  78                               (0:118),
  79           opcode_info$last_opcode,
  80           opcode_info$table   (0:18)
  81           )                   fixed bin ext;
  82 
  83 /* automatic */
  84 
  85 dcl       (
  86           p,
  87           q,
  88           pa,
  89           ref1,
  90           save_cur_node,
  91           ref                 (5),
  92           sym                 (5),
  93           rand                (5)
  94           )                   ptr,
  95           (
  96           sec,
  97           ftc,
  98           in_storage,                                       /* Conjecture: means result is in ref1 */
  99           inline,
 100           load_it,
 101           atom                (5),
 102           update_long,
 103           constant_rands,
 104           save_it,
 105           scaled,
 106           update_ref,
 107           atomic,
 108           is_string,
 109           check_type,
 110           check_aligned
 111           )                   bit (1) aligned,
 112           c_offset            fixed bin (24),
 113           drop                bit (1) aligned init ("0"b),
 114           op_code             bit (9),
 115           b3                  bit (3) aligned;
 116 dcl       double              bit (72) aligned;
 117 dcl       (mvt_table, result_string)
 118                               char (512) aligned,
 119           op_class            bit (5) defined (op_code) pos (1),
 120           op_relative         bit (4) defined (op_code) pos (6),
 121           (
 122           i,
 123           j,
 124           k,
 125           n,
 126           action,
 127           op_rel,
 128           delta,
 129           call_code,
 130           code,
 131           type                (5),
 132           bump,
 133           orig_count,
 134           rlength,
 135           scale,
 136           array               (2)
 137           )                   fixed bin,
 138           (save_l1, save_l2)  fixed bin (24),
 139           save_mwif           bit (1),
 140           save_coff           fixed bin (24),
 141           save_units          fixed bin (3),
 142           (macro, m)          fixed bin (15);
 143 
 144 /* entries */
 145 
 146 dcl       (
 147           load,
 148           load$for_test,
 149           load$for_save
 150           )                   entry (ptr, fixed bin),
 151           load$long_string    entry (ptr),
 152           (assign_op, load_size)
 153                               entry (ptr),
 154           aq_man$fix_scale    entry (ptr, fixed bin, fixed bin),
 155           aq_man$check_strings
 156                               entry (fixed bin (8)),
 157           aq_man$left_shift   entry (fixed bin (8), bit (1) aligned),
 158           aq_man$right_shift  entry (fixed bin (8), bit (1) aligned),
 159           min_max             entry (ptr),
 160           compile_exp         entry (ptr),
 161           gen_arithmetic_builtin
 162                               entry (ptr, (5) ptr, (5) bit (1) aligned, fixed bin),
 163           gen_arithmetic_call entry (ptr, (5) ptr, (5) aligned bit (1)),
 164           xr_man$load_const   entry (fixed bin, fixed bin),
 165           (
 166           compile_exp$save,
 167           compile_exp$save_exp
 168           )                   entry (ptr) returns (ptr),
 169           c_a                 entry (fixed bin (18), fixed bin) returns (ptr),
 170           base_man$load_var   entry (fixed bin, ptr, fixed bin),
 171           (
 172           base_man$load_a_var,
 173           base_man$load_q_var,
 174           base_man$load_aq_var
 175           )                   entry (ptr),
 176           base_to_core        entry (fixed bin, ptr),
 177           expmac              entry (fixed bin (15), ptr),
 178           expmac$many_eis     entry (fixed bin (15), ptr, fixed bin),
 179           expmac$conditional  entry (fixed bin (15), ptr, (5) ptr, (5) bit (1) aligned),
 180           (
 181           expmac$eis,
 182           expmac$one_eis
 183           )                   entry (fixed bin (15), ptr),
 184           expmac$two_eis      entry (fixed bin (15), ptr, ptr),
 185           expmac$abs          entry (ptr, fixed bin),
 186           long_op$eis_operator
 187                               entry (ptr, ptr, fixed bin (15)),
 188           cg_error            entry (fixed bin, fixed bin),
 189           prepare_operand     entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
 190           eval_exp            entry (ptr, bit (1) aligned) returns (ptr),
 191           (arith_op, decimal_op, exp_op)
 192                               entry (ptr, (5) ptr, (5) bit (1) aligned),
 193           (string_op, cat_op) entry (ptr, (5) ptr, fixed bin),
 194           pointer_builtins    entry (ptr, bit (1) aligned),
 195           get_reference       entry returns (ptr),
 196           inline_operation    entry (ptr, (5) ptr, (5) bit (1) aligned) returns (bit (1) aligned),
 197           set_indicators      entry (ptr, ptr, ptr, fixed bin) returns (fixed bin),
 198           expmac$zero         entry (fixed bin (15)),
 199           (
 200           store$save_string_temp,
 201           store$force,
 202           state_man$update_ref
 203           )                   entry (ptr),
 204           state_man$set_aliasables
 205                               entry (ptr),
 206           stack_temp$assign_block
 207                               entry (ptr, fixed bin),
 208           state_man$erase_temps
 209                               entry,
 210           (
 211           long_op,
 212           long_op$c_or_b
 213           )                   entry (ptr, fixed bin, fixed bin (15));
 214 dcl       generate_constant$bit_string
 215                               entry (bit (*) aligned, fixed bin) returns (ptr);
 216 dcl       generate_constant$real_fix_bin_1
 217                               entry (fixed bin) returns (ptr),
 218           generate_constant$char_string
 219                               entry (char (*) aligned, fixed bin (24)) returns (ptr),
 220           state_man$erase_reg entry (bit (19) aligned),
 221           state_man$flush     entry,
 222           string_temp         entry (ptr, ptr, ptr) returns (ptr),
 223           aq_man$lock         entry (ptr, fixed bin),
 224           adjust_ref_count    entry (ptr, fixed bin),
 225           copy_temp           entry (ptr) returns (ptr),
 226           share_expression    entry (ptr) returns (ptr);
 227 
 228 /* builtins */
 229 
 230 dcl       (addr, addrel, collate9, copy, fixed, hbound, index, length, min, mod, null, rank, string, substr)
 231                               builtin;
 232 
 233 /* based */
 234 
 235 dcl       1 bit_table_structure
 236                               based (addr (mvt_table)) aligned,
 237             2 bit_table       (0:511) bit (9) unaligned;
 238 
 239 dcl       fixed_bin_single    fixed bin based,
 240           fixed_bin_double    fixed bin (71) based,
 241           word                bit (36) aligned based;
 242 
 243 dcl       based_cs            char (1) aligned based;
 244 dcl       based_bs            bit (1) aligned based;
 245 
 246 dcl       1 mlr_instruction   based aligned,
 247             2 fill            char (1) unal,                /* fill character -- can be set by compile_exp */
 248             2 enablefault     bit (1) unal,
 249             2 pad1            bit (1) unal,
 250             2 mf2             bit (7) unal,
 251             2 opcode          bit (10) unal,
 252             2 inhibit         bit (1) unal,
 253             2 mf1             bit (7) unal;
 254 
 255 dcl       1 csl_instruction   based aligned,
 256             2 fill            bit (1) unal,
 257             2 pad1            bit (4) unal,
 258             2 bool            bit (4) unal,
 259             2 enablefault     bit (1) unal,
 260             2 pad2            bit (1) unal,
 261             2 mf2             bit (7) unal,
 262             2 opcode          bit (10) unal,
 263             2 inhibit         bit (1) unal,
 264             2 mf1             bit (7) unal;
 265 
 266 dcl       bit4                bit (4) based aligned;
 267 
 268 dcl       1 op_info           aligned based,
 269             2 act1            unal bit (6),
 270             2 act2            unal bit (6),
 271             2 macro           unal bit (18),
 272             2 delta           unal bit (2),
 273             2 call_code       unal bit (4);
 274 
 275 /* internal static */
 276 
 277 
 278 dcl       (
 279           zero_bs             init (468),
 280           one_bs              init (469),
 281           blank_cs            init (472),
 282           inline_verify       init (207),
 283           inline_search       init (199),
 284           inline_translate    init (111),
 285           test_translate      init (157),
 286           test_translate_rev  init (158),
 287           verify_ltrim_inline init (712),
 288           verify_rtrim_inline init (713),
 289           absfx1              init (126),
 290           testfx1             init (508),
 291           ldfx1               init (7),
 292           ldfx2               init (8),
 293           als                 init (134),
 294           arl                 init (245),
 295           qrs                 init (514),
 296           anq                 init (688),
 297           ana                 init (40),
 298           llr                 init (372),
 299           scaled_mdfx1        init (549),
 300           mdfl1               init (269),
 301           mdfl2               init (270),
 302           stfl2               init (18),
 303           stfx1               init (15),
 304           offset_mac_easy     init (242),
 305           offset_mac_hard     init (600),
 306           chars_move          init (420),
 307           move_bits           init (99),
 308           test_bits           init (96),
 309           fetch_chars_eis     init (588),
 310           index_chars         (4) init (452, 700, 702, 256),
 311           index_chars_1       (4) init (460, 704, 706, 256),
 312           index_mac           (3, 2) init (460, 462, 704, 708, 706, 709),
 313           index_rev_mac       (2) init (463, 464),
 314           round_fl            init (531),
 315           atan2_mac           init (504),
 316           atan2d_mac          init (557),
 317           a_to_x0             init (306),
 318           rank_eis_mac        init (740),
 319           qrl                 init (418),
 320           trunc_mac           (0:1) init (124, 384)
 321           )                   fixed bin (15) int static options (constant);
 322 
 323 dcl       rel_table           (4:9 /* op */, 0:1 /* string? */, 0:1 /* reversed? */) fixed bin (15) int static
 324                               init (159, 161, 160, 162,     /* < */
 325                               161, 159, 162, 160,           /* > */
 326                               163, 163, 163, 163,           /* = */
 327                               164, 164, 164, 164,           /* ^= */
 328                               165, 167, 166, 168,           /* <= */
 329                               167, 165, 168, 166);          /* >= */
 330 
 331 dcl       exp_table           (4, 4) fixed bin (15) int static init (592, 0, 559, 560,
 332                                                             /* fb1 */
 333                               0, 0, 0, 0,                   /* fb2 */
 334                               591, 0, 565, 562,             /* flb1 */
 335                               564, 0, 561, 562);            /* flb2 */
 336 
 337 
 338 /* include files */
 339 
 340 %include cgsystem;
 341 %include reference;
 342 %include symbol;
 343 %include operator;
 344 %include machine_state;
 345 %include nodes;
 346 %include data_types;
 347 %include boundary;
 348 %include op_codes;
 349 %include mask;
 350 %include bases;
 351 ^L
 352 /* program */
 353 
 354           ftc = cg_stat$for_test_called;
 355           cg_stat$for_test_called = "0"b;
 356 
 357 start:
 358           sec = cg_stat$save_exp_called;
 359           cg_stat$save_exp_called = "0"b;
 360 
 361           p = pt;
 362 
 363           if p -> node.type ^= operator_node
 364           then do;
 365 is_atom:
 366                     i = p -> reference.data_type;
 367                     call load (p, fixed (i = char_string | i = bit_string, 1));
 368                     save_cur_node = cg_stat$cur_node;
 369                     goto return_1;
 370                end;
 371 
 372           ref (1) = p -> operand (1);
 373           if ^ref (1) -> reference.shared
 374           then do;
 375 
 376                     if ref (1) -> reference.evaluated
 377                     then do;
 378                               p = ref (1);
 379                               goto is_atom;
 380                          end;
 381 
 382                     if ref (1) -> reference.temp_ref & ^ref (1) -> reference.long_ref & ^ref (1) -> reference.aggregate
 383                          & ref (1) -> reference.data_type ^= complex_flt_bin_1
 384                     then drop = "1"b;
 385                     else drop = "0"b;
 386 
 387                end;
 388 
 389 work:
 390           save_cur_node = cg_stat$cur_node;
 391           cg_stat$cur_node = p;
 392 
 393           save_it = cg_stat$save_exp_called;
 394           update_ref = "1"b;
 395 
 396           update_long, in_storage = "0"b;
 397           op_code = p -> operator.op_code;
 398 
 399           do i = 1 to min (p -> operator.number, hbound (rand, 1));
 400                rand (i) = p -> operand (i);
 401           end;
 402 
 403           op_rel = fixed (op_relative, 4);
 404           k = opcode_info$table (fixed (op_class, 5)) + op_rel;
 405           if k > opcode_info$last_opcode
 406           then goto not_yet;
 407 
 408           q = addr (opcode_info$opcode_info (k));
 409           action = fixed (q -> op_info.act1, 6);
 410 
 411           goto switch_a (action);
 412 
 413 /* assignment and picture operators */
 414 
 415 switch_a (1):
 416           call assign_op (pt);
 417           ref1 = cg_stat$temp_ref;
 418           goto return;
 419 
 420 /* min and max builtins */
 421 
 422 switch_a (2):
 423           call min_max (pt);
 424           ref1 = cg_stat$temp_ref;
 425 
 426           if ref1 -> reference.symbol -> symbol.decimal
 427           then goto return;
 428 
 429           inline = "1"b;
 430           goto done_1;
 431 
 432 /* error conditions */
 433 
 434 switch_a (4):
 435           call cg_error (300, fixed (op_code, 9));          /* operator in wrong context */
 436           goto return;
 437 
 438 switch_a (5):
 439 not_yet:
 440           call cg_error (301, fixed (op_code, 9));          /* operator not yet implemented */
 441           goto return;
 442 
 443 /* pointer valued builtin functions */
 444 
 445 switch_a (6):
 446           call pointer_builtins (p, ^drop);
 447 
 448 /* This used to avoid references that were shared. Now that shared */
 449 /* temps are no longer permitted on the output side of pointer expressions, */
 450 /* we set evaluated. This sets evaluated for non-tems in particular */
 451 /* So any non-temp, or any non-shared temp is set evaluated */
 452 
 453           ref1 = p -> operator.operand (1);
 454           if ^ref1 -> reference.temp_ref | ^ref1 -> reference.shared
 455           then ref1 -> reference.evaluated = "1"b;
 456 
 457           goto return;
 458 
 459 /* most op codes come here */
 460 
 461 switch_a (3):
 462           action = fixed (q -> op_info.act2, 6);
 463           macro = fixed (q -> op_info.macro, 18);
 464           delta = fixed (q -> op_info.delta, 2);
 465           call_code = fixed (q -> op_info.call_code, 4);
 466 
 467           n = p -> operator.number;
 468           do i = n by -1 to 2;
 469                q = prepare_operand (rand (i), 1, atom (i));
 470                ref (i) = q;
 471                sym (i) = q -> reference.symbol;
 472                type (i) = q -> reference.data_type;
 473           end;
 474 
 475 /* There appears to be a convention that the size expression must be evaluated
 476    before m_a is called.  So, we evaluate the size expression here for those
 477    optimizations that would otherwise call m_a before evaluating the size
 478    expression. This fixes 1985. */
 479 
 480 /* This fix referenced ref (2) for operators with only one operand. oops */
 481 
 482           if op_code = repeat_fun
 483           then if ref (2) -> reference.c_length = 1 & is_string_constant (2)
 484                then ref1 = prepare_operand (rand (1), 1, atom (1));
 485                else go to prepare_minus_1;
 486           else
 487 prepare_minus_1:
 488                ref1 = prepare_operand (rand (1), -1, atom (1));
 489 
 490           ref (1) = ref1;
 491           sym (1) = ref (1) -> reference.symbol;
 492           type (1) = ref (1) -> reference.data_type;
 493 
 494 /* we can't use the "for_test" code sequences if result is needed elsewhere */
 495 
 496           cg_stat$for_test_called = cg_stat$for_test_called & ref1 -> reference.ref_count <= 1;
 497 
 498           if sym (1) -> symbol.decimal
 499           then inline = "0"b;
 500 
 501           else if sym (1) -> symbol.complex | action = 7 | action = 30
 502           then inline = inline_operation (p, ref, atom);
 503 
 504           else /* operations with real results are done inline */
 505                inline = "1"b;
 506 
 507 /* compute context code */
 508 
 509           if n = 2
 510           then code = fixed (atom (2), 1);
 511           else if n = 3
 512           then code = fixed (atom (2) || atom (3), 2);
 513 
 514           if sym (1) -> symbol.complex & inline
 515           then do;
 516 
 517                     if ^ref (1) -> reference.allocate
 518                     then do;
 519 
 520 use_cpx:
 521                               q = get_reference ();
 522                               q -> reference = ref (1) -> reference;
 523                               ref (1) = q;
 524 
 525                               ref (1) -> reference.offset, ref (1) -> reference.qualifier = null;
 526                               string (ref (1) -> reference.address) = string (cg_stat$complex_ac -> reference.address);
 527                               ref (1) -> reference.relocation = cg_stat$complex_ac -> reference.relocation;
 528                               ref (1) -> reference.perm_address = "1"b;
 529                               goto branch;
 530                          end;
 531 
 532                     else if ref (1) -> reference.temp_ref
 533                     then do;
 534                               ref (1) -> reference.value_in.storage = "1"b;
 535                               if ^cg_stat$save_exp_called
 536                               then do;
 537                                         save_it = "1"b;
 538                                         ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
 539                                    end;
 540                          end;
 541 
 542                     if op_code = mult
 543                     then if min (type (2), type (3)) = complex_flt_bin_1
 544                          then goto use_cpx;
 545                          else ;
 546                     else if op_code = div
 547                     then if type (3) = complex_flt_bin_1
 548                          then goto use_cpx;
 549 
 550                     if ref (1) -> reference.offset ^= null
 551                     then goto use_cpx;
 552 
 553                     q = ref (1) -> reference.symbol;
 554                     if q -> symbol.static & q -> symbol.external
 555                     then goto use_cpx;
 556                     if q -> symbol.parameter
 557                     then goto use_cpx;
 558 
 559                     in_storage = "1"b;
 560                     update_ref = "0"b;
 561                end;
 562 
 563 branch:
 564           goto switch_b (action);
 565 
 566 /* arithmetic operators */
 567 
 568 switch_b (1):
 569           if ^inline
 570           then if sym (1) -> symbol.decimal
 571                then call decimal_op (pt, ref, atom);
 572 
 573 /* cannot do arithmetic operation inline, generate procedure call */
 574 
 575                else call gen_arithmetic_call (p, ref, atom);
 576 
 577           else call arith_op (pt, ref, atom);
 578 
 579 /* check to see if result should be stored */
 580 
 581 done:
 582           cg_stat$temp_ref = ref1;
 583 
 584 done_1:
 585           if ^ref1 -> reference.shared
 586           then ref1 -> reference.evaluated = "1"b;
 587 
 588           if ^inline
 589           then goto return;
 590 
 591           if cg_stat$for_test_called
 592           then goto return;
 593 
 594           if update_ref & (^ref1 -> reference.long_ref | update_long)
 595           then do;
 596                     k = ref1 -> reference.c_offset;
 597                     ref1 -> reference.c_offset = 0;
 598 
 599                     call state_man$update_ref (ref1);
 600 
 601                     ref1 -> reference.c_offset = k;
 602                end;
 603 
 604           if ref1 -> reference.allocate
 605           then do;
 606 
 607                     if ref1 -> reference.temp_ref
 608                     then if ^save_it
 609                          then if ^ref1 -> reference.aggregate
 610                               then go to return;
 611 
 612                     if ref1 -> reference.long_ref
 613                     then do;
 614                               if ref1 -> reference.temp_ref & ^ref1 -> reference.aggregate
 615                               then if ref1 -> reference.address_in.storage
 616                                    then call store$save_string_temp (ref1);
 617                                    else ;
 618                               else if ref1 ^= cg_stat$eis_temp
 619                               then call expmac$two_eis (chars_move + type (1) - char_string, ref1, cg_stat$eis_temp);
 620                               goto return;
 621                          end;
 622 
 623                     if in_storage
 624                     then goto return;
 625 
 626                     if ref1 -> reference.data_type = complex_flt_bin_1
 627                     then call expmac ((ldfx2), cg_stat$complex_ac);
 628 
 629                     call store$force (ref1);
 630                end;
 631 
 632 return:
 633           if cg_stat$save_exp_called
 634           then do;
 635                     ref_pt = cg_stat$temp_ref;
 636                     ref_pt -> reference.ref_count = orig_count;
 637                end;
 638           else if drop
 639           then call adjust_ref_count (ref1, -1);
 640 
 641 return_1:
 642           cg_stat$save_exp_called = sec;
 643           cg_stat$for_test_called = ftc;
 644           cg_stat$cur_node = save_cur_node;
 645           return;
 646 
 647 /* exponentiation operator */
 648 
 649 switch_b (2):
 650           if type (3) = real_fix_bin_1
 651           then if is_constant (3)
 652                then if sym (3) -> symbol.initial -> fixed_bin_single > 1
 653                     then do;
 654                               call exp_op (pt, ref, atom);
 655                               go to done;
 656                          end;
 657                     else if sym (3) -> symbol.initial -> fixed_bin_single = 1
 658                     then go to switch_a (1);
 659 
 660           check_type = "0"b;
 661           macro = exp_table (type (2), type (3));
 662           call math_op;
 663           goto done;
 664 
 665 /* string operators */
 666 
 667 switch_b (3):
 668           cg_stat$for_test_called = cg_stat$for_test_called & ref1 -> reference.ref_count <= 1;
 669 
 670           call string_op (pt, ref, code);
 671 
 672           goto done;
 673 
 674 /* relational operators */
 675 
 676 switch_b (4):
 677           call state_man$erase_temps;
 678           k = set_indicators (pt, ref (2), ref (3), code);
 679 
 680           if type (2) <= real_flt_bin_2
 681           then j = 0;
 682           else do;
 683                     q = ref (2) -> reference.symbol;
 684                     j = fixed (q -> symbol.bit | q -> symbol.char, 1);
 685                end;
 686 
 687           call expmac$zero ((rel_table (op_rel, j, k)));
 688           a_reg.size = 1;
 689           goto bnf1;
 690 
 691 /* rel, baseno, wordno, charno, bitno, (set, add)x(word bit char)no */
 692 
 693 
 694 declare   charno_mac          fixed bin (15) init (691) int static options (constant);
 695 declare   bitno_mac           fixed bin (15) init (692) int static options (constant);
 696 declare   baseno_mac          fixed bin (15) init (241) int static options (constant);
 697 declare   segno_mac           fixed bin (15) init (240) int static options (constant);
 698 declare   packed_pointer      bit (1) aligned;
 699 
 700 switch_b (5):
 701           if ref (2) -> reference.data_type = packed_ptr
 702           then do;
 703                     packed_pointer = "1"b;
 704                     if ^ref (2) -> reference.value_in.storage
 705                                                             /* if it happens to be in a PR from use, use it there! */
 706                     then if ^ref (2) -> reference.value_in.q/* in a PR */
 707                          then if string (ref (2) -> reference.value_in.b) ^= ""b
 708                               then packed_pointer = "0"b;   /* treat as unpacked */
 709                end;
 710           else do;
 711                     packed_pointer = "0"b;
 712 
 713                     if ^atom (2)                            /* first operand (other than output) */
 714                     then if rand (2) -> node.type = operator_node
 715                                                             /* certain packed pointers can be ^atom */
 716                          then do;                           /* must be turned into a pointer */
 717                                    call pointer_builtins (rand (2), "0"b);
 718                                    ref (2) = rand (2) -> operand (1);
 719                                    if ^ref (2) -> reference.shared
 720                                    then ref (2) -> reference.evaluated = "1"b;
 721                               end;
 722                end;
 723 
 724           if packed_pointer
 725           then go to PACKED_POINTER_BIFS (macro);
 726           else go to POINTER_BIFS (macro);                  /* macro contains 1...highest of these */
 727 
 728 
 729 PACKED_POINTER_BIFS (1):                                    /* rel */
 730 PACKED_POINTER_BIFS (10):                                   /* baseno */
 731           ref (2) -> reference.data_type = bit_string;
 732           go to LOAD_PP_COMMON;
 733 PACKED_POINTER_BIFS (2):                                    /* wordno */
 734 PACKED_POINTER_BIFS (3):
 735 PACKED_POINTER_BIFS (4):
 736 PACKED_POINTER_BIFS (9):                                    /* segno */
 737           ref (2) -> reference.data_type = real_fix_bin_1;
 738 
 739 LOAD_PP_COMMON:
 740           call load (ref (2), 0);
 741           ref (2) -> reference.data_type = packed_ptr;
 742 
 743           go to PACKED_POINTER_BIFS_2 (macro);              /* do the work */
 744 
 745 PACKED_POINTER_BIFS_2 (1):                                  /* rel */
 746           q = c_a ((bits_per_half), 1);                     /* no MOD */
 747           call expmac (als, q);
 748           go to RETURN_18_BITS;
 749 
 750 PACKED_POINTER_BIFS_2 (2):                                  /* wordno */
 751           q = c_a (-1, 2);                                  /* DL */
 752           call expmac (anq, q);
 753           go to done;
 754 
 755 declare   charno_packed_mac   init (377) fixed bin (15) int static options (constant);
 756 PACKED_POINTER_BIFS_2 (3):                                  /* charno */
 757           call expmac$zero (charno_packed_mac);             /* uses table */
 758           go to done;
 759 
 760 PACKED_POINTER_BIFS_2 (4):                                  /* bitno */
 761           q = c_a (12 + 18, 1);                             /* top 6 bits */
 762           call expmac (qrl, q);                             /* are the bit number */
 763           go to done;
 764 
 765 declare   baseno_mask         init (4095) fixed bin (18) static options (constant);
 766 
 767 PACKED_POINTER_BIFS_2 (9):                                  /* segno */
 768           q = c_a ((bits_per_half), 1);
 769           call expmac (qrl, q);
 770           q = c_a (baseno_mask, 2);                         /* DL */
 771           call expmac (anq, q);
 772           go to done;
 773 
 774 PACKED_POINTER_BIFS_2 (10):                                 /* baseno */
 775           q = c_a (baseno_mask, 3);                         /* DU */
 776           call expmac (ana, q);
 777           go to RETURN_18_BITS;
 778 
 779 
 780 POINTER_BIFS (1):                                           /* rel */
 781           call base_man$load_a_var (ref (2));
 782           go to RETURN_18_BITS;
 783 
 784 
 785 POINTER_BIFS (2):                                           /* wordno */
 786           call base_man$load_q_var (ref (2));
 787           macro = qrl;                                      /* to QL */
 788           q = c_a ((bits_per_half), 1);                     /* NO MOD */
 789           call expmac (macro, q);
 790           go to done;
 791 
 792 
 793 POINTER_BIFS (3):                                           /* charno */
 794           call base_man$load_aq_var (ref (2));
 795           call expmac$zero (charno_mac);
 796           go to done;
 797 
 798 POINTER_BIFS (4):                                           /* bitno */
 799           call base_man$load_aq_var (ref (2));
 800           call expmac$zero (bitno_mac);
 801           go to done;
 802 
 803 
 804 POINTER_BIFS (9):                                           /* segno */
 805 POINTER_BIFS (10):                                          /* baseno */
 806           call base_man$load_aq_var (ref (2));
 807           if op_code = segno_fun
 808           then do;
 809                     call expmac$zero (segno_mac);
 810                     go to done;
 811                end;
 812           call expmac$zero (baseno_mac);                    /* fall through */
 813 
 814 RETURN_18_BITS:
 815 l9a:
 816           a_reg.size = bits_per_half;
 817 
 818 bnf1:
 819           a_reg.length = bits_per_word;
 820           a_reg.offset = 0;
 821           goto done;
 822 
 823 
 824 /* bit_to_char, bit_to_word, char_to_word, half_to_word, word_to_mod2, word_to_mod4, word_to_mod8 operators */
 825 
 826 switch_b (6):
 827           if ^inline
 828           then goto ext_call;
 829 
 830 l2:
 831           if atom (2)
 832           then call load (ref (2), 0);
 833           else call compile_exp (rand (2));
 834 
 835           if delta = 1
 836           then macro = macro + fixed (type (1) ^= real_fix_bin_1, 1);
 837 
 838 switch_b (23):                                              /* not used by opcode_info */
 839 l2a:
 840           if macro ^= 0
 841           then call expmac$zero (macro);
 842           goto done;
 843 
 844 /* abs function */
 845 
 846 switch_b (7):
 847           if ^inline
 848           then do;
 849 
 850 ext_call:
 851                     load_it = "0"b;
 852                     if ref (1) -> reference.temp_ref & ^cg_stat$save_exp_called
 853                     then do;
 854                               if sym (1) -> symbol.binary & sym (1) -> symbol.real
 855                               then if sym (2) -> symbol.decimal
 856                                    then do;
 857                                              load_it = "0"b;
 858                                              bump = 0;
 859                                              inline = "1"b;
 860                                         end;
 861                                    else do;
 862                                              load_it = "1"b;
 863                                              bump = 2;
 864                                         end;
 865                               else bump = 1;
 866 
 867                               if ^ref (1) -> reference.shared
 868                               then ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + bump;
 869                          end;
 870 
 871                     if sym (2) -> symbol.decimal
 872                     then call decimal_op (p, ref, atom);
 873                     else call gen_arithmetic_builtin (p, ref, atom, call_code);
 874 
 875                     if load_it
 876                     then call load (ref (1), 0);
 877 
 878                     goto done;
 879                end;
 880 
 881           if atom (2)
 882           then call load$for_test (ref (2), 0);
 883           else call compile_exp_and_set_indicators (rand (2), type (2));
 884 
 885           macro = absfx1 - real_fix_bin_1 + type (2);
 886           goto l2a;
 887 
 888 /* trunc function */
 889 
 890 switch_b (8):
 891           if ^inline
 892           then goto ext_call;
 893 
 894           if sym (2) -> symbol.float
 895           then do;
 896                     macro = trunc_mac (fixed (type (1) ^= real_fix_bin_1, 1));
 897                     goto l2;
 898                end;
 899 
 900 /* the operation has no meaning for non-positive scales */
 901 
 902 l7:
 903           if sym (2) -> symbol.scale <= 0
 904           then do;
 905                     macro = 0;
 906                     goto l2;
 907                end;
 908 
 909           scale = sym (2) -> symbol.scale;
 910           if atom (2)
 911           then call load (ref (2), 0);
 912           else call compile_exp (rand (2));
 913 
 914           k = type (2) - real_fix_bin_1;
 915           macro = macro + k;
 916 
 917           call xr_man$load_const (scale, 2);
 918 
 919           if k > 0
 920           then if action ^= 8
 921                then call xr_man$load_const (-2 * scale, 3);
 922           goto l2a;
 923 
 924 /* trans_sign and mod functions */
 925 
 926 switch_b (9):
 927           if ^atom (3)
 928           then ref (3) = compile_exp$save (rand (3));
 929           if atom (2)
 930           then call load (ref (2), 0);
 931           else call compile_exp (rand (2));
 932 
 933           if delta = 1
 934           then macro = macro + fixed (type (1) ^= real_fix_bin_1, 1);
 935 
 936           call expmac (macro, ref (3));
 937 
 938           if action = 21
 939           then if scaled
 940                then do;
 941                          array (1) = sym (2) -> symbol.scale;
 942                          array (2) = sym (3) -> symbol.scale;
 943                          call expmac$abs (addr (array), 2);
 944                     end;
 945           goto done;
 946 
 947 /* bound_ck and range_ck operators */
 948 
 949 switch_b (10):
 950           call expmac$conditional (macro, pt, ref, atom);
 951           goto done;
 952 
 953 /* concatenation operator */
 954 
 955 switch_b (14):
 956           cg_stat$for_test_called = "0"b;
 957           call cat_op (pt, ref, code);
 958           goto done;
 959 
 960 /* index operator */
 961 
 962 switch_b (15):
 963           if op_code = index_fun
 964           then m = 1;
 965           else if op_code = index_before_fun
 966           then m = 2;
 967           else m = 3;
 968 
 969           if type (2) = char_string
 970           then do;
 971                     rlength = ref (3) -> reference.c_length;
 972                     if rlength = 1 | rlength = 2
 973                     then do;
 974                               if op_code = index_rev_fun
 975                               then macro = index_rev_mac (rlength);
 976                               else macro = index_mac (m, rlength);
 977                               if ^atom (2)
 978                               then ref (2) = compile_exp$save_exp (rand (2));
 979                               if ^atom (3)
 980                               then ref (3) = compile_exp$save_exp (rand (3));
 981                               call expmac$two_eis (macro, ref (2), ref (3));
 982                               go to done;
 983                          end;
 984                     else if op_code = index_rev_fun
 985                     then m = 4;
 986                end;
 987 
 988           else if ref (3) -> reference.c_length = 1         /* Must be bit string */
 989           then do;
 990                     if ^atom (2)
 991                     then if rand (2) -> node.type = operator_node
 992                          then if rand (2) -> operator.op_code = reverse_fun
 993                               then goto ind0;
 994                               else ref (2) = compile_exp$save (rand (2));
 995 
 996                     call compile_exp (rand (3));
 997 
 998 /* protect rand(3) in a, if necessary by getting ref(2)'s address early */
 999 
1000                     if ref (2) -> reference.big_offset
1001                     then do;
1002                               call aq_man$lock (null, 1);
1003                               if ^ref (2) -> reference.shared
1004                               then ref (2) -> reference.ref_count = ref (2) -> reference.ref_count + 1;
1005                               call base_man$load_var (2, ref (2), 1);
1006                          end;
1007 
1008                     call long_op$c_or_b (ref (2), 0, (index_chars_1 (m)));
1009                     goto done;
1010                end;
1011 
1012 /* not single char|bit case */
1013 
1014 ind0:
1015           if ^atom (3)
1016           then ref (3) = compile_exp$save_exp (rand (3));
1017 
1018           if ^atom (2)
1019           then call compile_string;
1020 
1021           call load$long_string (ref (2));
1022           call long_op$c_or_b (ref (3), 0, (index_chars (m)));
1023           goto done;
1024 
1025 /* length function as top operand of tree */
1026 
1027 switch_b (16):
1028           call load_size (ref (2));
1029           if ^ref (2) -> reference.shared
1030           then call adjust_ref_count (ref (2), -1);
1031           goto done;
1032 
1033 /* offset function */
1034 
1035 switch_b (17):
1036           if ^atom (2)
1037           then ref (2) = compile_exp$save (rand (2));
1038 
1039           pa = ref (2) -> reference.symbol;
1040           if pa -> symbol.constant
1041           then do;
1042 
1043 /* must be null pointer on right */
1044 
1045                     call load (generate_constant$real_fix_bin_1 (cg_stat$offset_null_value), 0);
1046                     goto done;
1047                end;
1048 
1049           call check_ptr;
1050 
1051           call load (ref (2), 0);
1052           k = ref (2) -> reference.data_type - unpacked_ptr;
1053 
1054           pa = ref (3) -> reference.symbol;
1055           if pa -> symbol.internal & (pa -> symbol.auto | pa -> symbol.static)
1056           then macro = offset_mac_easy;
1057           else macro = offset_mac_hard;
1058 
1059           call expmac (macro + k, ref (3));
1060           goto done;
1061 
1062 /* assign_zero and stack_ptr operators */
1063 
1064 switch_b (18):
1065           call expmac (macro, ref (1));
1066           cg_stat$temp_ref = ref (1);
1067           goto return;
1068 
1069 /* desc_size operator */
1070 
1071 switch_b (19):
1072           call expmac (macro, ref (2));
1073           goto done;
1074 
1075 /* floor and ceiling functions */
1076 
1077 switch_b (20):
1078           if ^inline
1079           then goto ext_call;
1080 
1081           if sym (2) -> symbol.float
1082           then do;
1083                     macro = macro + 2;
1084                     goto l2;
1085                end;
1086 
1087           goto l7;
1088 
1089 /* pl1 mod function */
1090 
1091 switch_b (21):
1092           if ^inline
1093           then goto ext_call;
1094 
1095           scaled = "0"b;
1096 
1097           if sym (1) -> symbol.float
1098           then do;
1099                     if type (1) = real_flt_bin_1
1100                     then macro = mdfl1;
1101                     else do;
1102                               macro = mdfl2;
1103 
1104                               if type (3) = real_flt_bin_1
1105                               then do;
1106 
1107                                         if atom (3) & is_constant (3)
1108                                         then do;
1109                                                   double = sym (3) -> symbol.initial -> word;
1110                                                   ref (3) = generate_constant$bit_string (double, (bits_per_two_words));
1111                                                   ref (3) -> reference.symbol -> symbol.boundary = mod2_;
1112                                              end;
1113                                         else do;
1114                                                   call compile_exp (rand (3));
1115                                                   call save_ref_3;
1116                                              end;
1117 
1118                                         atom (3) = "1"b;
1119                                    end;
1120                          end;
1121 
1122                     goto switch_b (9);
1123                end;
1124 
1125           k = 2 * type (2) + type (3) - 3;
1126 
1127           if sym (2) -> symbol.scale = 0 & sym (3) -> symbol.scale = 0
1128           then macro = macro + k;
1129           else do;
1130                     macro = scaled_mdfx1 + k;
1131                     scaled = "1"b;
1132                end;
1133 
1134           go to switch_b (9);
1135 
1136 /* round function */
1137 
1138 switch_b (22):
1139           if ^inline
1140           then goto ext_call;
1141           if sym (1) -> symbol.complex
1142           then goto ext_call;
1143 
1144           if atom (2)
1145           then call load (ref (2), 0);
1146           else call compile_exp (rand (2));
1147 
1148           if type (3) = real_fix_bin_1
1149           then k = sym (3) -> symbol.initial -> fixed_bin_single;
1150           else k = sym (3) -> symbol.initial -> fixed_bin_double;
1151 
1152           if sym (2) -> symbol.float
1153           then do;
1154                     call expmac ((round_fl), c_a ((k), 1));
1155                     goto done;
1156                end;
1157 
1158           macro = macro + type (2) - real_fix_bin_1;
1159 
1160           j = sym (2) -> symbol.scale - k;
1161 
1162           if j > 0
1163           then do;
1164                     call xr_man$load_const (j, 7);
1165                     goto l2a;
1166                end;
1167           else do;
1168                     call aq_man$fix_scale (ref (2), k, type (1));
1169                     go to done;
1170                end;
1171 
1172 /* repeat and reverse operator */
1173 
1174 switch_b (24):
1175           if (op_code = repeat_fun) & (ref (2) -> reference.c_length = 1) & is_string_constant (2)
1176           then do;
1177 
1178 /* we can just emit an mlr or csl with fill to compile this operator
1179 
1180    NOTE: For this optimization, prepare_operand was called on rand (1) to
1181    evaluate the size expression as well as the offset expression.  This
1182    ensures that the size expression is evaluated before m_a gets called.  It
1183    gets called during the call to expmac$one_eis.  This fixes 1985. */
1184 
1185                     cg_stat$for_test_called = "0"b;
1186 
1187                     call adjust_ref_count (rand (3), -1);
1188 
1189                     ref (1) = string_temp (p, ref (2), null);
1190 
1191                     if type (1) = char_string
1192                     then macro = blank_cs;
1193                     else do;
1194                               if ref (2) -> reference.units = word_
1195                               then c_offset = ref (2) -> reference.c_offset * bits_per_word;
1196                               else c_offset = ref (2) -> reference.c_offset;
1197                                                             /* must be in bits already */
1198 
1199                               if substr (sym (2) -> symbol.initial -> based_bs, c_offset + 1, 1)
1200                               then macro = one_bs;
1201                               else macro = zero_bs;
1202                          end;
1203 
1204                     call expmac$one_eis (macro, ref (1));
1205 
1206                     if type (1) = char_string
1207                     then do;
1208                               if ref (2) -> reference.units = word_
1209                               then c_offset = ref (2) -> reference.c_offset * chars_per_word;
1210                               else c_offset = ref (2) -> reference.c_offset;
1211                                                             /* units must already be chars */
1212 
1213                               addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> mlr_instruction.fill =
1214                                    substr (sym (2) -> symbol.initial -> based_cs, c_offset + 1, 1);
1215                          end;
1216 
1217                     go to eis_done;
1218                end;
1219 
1220           if op_code = reverse_fun
1221           then if ref (2) -> reference.c_length = 2
1222                then if ref1 -> reference.temp_ref & ^ref1 -> reference.aggregate
1223                     then do;
1224 
1225 /* reverse 2 chars- to make better code for reverse index */
1226 
1227                               if type (1) = char_string
1228                               then macro = chars_move;
1229                               else macro = move_bits;
1230                               call adjust_ref_count (ref (2), 1);
1231                                                             /* Gonna use twice */
1232                               if ^atom (2)
1233                               then ref (2) = compile_exp$save_exp (rand (2));
1234                               ref (1) = string_temp (p, ref (2), null);
1235                               if ^(^ref (1) -> reference.aggregate & ref (1) -> reference.temp_ref)
1236                               then call adjust_ref_count (ref (1), 1);
1237                               save_l1 = ref (1) -> reference.c_length;
1238                               save_l2 = ref (2) -> reference.c_length;
1239                               ref (1) -> reference.c_length, ref (2) -> reference.c_length = 1;
1240                               call adjust_c_offset (ref (1), +1);
1241                               call expmac$two_eis (macro, ref (1), ref (2));
1242                               call restore_c_offset (ref (1));
1243                               call adjust_c_offset (ref (2), +1);
1244                               call expmac$two_eis (macro, ref (1), ref (2));
1245                               call restore_c_offset (ref (2));
1246                               ref (1) -> reference.c_length = save_l1;
1247                               ref (2) -> reference.c_length = save_l2;
1248 
1249                               goto eis_done;
1250                          end;
1251 
1252           if atom (2)
1253           then do;
1254 l10:
1255                     call load$long_string (ref (2));
1256 
1257                     if op_code = repeat_fun
1258                     then if atom (3)
1259                          then call load (ref (3), 0);
1260                          else call compile_exp (rand (3));
1261                     else macro = macro + type (1) - char_string;
1262 
1263                     call expmac$zero (macro);
1264 
1265                     if type (1) = bit_string
1266                     then do;
1267                               machine_state.indicators = ind_invalid;
1268                               cg_stat$for_test_called = "0"b;
1269                          end;
1270 
1271 l10a:
1272                     if ref (1) -> reference.length ^= null
1273                     then do;
1274 
1275 /* for reverse or repeat the length may be considered
1276                        evaluated and in the q reg; for translate the length
1277                        is either already evaluated or is the length_fun op
1278                        which needs processing */
1279 
1280                               if action = 24
1281                               then do;
1282                                         pa = prepare_operand ((ref (1) -> reference.length), 0, atomic);
1283 
1284                                         if atomic
1285                                         then if ^pa -> reference.temp_ref
1286                                              then ref (1) -> reference.length = pa;
1287                                              else ;
1288                                         else do;
1289                                                   if pa -> reference.shared
1290                                                   then pa, ref (1) -> reference.length -> operand (1) = copy_temp (pa);
1291                                                   pa -> reference.evaluated = "1"b;
1292                                              end;
1293 
1294                                         call state_man$update_ref (pa);
1295                                    end;
1296                               else ref (1) -> reference.length = eval_exp ((ref (1) -> reference.length), "1"b);
1297                          end;
1298                     else if ref (1) -> reference.c_length <= max_short_size (type (1))
1299                     then call expmac$zero (fetch_chars_eis - char_string + type (1));
1300 
1301                     if ref (1) -> reference.long_ref
1302                     then do;
1303                               update_long = ref (1) -> reference.temp_ref & ^ref (1) -> reference.aggregate;
1304                               if update_long
1305                               then if ref (1) -> reference.length = null
1306                                    then if ref (1) -> reference.ref_count - fixed (cg_stat$save_exp_called, 1) > 1
1307                                         then do;
1308                                                   update_long = "0"b;
1309                                                   q = copy_temp (ref (1));
1310                                                   call state_man$update_ref (q);
1311                                                   call expmac$two_eis (chars_move + type (1) - char_string, ref (1), q);
1312                                              end;
1313                                         else ;
1314                                    else ;
1315                               else do;
1316                                         q, cg_stat$eis_temp = COPY (ref (1));
1317                                         if ref (1) -> reference.length ^= null
1318                                         then q -> reference.length = share_expression ((ref (1) -> reference.length));
1319                                         q -> reference.ref_count = 1;
1320                                         call state_man$update_ref (q);
1321                                    end;
1322                          end;
1323 
1324                     cg_stat$extended_stack = "1"b;
1325 
1326                     goto done;
1327                end;
1328 
1329           call compile_string;
1330           goto l10;
1331 
1332 /* verify and search functions */
1333 
1334 switch_b (25):
1335           if ^atom (3)
1336           then ref (3) = compile_exp$save_exp (rand (3));
1337 
1338           if ref (2) -> reference.c_length = 1
1339           then do;
1340                     if ^atom (2)
1341                     then call compile_string;
1342                     if op_code = verify_fun | op_code = verify_rev_fun
1343                     then macro = inline_verify;
1344                     else macro = inline_search;
1345                     call expmac$two_eis (macro, ref (2), ref (3));
1346                end;
1347 
1348           else if is_constant (3)
1349           then do;
1350                     if op_code = verify_ltrim_fun
1351                     then macro = verify_ltrim_inline;
1352                     else if op_code = verify_rtrim_fun
1353                     then macro = verify_rtrim_inline;
1354                     else if op_code = verify_rev_fun | op_code = search_rev_fun
1355                     then macro = test_translate_rev;
1356                     else macro = test_translate;
1357                     if ^atom (2)
1358                     then ref (2) = compile_exp$save_exp (rand (2));
1359                     if op_code = search_rev_fun
1360                     then op_code = search_fun;              /* Make tests below easier */
1361                     q = sym (3) -> symbol.initial;
1362 
1363                     if (ref (3) -> reference.c_length = 1) & (op_code ^= search_fun)
1364                     then q = c_a (rank (substr (q -> based_cs, 1, 1)), 16);
1365                                                             /* use the table in pl1_operators_ */
1366                     else do;
1367                               string (bit_table) = "0"b;
1368                               do i = 1 to ref (3) -> reference.c_length;
1369                                    j = rank (substr (q -> based_cs, i, 1));
1370                                    bit_table (j) = "777"b3;
1371                               end;
1372 
1373                               if op_code ^= search_fun
1374                               then string (bit_table) = ^string (bit_table);
1375 
1376                               q = generate_constant$char_string (mvt_table, length (mvt_table));
1377                          end;
1378 
1379                     call expmac$two_eis (macro, ref (2), q);
1380                end;
1381 
1382           else do;
1383                     if ^atom (2)
1384                     then call compile_string;
1385                     call long_op$eis_operator (ref (2), ref (3), macro);
1386                end;
1387 
1388           go to done;
1389 
1390 /* translate function */
1391 
1392 switch_b (26):
1393           if n = 4
1394           then macro = macro + 1;
1395 
1396           constant_rands = "1"b;
1397 
1398           do i = 3 to n;
1399                if ^atom (i)
1400                then do;
1401                          ref (i) = compile_exp$save_exp (rand (i));
1402                          constant_rands = "0"b;
1403                     end;
1404                else constant_rands = constant_rands & is_constant (i);
1405           end;
1406 
1407           if constant_rands
1408           then do;
1409 
1410 /* The second and third args to the translate bif are constant, so we
1411                   can generate an inline translate sequence */
1412 
1413                     if ^atom (2)
1414                     then ref (2) = compile_exp$save_exp (rand (2));
1415                     if ref (2) -> reference.value_in.string_aq
1416                                                             /* We must make sure string_temp */
1417                     then call state_man$erase_reg ("001"b); /* doesn't attempt to reuse space used foor ref(2) */
1418 
1419                     ref (1) = string_temp (p, ref (2), null);
1420 
1421 /* We must generate a translate table for use with an mvt instruction */
1422 
1423                     mvt_table = collate9 ();
1424 
1425                     q = sym (3) -> symbol.initial;
1426 
1427                     if n = 3
1428                     then mvt_table = substr (q -> based_cs, 1, ref (3) -> reference.c_length);
1429                     else do;
1430                               result_string = substr (q -> based_cs, 1, ref (3) -> reference.c_length);
1431                               q = sym (4) -> symbol.initial;
1432                               do i = ref (4) -> reference.c_length to 1 by -1;
1433                                    j = rank (substr (q -> based_cs, i, 1));
1434                                    substr (mvt_table, j + 1, 1) = substr (result_string, i, 1);
1435                               end;
1436                          end;
1437 
1438                     ref (3) = generate_constant$char_string (mvt_table, length (mvt_table));
1439 
1440                     call expmac$many_eis ((inline_translate), addr (ref), 3);
1441 eis_done:
1442                     if ^ref (1) -> reference.long_ref
1443                     then if ^cg_stat$for_test_called
1444                          then do;
1445                                    update_ref = "0"b;
1446                                    in_storage = ref1 = ref (1);
1447                                    if ^(cg_stat$save_exp_called & in_storage) & ref (1) -> reference.temp_ref
1448                                         & ^ref (1) -> reference.aggregate
1449                                    then do;
1450                                              if in_storage
1451                                              then if ^ref (1) -> reference.shared
1452                                                   then ref (1) -> reference.ref_count =
1453                                                             ref (1) -> reference.ref_count + 1;
1454                                              call load (ref (1), 1);
1455                                         end;
1456                               end;
1457                     go to done;
1458                end;
1459 
1460           else do;
1461 
1462 /* generate operator call */
1463 
1464                     if ^atom (2)
1465                     then call compile_string;
1466 
1467                     call load$long_string (ref (2));
1468 
1469                     if n = 3
1470                     then call long_op (ref (3), 0, macro);
1471                     else call long_op$eis_operator (ref (3), ref (4), macro);
1472 
1473 /* Since operator allocates own temp, we must branch for special handling */
1474 
1475                     go to l10a;
1476                end;
1477 
1478 /* lock_fun (stac) function */
1479 
1480 switch_b (27):
1481           if ^atom (2)
1482           then ref (2) = compile_exp$save (rand (2));
1483 
1484           call compile_exp (rand (3));
1485 
1486           call base_man$load_var (1, ref (2), 1);
1487           call state_man$set_aliasables (null);
1488           call expmac$zero (macro);
1489 
1490           a_reg.size = 1;
1491           goto bnf1;
1492 
1493 switch_b (29):                                              /* complex and conjg functions */
1494 switch_b (30):                                              /* real and imag functions */
1495           if inline
1496           then goto switch_b (10);
1497           else goto ext_call;
1498 
1499 /* sign function */
1500 
1501 switch_b (31):
1502           if sym (2) -> symbol.decimal
1503           then go to ext_call;
1504 
1505           if atom (2)
1506           then call load$for_test (ref (2), 0);
1507           else call compile_exp_and_set_indicators (rand (2), type (2));
1508 
1509           goto l2a;
1510 
1511 /* allocation function */
1512 
1513 switch_b (32):
1514           if sym (2) -> symbol.internal
1515           then n = 13;
1516           else n = 9;
1517 
1518           ref (2) = c_a ((sym (2) -> symbol.location), n);
1519           goto switch_b (19);
1520 
1521 /* bool function */
1522 
1523 switch_b (33):
1524           if ^atom (2)
1525           then ref (2) = compile_exp$save_exp (rand (2));
1526 
1527           if ^atom (3)
1528           then if rand (3) -> node.type = operator_node
1529                then if ref (3) -> reference.long_ref & atom (4)
1530                     then call compile_exp (rand (3));
1531                     else ref (3) = compile_exp$save (rand (3));
1532 
1533           cg_stat$for_test_called =
1534                cg_stat$for_test_called & is_constant (4) & ref (2) -> reference.length = ref (3) -> reference.length
1535                & ref (2) -> reference.c_length <= ref (3) -> reference.c_length;
1536 
1537           ref (1) = string_temp (p, ref (3), ref (2));
1538 
1539           if is_constant (4)
1540           then do;
1541                     if cg_stat$for_test_called
1542                     then m = test_bits;
1543                     else m = move_bits;
1544                     call expmac$eis (m, ref (2));
1545                     addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> csl_instruction.bool =
1546                          sym (4) -> symbol.initial -> bit4;
1547                end;
1548 
1549           else do;
1550                     call compile_exp (rand (4));
1551                     call state_man$erase_reg ("1"b);
1552                     call expmac ((arl), c_a (32, 1));
1553 
1554                     if need_areg ()
1555                     then do;
1556                               call expmac$zero ((a_to_x0));
1557                               macro = macro + 1;
1558                          end;
1559                     else call aq_man$lock (null, 1);
1560 
1561                     call expmac$eis (macro, ref (2));
1562                end;
1563 
1564           go to eis_done;
1565 
1566 /* math builtins */
1567 
1568 switch_b (34):
1569           if n = 3
1570           then do;
1571                     check_type = "1"b;
1572                     if op_code = atan_fun
1573                     then macro = atan2_mac;
1574                     else macro = atan2d_mac;
1575                end;
1576 
1577           if type (1) = real_flt_bin_2
1578           then macro = macro + 1;
1579 
1580           call math_op;
1581           go to done;
1582 
1583 /* stacq function.  we will generate the following code:
1584                     lda       ref3
1585                     epp2      ref2
1586                     ldq       ref4
1587                     tsx0      ap|stacq_op         */
1588 
1589 switch_b (35):
1590           if ^atom (2)
1591           then ref (2) = compile_exp$save (rand (2));
1592 
1593           if ^atom (4)
1594           then ref (4) = compile_exp$save (rand (4));
1595 
1596           call compile_exp (rand (3));
1597           call base_man$load_var (2, ref (2), 1 /* pr2 */);
1598           if ref (2) -> reference.aliasable
1599           then call state_man$set_aliasables (ref (2));
1600           call expmac (macro, ref (4));
1601           a_reg.size = 1;
1602           go to bnf1;
1603 
1604 /* clock and vclock functions.  we will generate the following code:
1605                     tsx0      ap|clock_op
1606           or        tsx0      ap|vclock_op        */
1607 
1608 switch_b (36):
1609           call state_man$erase_reg ((18)"0"b || "1"b);      /* erase pr7 */
1610           call expmac$zero (macro);
1611           go to done;
1612 
1613 /* byte builtin function. we generate the following code:
1614                     ldq       ref2
1615                     lls       63        */
1616 
1617 switch_b (37):
1618           if ^atom (2)
1619           then call compile_exp (rand (2));
1620           else call load (ref (2), 0);
1621 
1622           call aq_man$check_strings (0);
1623           a_reg.offset = 63;
1624           a_reg.length = 9;
1625           a_reg.size = 72;
1626           call aq_man$left_shift (63, "1"b);
1627           go to done;
1628 
1629 /* rank builtin function. we generate the following code:
1630              hard_to_load case:
1631                     mrl       (...),(pr),fill(000)
1632                     desc9a    ref2,1
1633                     desc9a    sp|46,4
1634                     ldq       sp|46
1635 
1636              everything else:
1637                     lda       ref2
1638                     lrl       63        */
1639 
1640 switch_b (38):
1641           if ref (2) -> reference.hard_to_load
1642           then do;
1643 
1644 /* hard_to_load implies operand is a reference, not an expression */
1645 
1646                     if ^ref (1) -> reference.temp_ref | ref (1) -> reference.ref_count > 1
1647                     then q = ref (1);
1648                     else q = c_a (46, 4);                   /* sp|46 (double temp) */
1649 
1650                     if q -> reference.temp_ref
1651                     then q -> reference.value_in.storage = "1"b;
1652 
1653                     call expmac$two_eis (rank_eis_mac, q, ref (2));
1654                     in_storage = "1"b;
1655 
1656                     if ^save_it & ref (1) -> reference.temp_ref
1657                     then do;
1658                               if ^ref (1) -> reference.shared
1659                               then ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
1660 
1661                               call expmac (ldfx1, q);
1662                          end;
1663                     else update_ref = "0"b;
1664                end;
1665           else do;
1666                     if atom (2)
1667                     then call load (ref (2), 1);
1668                     else call compile_exp (rand (2));
1669 
1670                     call aq_man$right_shift (63, "1"b);
1671                     a_reg.offset, a_reg.size, a_reg.length = 0;
1672                end;
1673           go to done;
1674 ^L
1675 compile_exp$for_test:
1676      entry (pt);
1677 
1678           ftc = cg_stat$for_test_called;
1679           cg_stat$for_test_called = "1"b;
1680           goto start;
1681 
1682 compile_exp$save:
1683      entry (pt, ref_pt);
1684 
1685 dcl       ref_pt              ptr;                          /* will be set to reference node for result */
1686 
1687           p = pt;
1688           if p -> node.type ^= operator_node
1689           then do;
1690 
1691                     if ^p -> reference.aligned_ref
1692                     then do;
1693 
1694 l4:
1695                               i = p -> reference.data_type;
1696                               is_string = i = char_string | i = bit_string;
1697 
1698                               if p -> reference.hard_to_load
1699                               then if substr (string (p -> reference.value_in), 1, 2) = "00"b
1700                                                             /* not in a or q */
1701                                    then if p -> reference.ref_count > 0
1702                                         then do;
1703                                                   if is_string | mod (p -> reference.c_length, bits_per_word) = 0
1704                                                   then do;
1705                                                             call load$for_save (p, 0);
1706                                                             go to l5;
1707                                                        end;
1708                                              end;
1709 
1710                               call load (p, fixed (is_string, 1));
1711 
1712 /* if the reference is now aligned, it was converted to a temporary
1713                        because its ref_count was greater than one */
1714 
1715                               if p -> reference.aligned_ref
1716                               then p -> reference.ref_count = p -> reference.ref_count + 2;
1717                               else p = COPY (p);
1718 
1719                               call store$force (p);
1720                          end;
1721 
1722 l5:
1723                     ref_pt = p;
1724                     return;
1725                end;
1726 
1727           check_aligned = "1"b;
1728 
1729 l6:
1730           ref (1) = p -> operand (1);
1731           if ref (1) -> reference.evaluated
1732           then do;
1733                     if check_aligned
1734                     then if ^ref (1) -> reference.aligned_ref
1735                          then if ^ref (1) -> reference.long_ref
1736                               then if ^ref (1) -> reference.varying_ref
1737                                    then if ^ref (1) -> reference.symbol -> symbol.decimal
1738                                         then do;
1739                                                   p = ref (1);
1740                                                   go to l4;
1741                                              end;
1742                     ref_pt = ref (1);
1743                     return;
1744                end;
1745 
1746           if ^ref (1) -> reference.allocate
1747           then do;
1748 
1749                     p -> operand (1) = copy_temp (ref (1));
1750                     orig_count = 1;
1751                     p -> operand (1) -> reference.ref_count = 2;
1752                end;
1753           else if ^ref (1) -> reference.shared
1754           then do;
1755                     orig_count = ref (1) -> reference.ref_count;
1756                     ref (1) -> reference.ref_count = orig_count + 1;
1757                end;
1758 
1759           ftc = cg_stat$for_test_called;
1760           cg_stat$for_test_called = "0"b;
1761 
1762           sec = cg_stat$save_exp_called;
1763           cg_stat$save_exp_called = "1"b;
1764 
1765           goto work;
1766 
1767 compile_exp$save_exp:
1768      entry (pt, ref_pt);
1769 
1770           p = pt;
1771           if p -> node.type ^= operator_node
1772           then goto l5;
1773 
1774           check_aligned = "0"b;
1775           goto l6;
1776 
1777 compile_exp$save_fix_scaled:
1778      entry (pt, target_scale, targ_type) returns (ptr);
1779 
1780 dcl       target_scale        fixed bin,
1781           target_type         fixed bin,
1782           targ_type           fixed bin;
1783 
1784           target_type = targ_type;
1785 save_join:
1786           p = pt;
1787           if p -> node.type ^= operator_node
1788           then call load (p, 0);
1789           else do;
1790                     call compile_exp (p);
1791                     p = p -> operand (1);
1792                end;
1793 
1794           if target_type <= real_fix_bin_2
1795           then call aq_man$fix_scale (p, target_scale, target_type);
1796 
1797           q = COPY (p);
1798           q -> reference.data_type = target_type;
1799 
1800           call stack_temp$assign_block (q, min (target_type, 2));
1801                                                             /* NOTE: size = type for real_fix_bin_1 or 2 */
1802 
1803           call expmac (stfx1 - real_fix_bin_1 + target_type, q);
1804 
1805           q -> reference.value_in.storage = "1"b;
1806 
1807           return (q);
1808 
1809 compile_exp$save_float_2:
1810      entry (pt) returns (ptr);
1811 
1812           target_type = real_flt_bin_2;
1813           goto save_join;
1814 ^L
1815 /* INTERNAL PROCEDURES */
1816 
1817 COPY:
1818      proc (pt) returns (ptr);
1819 
1820 dcl       (pt, p)             ptr;
1821 
1822           p = copy_temp (pt);
1823           p -> reference.units = word_;
1824           p -> reference.aligned_ref, p -> reference.padded_ref, p -> reference.aligned_for_store_ref,
1825                p -> reference.padded_for_store_ref = "1"b;
1826           p -> reference.aggregate = "0"b;
1827           p -> reference.c_offset = 0;
1828           p -> reference.ref_count = 2;
1829           p -> reference.length, p -> reference.offset, p -> reference.qualifier = null;
1830           return (p);
1831 
1832      end;
1833 
1834 check_ptr:
1835      proc;
1836 
1837           if ref (2) -> reference.temp_ref
1838           then if ^ref (2) -> reference.value_in.storage
1839                then if ^ref (2) -> reference.value_in.q
1840                     then do;
1841                               i = index (string (ref (2) -> reference.value_in.b), "1"b) - 1;
1842                               if i >= 0
1843                               then do;
1844                                         ref (2) -> reference.ref_count = ref (2) -> reference.ref_count + 1;
1845                                         call base_to_core (i, ref (2));
1846                                    end;
1847                          end;
1848 
1849      end;
1850 
1851 compile_exp_and_set_indicators:
1852      procedure (bv_ref, bv_type);
1853 
1854 /* compiles an ARITHMETIC expression and sets the indicators for testing */
1855 
1856 /* parameters */
1857 
1858 dcl       (
1859           bv_ref              ptr,
1860           bv_type             fixed bin
1861           )                   parameter;
1862 
1863 /* program */
1864 
1865           call compile_exp (bv_ref);
1866           if (machine_state.indicators ^= ind_arithmetic)
1867           then do;
1868                     call expmac$zero (testfx1 - real_fix_bin_1 + bv_type);
1869                     machine_state.indicators = ind_arithmetic;
1870                end;
1871 
1872      end /* compile_exp_and_set_indicators */;
1873 ^L
1874 compile_string:
1875      proc;
1876 
1877           if rand (2) -> node.type = operator_node
1878           then if ref (2) -> reference.long_ref
1879                then call compile_exp (rand (2));
1880                else ref (2) = compile_exp$save (rand (2));
1881 
1882      end;
1883 
1884 need_areg:
1885      proc returns (bit (1) aligned);
1886 
1887           if ref (1) -> reference.big_length
1888           then if ref (3) -> reference.big_length
1889                then if ref (1) -> reference.length ^= ref (3) -> reference.length
1890                          | ref (1) -> reference.c_length ^= ref (3) -> reference.c_length
1891                     then return ("1"b);
1892 
1893           return ("0"b);
1894      end;
1895 
1896 is_constant:
1897      proc (i) reducible returns (bit (1) aligned);
1898 
1899 dcl       i                   fixed bin;
1900 
1901           if sym (i) -> symbol.constant
1902           then if ^ref (i) -> reference.varying_ref
1903                then if ref (i) -> reference.offset = null
1904                     then if ref (i) -> reference.c_offset = 0
1905                          then if ref (i) -> reference.length = null
1906                               then return ("1"b);
1907 
1908           return ("0"b);
1909      end;
1910 ^L
1911 is_string_constant:
1912      proc (i) reducible returns (bit (1) aligned);
1913 
1914 dcl       i                   fixed bin;
1915 
1916           if sym (i) -> symbol.constant
1917           then if ^ref (i) -> reference.varying_ref
1918                then if ref (i) -> reference.offset = null
1919                     then if ref (i) -> reference.length = null
1920                          then return ("1"b);
1921 
1922           return ("0"b);
1923      end /* is_string_constant */;
1924 
1925 save_ref_3:
1926      proc;
1927 
1928           ref (3) = c_a (2, 12);
1929           ref (3) -> reference.ref_count = 2;
1930           call expmac ((stfl2), ref (3));
1931 
1932      end;
1933 
1934 
1935 math_op:
1936      proc;
1937 
1938 /*             procedure to issue calls to math operators   */
1939 
1940 dcl       adjust              bit (1) aligned;
1941 
1942           adjust = "0"b;
1943 
1944           if n = 3
1945           then if type (1) > type (3) & check_type
1946                then ref (3) = compile_exp$save_float_2 (rand (3));
1947                else if ^atom (3)
1948                then ref (3) = compile_exp$save (rand (3));
1949 
1950 /* load operand 2 into the q */
1951 
1952           if atom (2)
1953           then call load (ref (2), 0);
1954           else call compile_exp (rand (2));
1955 
1956           if n = 3
1957           then do;
1958                     if ref (3) -> reference.temp_ref
1959                     then do;
1960 
1961 /* protect operand(3) from being clobbered when temps are saved */
1962 
1963                               adjust = "1"b;
1964                               ref (3) -> reference.ref_count = ref (3) -> reference.ref_count + 1;
1965                          end;
1966 
1967 /* get a ptr to operand(3) into the ab */
1968 
1969                     call base_man$load_var (2, ref (3), 3);
1970                end;
1971 
1972 /*  get a ptr to the workspace into the bp */
1973 
1974           q = c_a (32, 12);
1975           q -> reference.ref_count = 2;
1976           call base_man$load_var (2, q, 1);
1977 
1978 /* we must flush all the registers because the math operators can make external calls */
1979 
1980           call state_man$flush;
1981 
1982           call expmac$zero (macro);
1983           machine_state.indicators = ind_arithmetic;
1984 
1985           if adjust
1986           then call adjust_ref_count (ref (3), -1);
1987           call adjust_ref_count (q, -1);
1988 
1989      end;
1990 
1991 adjust_c_offset:
1992      proc (p, delta);
1993 
1994 dcl       p                   ptr,
1995           delta               fixed bin;
1996 
1997           save_mwif = p -> reference.modword_in_offset;
1998           save_coff = p -> reference.c_offset;
1999           save_units = p -> reference.units;
2000           if save_mwif
2001           then p -> reference.c_offset = save_coff + delta;
2002           else if save_units < word_
2003           then p -> reference.c_offset = save_coff + delta;
2004           else do;
2005                     p -> reference.modword_in_offset = "1"b;
2006                     if p -> reference.data_type = bit_string
2007                     then do;
2008                               p -> reference.units = bit_;
2009                               p -> reference.c_offset = save_coff * bits_per_word + delta;
2010                          end;
2011                     else do;
2012                               p -> reference.units = character_;
2013                               p -> reference.c_offset = save_coff * chars_per_word + delta;
2014                          end;
2015                end;
2016      end;
2017 
2018 restore_c_offset:
2019      proc (p);
2020 
2021 dcl       p                   ptr;
2022 
2023           p -> reference.c_offset = save_coff;
2024           p -> reference.modword_in_offset = save_mwif;
2025           p -> reference.units = save_units;
2026      end;
2027 
2028 
2029      end compile_exp;