1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4    *                                                         *
   5    * Copyright (c) 1972 by Massachusetts Institute of        *
   6    * Technology and Honeywell Information Systems, Inc.      *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 
  11 /* procedure to generate call to convert a character string
  12 
  13    Initial Version: 21 September 1971 by BLW
  14           Modified: 18 October 1972 by BLW
  15           Modified: 15 February 1973 by RAB
  16           Modified: 30 July 1973 by RAB for EIS
  17           Modified: 26 May 1975 by RAB for assign_round
  18           Modified: 23 June 1976 by RAB to centralize use of cg_stat$last_call
  19           Modified: 7 Dec 1976 by RAB to fix 1558
  20           Modified: 13 Dec 1976 by RAB to fix 1561
  21           Modified: 14 Dec 1976 by RAB to change blank_on_zero mechanism in inline_picture
  22           Modified: 27 Jan 1977 by RAB to fix 1572
  23           Modified: 16 June 1977 by RAB to fix 1631
  24           Modified: 10 September 1977 by RAB to fix 1613 by adding 3rd arg to store_bit_address
  25           Modified: 4 October 1977 by RAB to fix 1676
  26           Modified: 31 July 1978 by PCK for unsigned binary
  27           Modified: 8 August 1978 by PCK to fix bug 1767
  28           Modified: 6 September 1978 by PCK to fix bug 1763
  29           Modified: 24 April 1978 by PCK to implement 4-bit decimal
  30           Modified: 30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
  31                     See prepare_operand for details.  Also fixes bug 1843 in which
  32                     padded unaligned strings are not padded if they are targets
  33                     of any_to_any_ calls.         */
  34 
  35 convert_chars: proc(left,right,check_size,always_round);
  36 
  37 dcl       left ptr,                     /* ptr to target */
  38           right ptr,                    /* ptr to source */
  39           check_size bit(1) aligned,    /* "1"b if size checking */
  40           always_round bit(1) aligned;  /* "1"b if we should always round */
  41 
  42 dcl       cg_stat$save_exp_called bit(1) ext,
  43           (cg_stat$double_temp,cg_stat$ext_proc_list,cg_stat$cur_block) ptr ext,
  44           cg_stat$text_pos fixed bin ext;
  45 
  46 dcl       (lp,arg(65),arg_pt,p,p1,p2,ap,q,buff(3),s,sym(2)) ptr;
  47 dcl       atomic              bit (1) aligned;
  48 dcl       (comparison,c,check,scaled,varying_target) bit(1),
  49           adjust bit(36),
  50           increment bit(1) aligned init("0"b),
  51           macro fixed bin(15),
  52           last_freed fixed bin(18),
  53           (iop,i,j,k,k1,k2,arg_pos,n_args,n,type(2),dtype(2),prec(2),scale(2),length_hold,iscan,tprec,word,nchars) fixed bin;
  54 
  55 dcl       c_a entry(fixed bin,fixed bin) returns(ptr),
  56           (aq_man$lock, aq_man$load_var, load_size$a_or_q) entry(ptr,fixed bin),
  57           base_man$load_var_and_lock entry(fixed bin,ptr,fixed bin),
  58           get_reference entry() returns(ptr),
  59           expmac$two_eis entry(fixed bin(15),ptr,ptr),
  60           expmac$one_eis entry(fixed bin(15),ptr),
  61           generate_constant$char_string entry(char(*) aligned, fixed bin) returns (ptr),
  62           expmac$many_eis entry(fixed bin(15),ptr,fixed bin),
  63           create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
  64           expmac$fill_usage entry(fixed bin,fixed bin),
  65           need_temp entry(ptr,bit(2) aligned),
  66           assign_op$length_of_varying entry(ptr,ptr),
  67           stack_temp$assign_block entry(ptr,fixed bin),
  68           state_man$unlock entry,
  69           xr_man$load_const entry(fixed bin,fixed bin),
  70           xr_man$super_lock entry(fixed bin);
  71 dcl       prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
  72 dcl       base_man$load_var entry(fixed bin,ptr,fixed bin),
  73           adjust_ref_count entry(ptr,fixed bin),
  74           long_op$extend_stack entry(ptr,fixed bin(15)),
  75           store$save_string_temp entry(ptr),
  76           copy_temp entry(ptr) returns(ptr),
  77           compile_exp entry(ptr),
  78           compile_exp$save entry(ptr) returns(ptr),
  79           compile_exp$save_exp entry(ptr) returns(ptr),
  80           create_list entry(fixed bin) returns(ptr),
  81           generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
  82           generate_constant entry(bit(*) aligned,fixed bin) returns(ptr);
  83 dcl       compile_link entry(char(*) aligned,bit(18) aligned,fixed bin) returns(fixed bin);
  84 dcl       store_bit_address entry(ptr,ptr,fixed bin(18)),
  85           expmac entry(fixed bin(15),ptr),
  86           expmac$many entry(fixed bin(15),ptr,fixed bin),
  87           expmac$zero entry(fixed bin(15)),
  88           reserve$declare_lib entry(fixed bin) returns(ptr),
  89           state_man$flush entry,
  90           state_man$flush_ref entry(ptr),
  91           stack_temp$free_temp entry(ptr),
  92           load entry(ptr,fixed bin);
  93 
  94 dcl       (abs,addr,bit,ceil,divide,fixed,float,index,length,max,mod,null,search,string,substr,unspec) builtin;
  95 
  96 dcl (     make_desc_mac       init(275),
  97           ldfx1               init(7),
  98           prepare_call        init(362),
  99           alloc_char_temp     init(89),
 100           move_chars          init(98),
 101           move_numeric        init(438),
 102           move_numeric_edit   init(221),
 103           dtb(2)              init(222,223),
 104           btd(2)              init(224,225),
 105           pic_mac(2)          init(417,416),
 106           conv_mac            init(412),
 107           zero_cs             init(419),
 108           zero_4bcs           init(739),
 109           blank_cs            init(472),
 110           pic_test            init(278),
 111           zero_mac(0:1)       init(308,307),
 112           call_ext_out        init(234)) fixed bin(15) int static;
 113 
 114 dcl (     short_work_space    init(28),
 115           medium_work_space   init(44),
 116           long_work_space     init(158)) fixed bin int static options(constant);
 117 
 118 dcl (     decimal_op          init(175),
 119           multi_decimal_op    init(176),
 120           complex_decimal_op  init(182),
 121           complex_binary_op   init(193)) fixed bin int static;
 122 
 123 dcl (     lte                 init("10000"b),     /* load table entry */
 124           insm                init("00001"b),     /* insert table entry 1 multiple */
 125           mfls                init("00110"b),     /* move with floating sign insertion */
 126           enf                 init("00010"b),     /* end floating suppression */
 127           mvc                 init("01101"b),     /* move source character */
 128           insb                init("01000"b),     /* insert blank on suppress */
 129           mvzb                init("00100"b),     /* move with zero suppression and blank replacement */
 130           mvza                init("00101"b),     /* move with zero suppression and asterisk replacement */
 131           mflc                init("00111"b)      /* move with floating currency symbol insertion */
 132                               ) bit(5) aligned int static;
 133 
 134 dcl (     integer_header      init("100000011000100000000010010"b),   /* (lte 3),(blank),(insm 2) */
 135           scaled_header       init("100000011000100000000010001"b)    /* (lte 3),(blank),(insm 1) */
 136                               ) bit(27) int static;
 137 
 138 dcl (     mvc_1               init("011010001"b),
 139           blank_on_zero       init("000110100"b),
 140           ses_off             init("000110000"b),
 141           ses_on              init("000111000"b),
 142           ses_on_bz           init("000111100"b),
 143           insb_5              init("011000101"b),
 144           enf_sign            init("000100000"b),
 145           enf_curr            init("000101000"b),
 146           enf_sign_bz         init("000100100"b),
 147           enf_curr_bz         init("000101100"b),
 148           insp_3              init("010110011"b),
 149           insn_4              init("010100100"b),
 150           insa_0              init("010010000"b),
 151           insb_0              init("010000000"b),
 152           insb_7              init("010000111"b),
 153           insb_8              init("010001000"b)) bit(9) int static aligned options(constant);
 154 
 155 dcl       blk_on_zero         char(1) aligned based(addr(blank_on_zero));
 156 
 157 dcl (     lte_3_blank         init("100000011000100000"b),
 158           lte_4_blank         init("100000100000100000"b)) bit(18) aligned int static;
 159 
 160 dcl (     insn_cr             init("010100000001100011010100000001110010"b),
 161           insn_db             init("010100000001100100010100000001100010"b)
 162                               ) bit(36) aligned int static;
 163 
 164 dcl       1 edit_sequence aligned,
 165           2 micro_op(68) structure unal,
 166             3 op_code bit(5) unal,
 167             3 data bit(4) unal;
 168 
 169 dcl       1 edit_seq based(addr(edit_sequence)) aligned,
 170           2 header bit(27) unal,
 171           2 pad bit(9) unal;
 172 
 173 dcl       char_image char(nchars) based(addr(edit_sequence)) aligned;
 174 
 175 %include pl1_descriptor_type_fcn;
 176 %include cg_reference;
 177 %include symbol;
 178 %include token;
 179 %include operator;
 180 %include list;
 181 %include temporary;
 182 %include data_types;
 183 %include nodes;
 184 %include op_codes;
 185 %include cgsystem;
 186 %include boundary;
 187 %include declare_type;
 188 %include label;
 189 %include mask;
 190 
 191 convert_arithmetic: entry(left,right,check_size,always_round);
 192 
 193           p1, arg(1) = left;
 194           p2, arg(2) = right;
 195           right = null;
 196 
 197           call state_man$flush_ref(p1);
 198 
 199 /* Initialize by filling in arrays */
 200 
 201           do i = 1 to 2;
 202           sym(i) = arg(i) -> reference.symbol;
 203           type(i) = arg(i) -> reference.data_type;
 204           prec(i) = sym(i) -> symbol.c_dcl_size;
 205           scale(i) = sym(i) -> symbol.scale;
 206           end;
 207 
 208           if p1 -> reference.temp_ref then p1 -> reference.value_in.storage = "1"b;
 209 
 210 /* See if we can generate inline sequence */
 211 
 212           if ^ check_size
 213           then do;
 214                if type(1) <= real_fix_bin_2
 215                then if scale(1) = 0
 216                then if p1 -> reference.aligned_for_store_ref
 217                then if abs(scale(2)) <= 31
 218                then if type(2) = real_fix_dec | type(2) = real_flt_dec
 219                then do;
 220                     if type(2) = real_flt_dec | scale(2) ^= 0
 221                     then do;
 222                          q = get_temp(11*type(1));
 223                          call expmac$two_eis((move_numeric),q,p2);
 224                          end;
 225                     else q = p2;
 226                     call expmac$two_eis((dtb(type(1))),p1,q);
 227                     return;
 228                     end;
 229 
 230                if type(2) <= real_fix_bin_2
 231                then if scale(2) = 0
 232                then if abs(scale(1)) <= 31
 233                then do;
 234 
 235                     if type(1) = real_fix_dec
 236                     then if scale(1) = 0
 237                          then do;
 238                               q = p1;
 239                               call issue_btd;
 240                               return;
 241                               end;
 242                          else do;
 243                               q = get_temp(11*type(2));
 244                               call issue_btd;
 245                               macro = move_numeric;
 246                               if always_round
 247                                    then macro = macro + 1;
 248                               call expmac$two_eis(macro,p1,q);
 249                               return;
 250                               end;
 251 
 252                     if type(1) = real_flt_dec
 253                     then do;
 254 
 255                          /* float decimal -- we pretend that it is fixed decimal, and then
 256                                              we append an exponent */
 257 
 258                          q = p1;
 259                          length_hold = p1 -> reference.c_length;
 260 
 261                          if sym(1) -> symbol.unaligned
 262                          then p1 -> reference.c_length = length_hold - 2;
 263                          else p1 -> reference.c_length = length_hold - 1;
 264 
 265                          p1 -> reference.data_type = real_fix_dec;
 266                          if ^ p1 -> reference.shared
 267                               then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
 268                          call issue_btd;
 269                          p1 -> reference.c_length = length_hold;
 270                          p1 -> reference.data_type = real_flt_dec;
 271 
 272                          q = get_reference();
 273                          q -> reference.symbol = sym(1);
 274                          q -> reference.qualifier = p1;
 275                          q -> reference.c_offset = prec(1) + 1;
 276                          q -> reference.data_type = char_string;
 277                          q -> reference.defined_ref = "1"b;
 278 
 279                          if sym(1) -> symbol.unaligned
 280                          then do;
 281                                    q -> reference.units = digit_;
 282                                    q -> reference.c_length = 2;
 283                                    macro = zero_4bcs;
 284                               end;
 285                          else do;
 286                                    q -> reference.units = character_;
 287                                    q -> reference.c_length = 1;
 288                                    macro = zero_cs;
 289                               end;
 290 
 291                          call expmac$one_eis(macro,q);
 292 
 293                          return;
 294                          end;
 295 
 296                     if type(1) = char_string
 297                     then do;
 298 
 299                          /* We must first convert to fixed decimal and then to character string */
 300 
 301                          prec(2) = fixed(ceil(float(prec(2),23)/3.32) + 1,17);
 302                          q = get_temp(prec(2));
 303                          call issue_btd;
 304                          type(2) = real_fix_dec;
 305                          arg(2), p2 = q;
 306                          sym(2) = q -> reference.symbol;
 307                          end;
 308                     end;
 309 
 310                if type(1) = char_string
 311                then if type(2) = real_fix_dec
 312                then if prec(2) >= scale(2)
 313                then if scale(2) >= 0
 314                then do;
 315                     iscan = 4;
 316 
 317                     if scale(2) = 0
 318                     then do;
 319 
 320                          /* decimal integer -- (lte 3),(blank),(insm 2),(mfls p-1),(enf),(mvc 1) */
 321 
 322                          edit_seq.header = integer_header;
 323                          if prec(2) > 1
 324                               then call fill_seq((mfls),prec(2) - 1);
 325                          string(micro_op(iscan)) = enf;
 326                          string(micro_op(iscan+1)) = mvc_1;
 327                          nchars = iscan + 1;
 328                          end;
 329 
 330                     else do;
 331 
 332                          /* scaled decimal -- (lte 3),(blank),(insm 1),(mfls p-q-1),(enf),
 333                                               (mvc 1),(insb 7),(mvc q) */
 334 
 335                          edit_seq.header = scaled_header;
 336                          i = prec(2) - scale(2) - 1;
 337                          if i > 0
 338                               then call fill_seq((mfls),i);
 339                          string(micro_op(iscan)) = enf;
 340                          if i < 0
 341                               then string(micro_op(iscan+1)) = insb_8;
 342                               else string(micro_op(iscan+1)) = mvc_1;
 343                          string(micro_op(iscan+2)) = insb_7;
 344                          iscan = iscan + 3;
 345                          call fill_seq((mvc),scale(2));
 346                          nchars = iscan - 1;
 347                          end;
 348 
 349                     tprec = prec(2) + 3;
 350 
 351                     varying_target = p1 -> reference.varying_ref & prec(1) >= tprec;
 352                     if varying_target
 353                     then do;
 354                          call assign_op$length_of_varying(p1,generate_constant$real_fix_bin_1(tprec));
 355                          p1 -> reference.c_length = tprec;
 356                          end;
 357                     else if prec(1) ^= tprec
 358                          then right, arg(1) = get_str_temp(tprec);
 359                          else call pad_ref(p1);
 360 
 361                     call issue_mvne;
 362 
 363                     if varying_target then p1 -> reference.c_length = prec(1);
 364 
 365                     return;
 366                     end;
 367                end;
 368 
 369 /* We cannot generate an inline sequence, so we generate an operator call */
 370 
 371           if arg(1) -> reference.temp_ref
 372                then arg(1) -> reference.ref_count = arg(1) -> reference.ref_count + 1;
 373 
 374           if sym(1) -> symbol.packed
 375            & (sym(1) -> symbol.bit | sym(1) -> symbol.char)
 376                then call pad_ref(p1);
 377 
 378 
 379           do i = 2 to 1 by -1;
 380 
 381           /* Protect length exprs + string temps from being prematurely released */
 382 
 383           if ^ arg(i) -> reference.shared
 384           then do;
 385                n = arg(i) -> reference.ref_count;
 386                check = n = 1;
 387                arg(i) -> reference.ref_count = n + 1;
 388                end;
 389           else check = "0"b;
 390 
 391           /* load and lock pointer register with address of the operand */
 392 
 393           call base_man$load_var_and_lock(2,arg(i),i + 2);
 394 
 395           /* free unnecessary temps */
 396 
 397           if check then call need_temp(arg(i),"11"b);
 398 
 399           /* load a or q with length or scale and precision of operand */
 400 
 401           if type(i) < char_string
 402           then do;
 403                word = prec(i);
 404                if scale(i) ^= 0
 405                     then word = word + 262144*scale(i);
 406                q = generate_constant$real_fix_bin_1(word);
 407                call aq_man$load_var(q,i);
 408                end;
 409           else call load_size$a_or_q(arg(i),i);
 410 
 411           if i = 2
 412                then call aq_man$lock(null,2);
 413 
 414           /* load type into an index register */
 415 
 416           dtype (i) = pl1_descriptor_type (gen_attr (sym (i), arg (i)), sym (i) -> symbol.c_dcl_size);
 417 
 418           word = 2 * dtype(i) + fixed(sym(i) -> symbol.packed,1);
 419 
 420           call xr_man$load_const(word,i+5);
 421           if i = 2
 422                then call xr_man$super_lock(7);
 423 
 424           end;
 425 
 426 
 427           /* get a pointer to a work_space
 428                     28 words for 9-bit decimal operands
 429                     44 words for 4-bit decimal operands
 430                     156 words for strings                   */
 431 
 432           if max(type(1),type(2)) < char_string
 433                then if sym(1) -> symbol.unaligned & sym(1) -> symbol.decimal
 434                      | sym(2) -> symbol.unaligned & sym(2) -> symbol.decimal
 435                          then n = medium_work_space;
 436                          else n = short_work_space;
 437                else n = long_work_space;
 438           q = c_a(n,12);
 439           q -> reference.ref_count = 2;
 440           call base_man$load_var(2,q,5);
 441 
 442           /* Unlock the registers */
 443 
 444           call state_man$unlock;
 445 
 446           /* Decide which macro to use */
 447 
 448           i = 2;
 449           if n = short_work_space
 450           then if sym(1) -> symbol.real
 451                then if sym(2) -> symbol.real
 452                     then i = 0;
 453 
 454           macro = conv_mac + i;
 455 
 456           if always_round
 457           then macro = macro + 1;
 458           else if sym(1) -> symbol.float
 459                then macro = macro + 1;
 460                else if sym(1) -> symbol.char
 461                     then if sym(2) -> symbol.float
 462                          then macro = macro + 1;
 463 
 464           /* Flush machine state and issue the macro */
 465 
 466           call state_man$flush;
 467 
 468           call expmac$zero(macro);
 469 
 470 
 471           /* Lower reference counts originally raised and return */
 472 
 473           do i = 1 to 2;
 474           if ^ arg(i) -> reference.shared then call adjust_ref_count(arg(i),-1);
 475           end;
 476 
 477           call adjust_ref_count(q,-1);
 478           return;
 479 
 480 
 481 /* Compiles pack or unpack operator */
 482 
 483 picture_op:         entry(node_pt);
 484 
 485           p = node_pt;
 486 
 487           p1 = p -> operand(1);
 488 
 489           call state_man$flush_ref(p1);
 490 
 491           if p1 -> reference.temp_ref then p1 -> reference.value_in.storage = "1"b;
 492 
 493           p2 = p -> operand(2);
 494 
 495           if p2 -> node.type = operator_node
 496                then p2 = p2 -> operand(1);
 497 
 498           /* get picture constant */
 499 
 500           iop = fixed(p -> operator.op_code = unpack,1) + 1;
 501           arg(1) = p1;
 502           arg(2) = p2;
 503           q = arg(iop) -> reference.symbol -> symbol.general;
 504           if q -> reference.data_type = 0
 505                then q = prepare_operand(q,1,atomic);
 506 
 507           /* Try to process inline.  If we cannot, then generate operator call */
 508 
 509           if ^ inline_picture()
 510           then do;
 511                if p1 -> reference.temp_ref
 512                     then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
 513                arg(2) = q;
 514                arg(3) = p2;
 515 
 516                adjust = "0"b;
 517                do i = 1 to 3;
 518                     if arg(i) -> reference.temp_ref & ^ arg(i) -> reference.aggregate
 519                     then do;
 520                          arg(i) -> reference.ref_count = arg(i) -> reference.ref_count + 1;
 521                          substr(adjust,i,1) = "1"b;
 522                          end;
 523                     call base_man$load_var_and_lock(2,arg(i),i + 2);
 524                     end;
 525 
 526                call state_man$unlock;
 527                call state_man$flush;
 528 
 529                call expmac$zero((pic_mac(iop)));
 530 
 531 
 532                if adjust
 533                then do i = 1 to 3;
 534                     if substr(adjust,i,1)
 535                          then call adjust_ref_count(arg(i),-1);
 536                     end;
 537                end;
 538 
 539           return;
 540 
 541 
 542 /*        *************************************************
 543 
 544 gen_procedure_call: entry(node_pt,ref,code);
 545 
 546           k = code;
 547 
 548           lp = node_pt;
 549           n_args = 2 * lp -> operator.number;
 550 
 551           if ref(1) -> reference.temp_ref
 552           then do;
 553                q = ref(1) -> reference.length;
 554                if q ^= null
 555                then do;
 556                     call long_op$extend_stack(ref(1),alloc_char_temp - char_string + ref(1) -> reference.data_type);
 557                     ref(1) -> reference.ref_count = ref(1) -> reference.ref_count + 1;
 558                     call store$save_string_temp(ref(1));
 559                     increment = "1"b;
 560                     end;
 561                else if ref(1) -> reference.shared
 562                     then ref(1) = copy_temp(ref(1));
 563 
 564                end;
 565 
 566           do i = 1 to lp -> operator.number;
 567                j = 2 * i - 1;
 568                arg(j) = ref(i);
 569                arg(j+1) = get_desc(arg(j));
 570                end;
 571 
 572           comparison = "0"b;
 573           lp = ref(1);
 574           goto l2;
 575 
 576           ************************************************* */
 577 
 578 gen_arithmetic_call: entry(node_pt,ref,atom);
 579 
 580 dcl       node_pt ptr,                  /* points at operator node */
 581           ref(3) ptr,                   /* ref nodes for operands */
 582           atom(3) bit(1) aligned;       /* "1"b if operand(i) atomic */
 583 
 584           s = ref(2) -> reference.symbol;
 585           if s -> symbol.decimal
 586           then do;
 587                k1 = complex_decimal_op;
 588                k2 = decimal_op;
 589                end;
 590           else k1, k2 = complex_binary_op;
 591 
 592           c, comparison = "0"b;
 593           lp = node_pt;
 594 
 595           call prepare_operands;
 596 
 597           arg(2) = ref(1);
 598           if arg(2) ^= null
 599           then do;
 600                c = ref(1) -> reference.symbol -> symbol.complex;
 601                arg(3) = get_desc(arg(2));
 602                end;
 603           else do;
 604                comparison = "1"b;
 605                arg(2), arg(3) = cg_stat$double_temp;
 606                end;
 607 
 608           if comparison then j = 0; else j = fixed(substr(lp -> operator.op_code,6,4),4);
 609           arg(1) = generate_constant$real_fix_bin_1(j);
 610 
 611           arg(4) = ref(2);
 612           arg(5) = get_desc(arg(4));
 613 
 614           if lp -> operator.op_code = negate then n_args = 5;
 615           else do;
 616                n_args = 7;
 617                arg(6) = ref(3);
 618                arg(7) = get_desc(arg(6));
 619                c = c | arg(6) -> reference.symbol -> symbol.complex;
 620                end;
 621 
 622           if c | s -> symbol.complex then k = k1; else k = k2;
 623 
 624           lp = ref(1);
 625           goto l2;
 626 
 627 gen_arithmetic_builtin: entry(node_pt,ref,atom,code);
 628 
 629 dcl       code fixed bin;
 630 
 631           lp = node_pt;
 632           s = ref(1) -> reference.symbol;
 633           if s -> symbol.decimal | ref(2) -> reference.symbol -> symbol.decimal
 634           then do;
 635                if lp -> operator.number > 3 then k = multi_decimal_op;
 636                else if ref(2) -> reference.symbol -> symbol.complex
 637                      | ref(1) -> reference.symbol -> symbol.complex
 638                     then k = complex_decimal_op;
 639                     else k = decimal_op;
 640                end;
 641           else k = complex_binary_op;
 642 
 643           call prepare_operands;
 644 
 645           arg(1) = generate_constant$real_fix_bin_1(code);
 646 
 647           n_args = 2 * lp -> operator.number + 1;
 648 
 649           do i = 1 to lp -> operator.number-1;
 650                j = 2 * i;
 651                arg(j) = ref(i);
 652                arg(j+1) = get_desc(arg(j));
 653                end;
 654 
 655           j = 2 * i;
 656           if lp -> operator.op_code = round_fun then arg(j), arg(j+1) = ref(i);
 657           else do;
 658                arg(j) = ref(i);
 659                arg(j+1) = get_desc(arg(j));
 660                end;
 661 
 662           lp = ref(1);
 663           comparison = "0"b;
 664 
 665 l2:       if lp ^= null
 666           then if lp -> reference.temp_ref
 667                then lp -> reference.value_in.storage = "1"b;
 668 
 669           arg_pt = c_a(2*(n_args+1),12);          /* get space for arglist in stack */
 670 
 671           if increment then arg_pt -> reference.ref_count = arg_pt -> reference.ref_count + 1;
 672 
 673           last_freed = arg_pt -> reference.qualifier -> temporary.last_freed;
 674 
 675           arg_pos = arg_pt -> reference.qualifier -> temporary.location;
 676           ap = c_a(0,4);                /* address sp|0 */
 677 
 678           if arg_pos + 2*n_args + 1 >= 16384
 679           then do;
 680                call xr_man$load_const(arg_pos,1);           /* xr1 is safe because it's not in pool */
 681                ap -> reference.address.tag = "001001"b;
 682                arg_pos = 0;
 683                string(arg_pt -> reference.address) = string(ap -> reference.address);
 684                arg_pt -> reference.perm_address = "1"b;
 685                end;
 686 
 687           /* put ptrs to arguments into arg list.  If arg is a temporary, we will
 688              adjust the reference count up by 1 so that the temporary remains allocated
 689              until we return from the call.  If we did not do this and some of the
 690              registers had to be saved in storage, one of the arguments might get altered */
 691 
 692           adjust = "0"b;
 693           do i = 1 to n_args;
 694                p = arg(i);
 695                if p = null then goto l3;
 696 
 697                if p -> reference.temp_ref
 698                then do;
 699                     p -> reference.ref_count = p -> reference.ref_count + 1;
 700                     substr(adjust,i,1) = "1"b;
 701                     end;
 702 
 703                ap -> address.offset = bit(fixed(arg_pos + 2*i,15),15);
 704                call store_bit_address(ap,p,last_freed);
 705 
 706                do j = i + 1 to n_args;
 707                     if p = arg(j)
 708                     then do;
 709                          ap -> address.offset = bit(fixed(arg_pos + 2*j,15),15);
 710                          call store_bit_address(ap,p,last_freed);
 711                          arg(j) = null;
 712                          end;
 713                     end;
 714 
 715 l3:            end;
 716 
 717           buff(1) = arg_pt;
 718           buff(2) = c_a(n_args*2048,2);
 719           buff(3) = reserve$declare_lib(k);
 720 
 721           ap = buff(3) -> reference.symbol;
 722           if ^ ap -> symbol.allocated
 723           then do;
 724                ap -> symbol.location = compile_link(ap -> symbol.token -> token.string,"0"b,0);
 725                ap -> symbol.allocated = "1"b;
 726 
 727                q = create_list(2);
 728                q -> element(2) = ap;
 729                q -> element(1) = cg_stat$ext_proc_list;
 730                cg_stat$ext_proc_list = q;
 731                end;
 732 
 733           call expmac$many((prepare_call),addr(buff),2);
 734           call base_man$load_var(2,buff(3),1);
 735           call state_man$flush;
 736           call expmac$zero((call_ext_out));
 737 
 738 
 739           if comparison then call expmac((ldfx1),cg_stat$double_temp);
 740 
 741           if adjust = "0"b then return;
 742 
 743           do i = 1 to n_args;
 744                if substr(adjust,i,1)
 745                then do;
 746                     p = arg(i);
 747                     call adjust_ref_count(p,-1);
 748                     end;
 749                end;
 750 
 751           return;
 752 
 753 
 754 
 755 inline_picture:     proc() returns(bit(1) aligned);
 756 
 757 
 758 /* Attempts to generate inline sequence for picture operations */
 759 
 760 dcl       (lab,pp) ptr;
 761 dcl       (picture_pos,type,prec,scale,scalefactor,picture_length,nrands,source_length) fixed bin;
 762 dcl       (pc,sc,drift,zero_sup_char) char(1) aligned;
 763 dcl       table_entries char(8) init(" *+-$,.0") int static;
 764 dcl       (current_micro_op,micro_op_code) bit(5) aligned;
 765 dcl       micro_inst bit(9) aligned;
 766 
 767 dcl       zero_suppression    bit(1) aligned;     /* "1"b -- machine is doing zero suppression (ES is OFF) */
 768 dcl       have_drift          bit(1) aligned;     /* "1"b -- a drifting field has been encountered */
 769 dcl       have_suppression    bit(1) aligned;     /* "1"b -- suppression characters or a drifting field have been encountered */
 770 dcl       insertion_on_zero   bit(1) aligned;     /* "1"b -- characters have been inserted which should be blanked
 771                                                              if the number is 0 */
 772 dcl       test_zero           bit(1) aligned;     /* zero_suppression & insertion_on_zero */
 773 
 774 %include picture_image;
 775 %include picture_types;
 776 
 777           if iop = 2
 778           then return("0"b);            /* unpack or encode */
 779           else do;
 780 
 781                /* pack or edit */
 782 
 783                call open_picture;
 784 
 785                if type = char_picture
 786                then if verify(substr(pp -> picture_image.chars,1,picture_length),"x") = 0
 787                     then do;
 788                          call pad_ref(p1);
 789                          call expmac$two_eis((move_chars),p1,p2);
 790                          return("1"b);
 791                          end;
 792                     else return("0"b);
 793 
 794                if type > real_fixed_picture then return("0"b);
 795 
 796                if abs(scale) > 31 then return("0"b);
 797 
 798                /* We have a picture worth trying , so we go through a loop looking at
 799                   each picture character */
 800 
 801                have_drift, have_suppression, insertion_on_zero, current_micro_op = "0"b;
 802                zero_suppression = "1"b;
 803                drift, zero_sup_char = " ";
 804                iscan = 1;
 805 
 806 
 807                do picture_pos = 1 to picture_length;
 808                     pc = substr(pp -> picture_image.chars,picture_pos,1);
 809                     go to case(index("9y*z$s+-cd/.,bv",pc));
 810 
 811                     /* 9 */
 812 
 813 case(1):            call force_significance;
 814                     call put((mvc));
 815                     go to step;
 816 
 817                     /* y */
 818 
 819 case(2):            if have_drift
 820                     then if zero_suppression
 821                          then return("0"b);
 822 
 823                     if picture_pos > 1
 824                          then call issue((ses_off));
 825                     call put((mvzb));
 826                     if substr(pp -> picture_image.chars,picture_pos + 1,1) ^= "y"
 827                          then call issue((ses_on));
 828                     zero_suppression = "0"b;
 829                     go to step;
 830 
 831                     /* * */
 832 
 833 case(3):            zero_sup_char = "*";
 834                     insertion_on_zero = "1"b;
 835                     call start_suppression;
 836                     call put((mvza));
 837                     go to step;
 838 
 839                     /* z */
 840 
 841 case(4):            zero_sup_char = " ";
 842                     call start_suppression;
 843                     call put((mvzb));
 844                     go to step;
 845 
 846                     /* $ */
 847 
 848 case(5):            if pp -> picture_image.drift_character ^= "$"
 849                     then call non_drifting;
 850 
 851                     else do;
 852                          if ^ have_drift
 853                          then do;
 854                               drift = "$";
 855                               insertion_on_zero,
 856                               have_drift = "1"b;
 857                               call start_suppression;
 858                               end;
 859                          else call put((mflc));
 860                          end;
 861 
 862                     go to step;
 863 
 864                     /* s */
 865 
 866 case(6):            if pp -> picture_image.drift_character ^= "s"
 867                          then call non_drifting;
 868                          else call drifting_sign;
 869 
 870                     /* + */
 871 
 872 case(7):            if pp -> picture_image.drift_character ^= "+"
 873                     then do;
 874                          call issue((insp_3));
 875                          insertion_on_zero = "1"b;
 876                          go to step;
 877                          end;
 878 
 879                     call drifting_sign;
 880 
 881                     /* - */
 882 
 883 case(8):            if pp -> picture_image.drift_character ^= "-"
 884                     then do;
 885                          call issue((insn_4));
 886                          go to step;
 887                          end;
 888 
 889                     call drifting_sign;
 890 
 891                     /* c */
 892 
 893 case(9):            call issue_4((insn_cr));
 894                     picture_pos = picture_pos + 1;
 895                     go to step;
 896 
 897                     /* d */
 898 
 899 case(10):           call issue_4((insn_db));
 900                     picture_pos = picture_pos + 1;
 901                     go to step;
 902 
 903                     /* / . , */
 904 
 905 case(11):
 906 case(12):
 907 case(13):
 908                     insertion_on_zero = "1"b;
 909                     call insert_pun;
 910 
 911                     /* b */
 912 
 913 case(14):           pc = " ";
 914                     call insert_pun;
 915 
 916                     /* v */
 917 
 918 case(15):           if index(substr(pp -> picture_image.chars,picture_pos+1),"9") = 0
 919                     then call force_significance_bz;
 920                     else if have_drift & index(substr(pp -> picture_image.chars,picture_pos+1),"y") ^= 0
 921                          then return("0"b);
 922                          else call force_significance;
 923 
 924 step:               if iscan > 64 then return("0"b);
 925                     end;
 926 
 927                test_zero = zero_suppression & insertion_on_zero;
 928                if test_zero & have_drift
 929                     then call force_significance_bz;
 930 
 931                call pad_ref(p1);
 932 
 933                call force;
 934                nchars = iscan - 1;
 935 
 936                if test_zero & ^ have_drift
 937                then do;
 938                     nchars = nchars + 1;
 939                     char_image = blk_on_zero || substr(char_image,1,nchars-1);
 940                     end;
 941 
 942                call issue_mvne;
 943 
 944                end;
 945 
 946           return("1"b);
 947 
 948 
 949 start_suppression:  proc;
 950 
 951           if ^ have_suppression
 952           then do;
 953                if ^ zero_suppression
 954                then do;
 955                     call issue((ses_off));
 956                     zero_suppression = "1"b;
 957                     end;
 958 
 959                have_suppression = "1"b;
 960                end;
 961 
 962           end;
 963 
 964 
 965 force_significance: proc;
 966 
 967           if zero_suppression
 968           then do;
 969                if have_drift
 970                then do;
 971                     if drift = "$"
 972                          then micro_inst = enf_curr;
 973                          else micro_inst = enf_sign;
 974                     call issue(micro_inst);
 975                     have_drift = "0"b;
 976                     end;
 977                else call issue(ses_on);
 978 
 979                zero_suppression = "0"b;
 980                end;
 981 
 982           end;
 983 
 984 
 985 force_significance_bz: proc;
 986 
 987           /* same as force_significance except we blank on zero and leave have_drift on */
 988 
 989           if zero_suppression
 990           then do;
 991                if have_drift
 992                then do;
 993                     if drift = "$"
 994                          then micro_inst = enf_curr_bz;
 995                          else micro_inst = enf_sign_bz;
 996                     call issue(micro_inst);
 997                     end;
 998                else call issue(ses_on_bz);
 999 
1000                zero_suppression = "0"b;
1001                end;
1002 
1003           end;
1004 
1005 
1006 non_drifting:       proc;
1007 
1008           if have_drift & zero_suppression
1009           then do;
1010                call force_significance;
1011                zero_suppression = "1"b; /* remember that zero_suppression was on */
1012                end;
1013 
1014           if picture_pos > 1
1015                then call issue((ses_off));        /* for safety, we must have ES OFF */
1016 
1017           if have_suppression & zero_suppression
1018           then if pc = "$"
1019                then micro_inst = enf_curr_bz;
1020                else micro_inst = enf_sign_bz;
1021           else if pc = "$"
1022                then micro_inst = enf_curr;
1023                else micro_inst = enf_sign;
1024 
1025           call issue(micro_inst);
1026 
1027           zero_suppression = "0"b;
1028 
1029           insertion_on_zero = "1"b;
1030           go to step;
1031 
1032           end;
1033 
1034 
1035 drifting_sign:      proc;
1036 
1037 dcl       table_change bit(18) aligned;
1038 
1039           if ^ have_drift
1040           then do;
1041                call start_suppression;
1042                insertion_on_zero,
1043                have_drift = "1"b;
1044                drift = pc;
1045                if drift ^= "s"
1046                then do;
1047                     if drift = "-"
1048                          then table_change = lte_3_blank;
1049                          else table_change = lte_4_blank;
1050                     call issue_2(table_change);
1051                     end;
1052                end;
1053 
1054           else call put((mfls));
1055           go to step;
1056 
1057           end;
1058 
1059 
1060 
1061 insert_pun:         proc;
1062 
1063           if zero_suppression
1064           then if ^ have_suppression
1065                then do;
1066                     call issue((ses_on));
1067                     zero_suppression = "0"b;
1068                     end;
1069 
1070           if zero_sup_char = "*"
1071                then micro_inst = insa_0;
1072                else micro_inst = insb_0;
1073 
1074           if pc = "/"
1075           then do;
1076                call issue(micro_inst);
1077                call issue(unspec(pc));
1078                end;
1079 
1080           else do;
1081                substr(micro_inst,6,4) = bit(fixed(index(table_entries,pc),4),4);
1082                call issue(micro_inst);
1083                end;
1084 
1085           go to step;
1086 
1087           end;
1088 
1089 
1090 
1091 put:      proc(micro_op_code);
1092 
1093 dcl       micro_op_code bit(5) aligned;
1094 
1095           if micro_op_code ^= current_micro_op
1096                then call force;
1097 
1098           current_micro_op = micro_op_code;
1099           nrands = nrands + 1;
1100 
1101           end;
1102 
1103 
1104 
1105 force:    proc;
1106 
1107           if current_micro_op
1108                then call fill_seq((current_micro_op),nrands);
1109 
1110           current_micro_op = "0"b;
1111           nrands = 0;
1112 
1113           end;
1114 
1115 
1116 
1117 issue:    proc(micro_inst);
1118 
1119 dcl       micro_inst bit(9) aligned;
1120 
1121           call force;
1122 
1123           string(micro_op(iscan)) = micro_inst;
1124           iscan = iscan + 1;
1125 
1126           end;
1127 
1128 
1129 
1130 issue_4:  proc(bit36);
1131 
1132 dcl       bit36 bit(36) aligned;
1133 dcl       (i,n) fixed bin;
1134 dcl       p ptr;
1135 
1136           n = 4;
1137           p = addr(bit36);
1138           go to join;
1139 
1140 issue_2:  entry(bit18);
1141 
1142 dcl       bit18 bit(18) aligned;
1143 
1144 dcl       1 array_st based aligned,
1145           2 micro_array(4) bit(9) unal;
1146 
1147           n = 2;
1148           p = addr(bit18);
1149 
1150 join:     call force;
1151 
1152           do i = 1 to n;
1153                string(micro_op(iscan)) = p -> micro_array(i);
1154                iscan = iscan + 1;
1155                end;
1156 
1157           end;
1158 
1159 
1160 
1161 open_picture:       proc;
1162 
1163           pp = q -> reference.symbol -> symbol.initial;
1164 
1165           type = pp -> picture_image.type;
1166           prec = pp -> picture_image.prec;
1167           scale = pp -> picture_image.scale;
1168           picture_length = pp -> picture_image.piclength;
1169           source_length = pp -> picture_image.varlength;
1170           scalefactor = pp -> picture_image.scalefactor;
1171 
1172           end;
1173 
1174 
1175 end;
1176 
1177 
1178 
1179 prepare_operands: proc;
1180 
1181 dcl            i fixed bin;
1182 
1183                do i = 2 to lp -> operator.number;
1184                     if ^ atom(i) then ref(i) = compile_exp$save_exp((lp -> operand(i)));
1185                     end;
1186 
1187                if ref(1) = null then return;
1188 
1189                if ^ ref(1) -> reference.allocate
1190                then do;
1191                     lp -> operand(1), ref(1) = copy_temp(ref(1));
1192                     ref(1) -> reference.ref_count = 2;
1193                     end;
1194                else if ^ cg_stat$save_exp_called
1195                     then if ref(1) -> reference.temp_ref
1196                          then ref(1) -> reference.ref_count = ref(1) -> reference.ref_count + 1;
1197 
1198                end;
1199 
1200 get_temp: proc(prec) returns(ptr);
1201 
1202 dcl       (length,type,prec) fixed bin;
1203 dcl       p ptr;
1204 dcl       long bit(1) aligned;
1205 
1206           /* Entry point to get a fixed decimal temporary */
1207 
1208           length = prec + 1;
1209           type = real_fix_dec;
1210           long = "0"b;
1211           go to join;
1212 
1213           /* Entry point to get a character string temporary */
1214 
1215 get_str_temp:       entry(prec) returns(ptr);
1216 
1217           length = prec;
1218           long = length > max_short_size(char_string);
1219           type = char_string;
1220 
1221 join:     p = get_reference();
1222           p -> reference.data_type = type;
1223           p -> reference.c_length = length;
1224           p -> reference.long_ref = long;
1225           p -> reference.temp_ref, p -> reference.allocate, p -> reference.value_in.storage = "1"b;
1226           call stack_temp$assign_block(p,divide(length + chars_per_word - 1,chars_per_word,17,0));
1227 
1228           return(p);
1229           end;
1230 
1231 
1232 issue_btd:          proc;
1233 
1234           if ^ p2 -> reference.aligned_ref
1235                then p2 = compile_exp$save(p2);
1236 
1237           call expmac$two_eis((btd(type(2))),q,p2);
1238 
1239           end;
1240 
1241 
1242 issue_mvne:         proc;
1243 
1244           arg(3) = generate_constant$char_string(char_image,nchars);
1245 
1246           call expmac$many_eis((move_numeric_edit),addr(arg),3);
1247 
1248           end;
1249 
1250 
1251 pad_ref:  proc(pt);
1252 
1253           /* pad_ref is called with a bit string, character string, or a
1254              picture.  If the string is a short aligned string but does not
1255              fill an integral number of words, the last word is zeroed. */
1256 
1257 dcl       (p1,pt) ptr;
1258 
1259 dcl       size fixed bin(24);
1260 
1261           p1 = pt;
1262 
1263           if p1 -> reference.data_type = bit_string
1264                then size = p1 -> reference.c_length;
1265                else size = p1 -> reference.c_length * bits_per_char;
1266 
1267           if ^ p1 -> reference.long_ref
1268           then if ^ p1 -> reference.varying_ref
1269           then if p1 -> reference.aligned_for_store_ref
1270           then if mod(size,bits_per_word) ^= 0
1271           then do;
1272                if ^ p1 -> reference.shared
1273                     then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1274                call expmac((zero_mac(fixed(size > bits_per_word,1))),p1);
1275                end;
1276           end /* pad_ref */;
1277 
1278 
1279 
1280 fill_seq: proc(pop,pn);
1281 
1282 dcl       (mop,pop) bit(5) aligned;     /* micro-op */
1283 dcl       (n,pn) fixed bin;             /* number of chars being moved */
1284 
1285 dcl       (i,ninst) fixed bin;
1286 dcl       j fixed bin(4);
1287 
1288           n = pn;
1289           mop = pop;
1290 
1291           ninst = divide(n + 15,16,17,0);
1292 
1293           do i = 1 to ninst;
1294           string(micro_op(iscan)) = mop;
1295           if i = ninst
1296           then do;
1297                j = mod(n,16);
1298                if j ^= 0
1299                     then micro_op(iscan).data = bit(j,4);
1300                end;
1301           iscan = iscan + 1;
1302           end;
1303 
1304           end;
1305 
1306 
1307 get_desc:      proc(ref) returns(ptr);
1308 
1309 dcl            ref ptr;
1310 
1311 dcl            (p,q,r,s,arg(2)) ptr,
1312                (type,scale,desc_type) fixed bin,
1313                desc bit(36) int static aligned init("1"b);
1314 
1315                p = ref;
1316                s = p -> reference.symbol;
1317 
1318                substr(desc,8,1) = s -> symbol.packed;
1319 
1320                type = p -> reference.data_type;
1321 
1322                desc_type = pl1_descriptor_type (gen_attr (s, p), s -> symbol.c_dcl_size);
1323 
1324                substr(desc,2,6) = bit(fixed(desc_type,6),6);
1325 
1326                if type < char_string
1327                then do;
1328                          substr(desc,25,12) = bit(fixed(s -> symbol.c_dcl_size,12),12);
1329 
1330                          scale = s -> symbol.scale;
1331 
1332                          if scale < 0
1333                          then scale = scale + 1000000000000b;         /* 2's comp */
1334 
1335                          substr(desc,13,12) = bit(fixed(scale,12),12);
1336 
1337 l1:                      return(generate_constant(desc,1));
1338                     end;
1339 
1340                q = p -> reference.length;
1341                if q = null
1342                then do;
1343                     substr(desc,13,24) = bit(fixed(p -> reference.c_length,24),24);
1344                     goto l1;
1345                     end;
1346 
1347                substr(desc,13,24) = "0"b;
1348 
1349                if q -> node.type = operator_node
1350                     then r = q -> operand(1);
1351                     else r = q;
1352                if ^ r -> reference.shared
1353                     then r -> reference.ref_count = r -> reference.ref_count + 1;
1354 
1355                call compile_exp(q);
1356 
1357                arg(1) = c_a(1,12);
1358                arg(1) -> reference.ref_count = 2;
1359 
1360                arg(2) = generate_constant(desc,1);
1361                call expmac$many((make_desc_mac),addr(arg),2);
1362 
1363                return(arg(1));
1364                end;
1365 
1366 /* Generate the correct attribute string from both the symbol node and reference node */
1367 
1368 gen_attr:
1369           procedure (symptr, refptr) returns (bit (36) aligned);
1370 
1371 /* parameters */
1372 
1373 dcl       symptr ptr;
1374 dcl       refptr ptr;
1375 
1376 /* program */
1377 
1378           if ^ refptr -> reference.varying_ref & symptr -> symbol.varying
1379           then return (substr (string (symptr -> symbol.attributes), 1, 36) & ^(varying_mask));
1380 
1381           return (substr (string (symptr -> symbol.attributes), 1, 36));
1382 
1383           end /* gen_attr */;
1384 
1385           end;