1 /****^  ******************************************************
   2         *                                                    *
   3         * Copyright, (C) Honeywell Bull Inc., 1987           *
   4         *                                                    *
   5         * Copyright (c) 1972 by Massachusetts Institute of   *
   6         * Technology and Honeywell Information Systems, Inc. *
   7         *                                                    *
   8         ****************************************************** */
   9 
  10 
  11 /****^  HISTORY COMMENTS:
  12   1) change(87-04-15,RWaters), approve(87-04-15,MCR7639), audit(87-04-28,Huen),
  13      install(87-05-21,MR12.1-1033):
  14      Fixes bugs #1926,2145
  15   2) change(87-06-26,Huen), approve(87-06-26,MCR7712), audit(87-12-01,RWaters),
  16      install(87-12-01,MR12.2-1005):
  17      Fix bug2042
  18   3) change(88-01-29,RWaters), approve(88-01-29,MCR7724), audit(88-02-05,Huen),
  19      install(88-02-16,MR12.2-1024):
  20      Allow option(constant) variables as arguments to builtin functions.
  21   4) change(89-03-28,Huen), approve(89-03-28,MCR8077), audit(89-04-03,JRGray),
  22      install(89-04-24,MR12.3-1032):
  23      Fix bug 2193 - Display the existing error message (#127) when the first
  24      argument to hbound builtin is not an array value.
  25   5) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu),
  26      install(89-07-31,MR12.3-1066):
  27      Fix reference thru null pointer in action (33).
  28                                                    END HISTORY COMMENTS */
  29 
  30 /* format: style2,^indattr,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */
  31 builtin:
  32      proc (cur_block, statement_ptr, input_tree, subscripts, builtin_symbol, context) returns (ptr);
  33 
  34 /* Modified 770617 by PG to add clock, vclock, stacq
  35    Modified 780213 by RAB to fix 1707
  36    Modified 780329 by PCK to add stackframeptr, stackbaseptr, environmentptr, and codeptr builtins
  37    Modified 780412 by PG to fix 1723, and to fix unreported bugs in decat and unspec
  38    Modified 780807 by RAB to fix 1749
  39    Modified 780824 by PCK to fix 1701, 1766, and 1777
  40    Modified 780825 by RAB to fix 1780
  41    Modified Dec 1978 by David Spector to make addr arg non-set xref
  42    Modified 790416 by PCK to implement 4-bit decimal fix bugs 1826 and 1830
  43    Modified 790516 by RAB for reference.substr
  44    Modified 790606 by PG to add byte and rank
  45    Modified 791107 by BSG for index (reverse) etc.
  46    Modified: 26 Dec 1979 by PCK to implement by name assignment
  47    Modified 820726 by BIM for segno, wordno
  48    Modified 830909 by BIM never to have bif return unsigned.
  49                     assign_op gets CONFUSED.
  50    Modified 870727 by RW to fix phx16821 & phx16584, invalid substr ranges.
  51    Modified 870523 by SH to fix bug 2042 by displaying new error 390 if the
  52                     argument used in rank builtin is not a non_varying
  53                     character string of length 1.
  54    Modified 880129 by RW to fix bug 1994 and bug 2186.
  55    Modified 890302 by SH to display error 127 if the first argument to hbound
  56                    builtin is not an array value. (pl1_2193)
  57    Modified 890714 by RW to check for null pointer in action(33)
  58 */
  59 
  60           dcl      (cur_block, builtin_symbol, statement_ptr, subscripts, input_tree, tree) ptr;
  61 
  62           dcl      (
  63                    arg (128),
  64                    ref (128),
  65                    arg_symbol (128),
  66                    length,
  67                    offset,
  68                    p,
  69                    q,
  70                    r,
  71                    rlength,
  72                    s,
  73                    t,
  74                    off,
  75                    save_arg_one
  76                    ) ptr,
  77                    cur_length (2) ptr,
  78                    (agg_ref, dcl_length) ptr init (null),
  79                    (units, cunits) fixed bin (3),
  80                    error_number fixed bin (15),
  81                    constant fixed bin,
  82                    (arg_number, builtin_number, code, i, indicator, jump_index, m, reserved_number, rprecision, rscale,
  83                    temp_size) fixed bin (31),
  84                    (c_length, c_offset, coff, integer, number, substr_index, p1, p2, q1, q2, rcount) fixed bin (31),
  85                    integer_24 fixed bin (24),
  86                    based_type bit (36) based,
  87                    (desc_reqd, decimal_result, arith_size_ck, string_size_ck) bit (1) aligned init ("0"b),
  88                    pseudo_variable bit (1) aligned init ("0"b),
  89                    (full_attribute_set, not_flag) bit (1) aligned,
  90                    bit4 bit (4) aligned,
  91                    modified bit (1) aligned,
  92                    opcode bit (9) aligned,
  93                    constant_string_length fixed bin (21),
  94                    constant_char_string char (constant_string_length) based,
  95                    constant_bit_string bit (constant_string_length) based,
  96                    builtin_string char (8) aligned,
  97                    collating_sequence char (128) aligned internal static init ("^@^A^B^C^D^E^F^G^H
  98 ^K^L^M^N^O^P^Q^R^S^T^U^V^W^X^Y^Z^[^\^]^^^_ !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~^?");
  99 
 100           dcl      pl1_data$long_collating_sequence char (512) aligned ext static;
 101 
 102           dcl      pl1_stat_$use_old_area bit (1) aligned ext static,
 103                    pl1_stat_$check_ansi bit (1) aligned ext static,
 104                    pl1_stat_$eis_mode bit (1) aligned ext static,
 105                    pl1_stat_$root ptr ext static,
 106                    pl1_stat_$cur_statement ptr ext static;
 107 
 108           dcl      (addr, bit, divide, fixed, max, min, null, reverse, string, substr, unspec) builtin;
 109 
 110 /*
 111 abs                 13
 112 acos                54
 113 add                 14
 114 addr                33
 115 addrel              41
 116 after               55
 117 
 118 allocation          36
 119 asin                54
 120 atan                25
 121 atand               25
 122 atanh               25
 123 baseno              39
 124 segno               70
 125 
 126 baseptr             41
 127 before              56
 128 bin                 15
 129 binary              15
 130 bit                 18
 131 
 132 bool                23
 133 byte                68
 134 ceil                16
 135 char                18
 136 clock               62
 137 codeptr             63
 138 collate              1
 139 collate9            59
 140 
 141 complex             17
 142 conjg               50
 143 convert             46
 144 copy                 9
 145 cos                 25
 146 
 147 cosd                25
 148 cosh                25
 149 cplx                17
 150 currentsize         64
 151 date                31
 152 dec                 15
 153 
 154 decat               24
 155 decimal             18
 156 dim                 26
 157 divide              14
 158 dot                 45
 159 
 160 empty               28
 161 environmentptr      63
 162 erf                 25
 163 erfc                25
 164 exp                 25
 165 fixed                3
 166 
 167 float                2
 168 floor               16
 169 hbound              26
 170 high                 5
 171 high9               60
 172 
 173 imag                19
 174 index                6
 175 lbound              26
 176 length               7
 177 lineno              30
 178 
 179 log                 25
 180 log10               25
 181 log2                25
 182 low                  8
 183 ltrim               57
 184 
 185 max                 20
 186 maxlength           65
 187 min                 20
 188 mod                 21
 189 multiply            14
 190 null                29
 191 
 192 nullo               44
 193 onchar              51
 194 oncode              53
 195 onfield             42
 196 onfile              42
 197 
 198 onkey               42
 199 onloc               42
 200 onsource            52
 201 pageno              30
 202 pointer             34
 203 
 204 prec                 4
 205 prod                43
 206 ptr                 34
 207 rank                69
 208 real                19
 209 rel                 39
 210 wordno              71
 211 charno              72
 212 bitno               73
 213 addwordno           41
 214 addcharno           41
 215 addbitno            41
 216 setwordno           41
 217 setcharno           41
 218 setbitno            41
 219 
 220 reverse             27
 221 round               22
 222 rtrim               58
 223 search              37
 224 sign                38
 225 
 226 sin                 25
 227 sind                25
 228 sinh                25
 229 size                47
 230 sqrt                25
 231 
 232 stac                40
 233 stackbaseptr        61
 234 stackframeptr       61
 235 stacq               66
 236 string              10
 237 substr              11
 238 substraddr          67
 239 subtract            14
 240 sum                 43
 241 tan                 25
 242 
 243 tand                25
 244 tanh                25
 245 time                32
 246 translate           49
 247 trunc               16
 248 
 249 unspec              12
 250 valid               48
 251 vclock              62
 252 verify              37
 253 */
 254 ^L
 255           dcl      1 rtype like type;
 256 
 257           dcl      1 arg_type (128) like type;
 258 
 259           dcl      defined_arg_type (128) bit (36) defined (arg_type);
 260 
 261           dcl      1 as_if_type (128) like type;
 262 
 263           dcl      defined_as_if_type (128) bit (36) defined (as_if_type);
 264 
 265           dcl      targ_type bit (36) aligned;
 266           dcl      targ_prec fixed bin (31);
 267 
 268           dcl      save_context bit (36),
 269                    1 def_save_context defined (save_context),
 270                      2 aggregate bit (1),
 271                      2 arg_list bit (1),
 272                      2 left_side bit (1),
 273                      2 return bit (1),
 274                      2 evaluate_offset bit (1),
 275                      2 top bit (1),
 276                      2 RHS_aggregate bit (1),
 277                      2 return_from_empty bit (1),
 278                      2 ignore_based bit (1),
 279                      2 ext_param bit (1),
 280                      2 cross_section bit (1),
 281                      2 string_unspec bit (1);
 282 ^L
 283           tree = input_tree;
 284 
 285           if def_context.top then
 286                if statement_ptr -> statement.statement_type = call_statement then
 287                     call semantic_translator$abort (224, builtin_symbol);
 288 
 289           if subscripts = null then
 290                arg_number = 0;
 291           else
 292                arg_number = subscripts -> list.number;
 293 
 294           builtin_number = builtin_symbol -> symbol.c_dcl_size;
 295           opcode = pl1_data$builtin_name.description (builtin_number).opcode;
 296           jump_index = pl1_data$builtin_name.description (builtin_number).jump_index;
 297           reserved_number = pl1_data$builtin_name.description (builtin_number).reserve_list_number;
 298 
 299           if pl1_stat_$check_ansi then
 300                if pl1_data$builtin_name.description (builtin_number).nonstandard then
 301                     call semantic_translator$error (202, builtin_symbol);
 302 
 303 
 304           indicator = pl1_data$builtin_name.description (builtin_number).check_indicator;
 305 
 306           if indicator = 1 then
 307                if arg_number ^= pl1_data$builtin_name.description (builtin_number).number1 then
 308                     call semantic_translator$abort (121, builtin_symbol);
 309                else
 310                     ;
 311           else if indicator = 2 then
 312                if arg_number < pl1_data$builtin_name.description (builtin_number).number1 then
 313                     call semantic_translator$abort (122, builtin_symbol);
 314                else
 315                     ;
 316           else if indicator = 3 then
 317                if arg_number < pl1_data$builtin_name.description (builtin_number).number1
 318                     | arg_number > pl1_data$builtin_name.description (builtin_number).number2 then
 319                     call semantic_translator$abort (123, builtin_symbol);
 320 
 321           if def_context.left_side then do;
 322                builtin_string = builtin_symbol -> symbol.token -> token.string;
 323 
 324                if builtin_string ^= "real" & builtin_string ^= "imag" & builtin_string ^= "string"
 325                     & builtin_string ^= "substr" & builtin_string ^= "unspec" & builtin_string ^= "onchar"
 326                     & builtin_string ^= "onsource" & builtin_string ^= "pageno" then
 327                     call semantic_translator$abort (244, builtin_symbol);
 328                else
 329                     pseudo_variable = "1"b;
 330           end;
 331 ^L
 332           save_context = "0"b;
 333 
 334           do i = 1 to arg_number;
 335 
 336                this_context = "0"b;
 337                if i = 1 & (jump_index = 10 | jump_index = 12 | jump_index = 33) /*  string, unspec, addr */ then do;
 338                     def_this_context.evaluate_offset = "1"b;
 339 
 340                     if jump_index ^= 33 then
 341                          def_this_context.string_unspec = "1"b;
 342                end;
 343 
 344                if (jump_index = 46 & i = 1) /* convert */ | jump_index = 47 /* size */ then
 345                     def_this_context.ignore_based = "1"b;
 346 
 347                if i = 1
 348                     & (def_context.f_offset_to_be_added | jump_index = 11 /* substr */
 349                     | (jump_index >= 55 & jump_index <= 58)) /* after, before, ltrim, rtrim */ then
 350                     def_this_context.f_offset_to_be_added = "1"b;
 351 
 352                arg (i) =
 353                     expression_semantics (cur_block, statement_ptr, (subscripts -> element (arg_number + 1 - i)),
 354                     this_context);
 355 
 356                if def_this_context.aggregate then do;
 357                     if pl1_data$builtin_name.description (builtin_number).descriptor (i).check_code = 5 then
 358                          if jump_index ^= 11 /* substr */ then
 359                               goto err124;
 360 
 361                     if pl1_data$builtin_name.description (builtin_number).aggregate_result then
 362                          if ^def_context.by_name_assignment then do;
 363                               subscripts -> element (arg_number + 1 - i), arg (i) =
 364                                    expand_primitive (cur_block, statement_ptr, arg (i), this_context);
 365                          end;
 366                          else
 367                               go to err381;
 368                end;
 369 
 370                save_context = save_context | this_context;
 371 
 372                ref (i) = arg (i);
 373 
 374                do while (ref (i) -> node.type = operator_node);
 375                     ref (i) = ref (i) -> operand (1);
 376                end;
 377 
 378                if ref (i) -> node.type = token_node then do;
 379                     ref (i), arg_symbol (i) = null;
 380                     if arg (i) -> token.type = dec_integer then
 381                          defined_arg_type (i) = dec_integer_type;
 382                     else
 383                          defined_arg_type (i) = decoded_type (fixed (arg (i) -> token.type, 15));
 384                end;
 385                else if ref (i) -> node.type = label_node then do;
 386                     arg_symbol (i) = ref (i);
 387                     ref (i) = null;
 388                     defined_arg_type (i) = "0"b;
 389                end;
 390                else if ref (i) -> node.type = reference_node then do;
 391                     arg_symbol (i) = ref (i) -> reference.symbol;
 392                     defined_arg_type (i) =
 393                          substr (string (arg_symbol (i) -> symbol.attributes), 1, 36) & ^dimensioned_mask
 394                          & ^initialed_mask;
 395                end;
 396           end;
 397 
 398           this_context = "0"b;
 399 ^L
 400 /*   Processing of aggregate arguments   */
 401 
 402           if def_save_context.aggregate then
 403                if pl1_data$builtin_name.description (builtin_number).aggregate_result then do;
 404                     if jump_index = 24 /*   decat   */ then
 405                          call semantic_translator$abort (478, builtin_symbol);
 406 
 407                     if def_context.left_side then
 408                          call propagate_bit (arg_symbol (1), set_bit);
 409 
 410                     def_context.aggregate = "1"b;
 411                     tree = expand_arguments ();
 412 
 413                     goto exit;
 414                end;
 415 ^L
 416           do i = 1 to min (arg_number, pl1_data$builtin_name.description (builtin_number).number_of_descriptions);
 417 
 418                code = pl1_data$builtin_name.description (builtin_number).descriptor (i).check_code;
 419                string (type) = pl1_data$builtin_name.description (builtin_number).descriptor (i).type;
 420 
 421                if code = 0 then
 422                     goto next_descriptor;
 423 
 424                if code = 1 then
 425                     if string (type) & defined_arg_type (i) then
 426                          goto conv_arg;
 427                     else
 428                          goto err124;
 429 
 430                if code = 2 then
 431                     goto conv_arg;
 432 
 433                if code = 3 | code = 11 then do;
 434                     if code = 11 then
 435                          if arg_type (i).complex then
 436                               goto err124;
 437 
 438                     if arg_type (i).picture | arg_type (i).decimal | arg_type (i).char then do;
 439                          if arg_type (i).decimal then
 440                               string (type) = defined_arg_type (i) & ^fixed_mask | float_mask;
 441                          else if arg_type (i).complex then
 442                               string (type) = float_decimal_complex_mask;
 443                          else
 444                               string (type) = float_decimal_real_mask;
 445                          t = convert$from_builtin ((arg (i)), string (type));
 446                                                             /* call by value to protect arg(i) */
 447                          if t -> node.type = operator_node then
 448                               t = t -> operand (1) -> reference.symbol;
 449                          else
 450                               t = t -> reference.symbol;
 451                          targ_type = string (type);
 452                          if decimal_result then
 453                               targ_prec = max (targ_prec, t -> symbol.c_dcl_size);
 454                          else if i = 1 then do;
 455                               decimal_result = "1"b;
 456                               targ_prec = t -> symbol.c_dcl_size;
 457                          end;
 458                     end;
 459                     string (type) = float_mask | binary_mask;
 460                     goto conv_arg;
 461                end;
 462 
 463                if code = 4 then do;
 464                     if arg_type (i).bit then
 465                          string (type) = fixed_binary_real_mask;
 466                     else if arg_type (i).char then
 467                          string (type) = fixed_decimal_real_mask;
 468                     else if arg_type (i).picture then
 469                          if arg_symbol (i) -> symbol.complex then
 470                               if arg_symbol (i) -> symbol.pix.pic_float then
 471                                    string (type) = float_decimal_complex_mask;
 472                               else
 473                                    string (type) = fixed_decimal_complex_mask;
 474                          else if arg_symbol (i) -> symbol.pix.pic_float then
 475                               string (type) = float_decimal_real_mask;
 476                          else
 477                               string (type) = fixed_decimal_real_mask;
 478                     else if defined_arg_type (i) & arithmetic_mask then
 479                          string (type) = defined_arg_type (i);
 480                     else
 481                          goto err124;
 482 
 483                     goto conv_arg;
 484                end;
 485 
 486                if code = 5 then do;
 487                     string (type) = fixed_binary_real_mask;
 488 
 489                     if arg_type (i).fixed | arg_type (i).float then do;
 490                          ref (i), arg (i) = convert$to_integer (arg (i), integer_type);
 491 
 492                          if ref (i) -> node.type = operator_node then do;
 493                               ref (i) -> operator.processed = "1"b;
 494                               ref (i) = ref (i) -> operand (1);
 495                          end;
 496 
 497                          arg_symbol (i) = ref (i) -> reference.symbol;
 498                          defined_arg_type (i) = integer_type;
 499 
 500                          goto next_descriptor;
 501                     end;
 502 
 503                     goto conv_arg;
 504                end;
 505 
 506                if code = 6 then do;
 507                     if arg (i) -> node.type = reference_node then
 508                          if symbol_is_constant (arg_symbol (i)) then
 509                               if ^arg_type (i).fixed | ^arg_type (i).binary | ^arg_type (i).real then
 510                                    arg (i) = subscripts -> element (arg_number + 1 - i);
 511                               else
 512                                    goto next_descriptor;
 513                          else
 514                               goto err124;
 515 
 516                     if arg (i) -> node.type ^= token_node then
 517                          goto err124;
 518 
 519 
 520                     if arg (i) -> token.type ^= dec_integer then
 521                          goto err124;
 522 
 523                     string (type) = fixed_binary_real_mask;
 524 
 525                     goto conv_arg;
 526                end;
 527 
 528                if code = 7 then do;
 529                     if arg_type (i).bit | arg_type (i).char then
 530                          string (type) = defined_arg_type (i);
 531                     else if arg_type (i).binary | arg_type (i).picture | arg_type (i).decimal then
 532                          string (type) = char_mask;
 533                     else
 534                          goto err124;
 535 
 536                     goto conv_arg;
 537                end;
 538 
 539                if code = 8 then do;
 540                     if arg_type (i).bit then
 541                          string (type) = bit_mask;
 542                     else if arg_type (i).fixed | arg_type (i).float then do;
 543                          ref (i), arg (i) = convert$to_integer (arg (i), integer_type);
 544 
 545                          if ref (i) -> node.type = operator_node then do;
 546                               ref (i) -> operator.processed = "1"b;
 547                               ref (i) = ref (i) -> operand (1);
 548                          end;
 549 
 550                          arg_symbol (i) = ref (i) -> reference.symbol;
 551                          defined_arg_type (i) = integer_type;
 552 
 553                          go to next_descriptor;
 554                     end;
 555                     else
 556                          string (type) = fixed_binary_real_mask;
 557 
 558                     go to conv_arg;
 559 
 560                end;
 561 
 562                if code = 9 then
 563                     if ref (i) = null then
 564                          goto err124;
 565                     else
 566                          goto next_descriptor;
 567 
 568                if code = 10 then do;
 569                     if (defined_arg_type (i) & computational_mask) = "0"b then
 570                          goto err124;
 571 
 572                     goto next_descriptor;
 573                end;
 574 
 575                if code = 12 then do;
 576                     if ^arg_type (i).label & ^arg_type (i).entry & ^arg_type (i).format
 577                          & arg (i) -> node.type ^= label_node then
 578                          go to err124;
 579                     go to next_descriptor;
 580                end;
 581 
 582 conv_arg:
 583                call convert_arg;
 584 
 585 next_descriptor:
 586           end;
 587 ^L
 588           string (rtype) = defined_arg_type (1) & ^unaligned_mask | aligned_mask;
 589 
 590           rprecision, rscale = 0;
 591           rlength = null;
 592 
 593           do i = 1 to arg_number;
 594                if ref (i) ^= null then
 595                     if ref (i) -> reference.varying_ref then do;
 596                          if i = 1 then
 597                               if jump_index = 9 /* copy */ | jump_index = 24 /* decat */ | jump_index = 27 /* reverse */
 598                                    | jump_index = 49 /* translate */ then do;
 599                                    rlength = create_length_fun (arg (1));
 600                                    string (rtype) = string (rtype) & ^varying_mask;
 601                               end;
 602                     end;
 603           end;
 604 
 605           if arg_number ^= 0 & arg_symbol (1) ^= null then
 606                if arg_symbol (1) -> node.type = symbol_node then do;
 607                     rprecision = arg_symbol (1) -> symbol.c_dcl_size;
 608                     if arg_type (1).bit | arg_type (1).char then
 609                          if rlength = null then
 610                               rprecision = ref (1) -> reference.c_length;
 611                          else
 612                               rprecision = 0;
 613 
 614                     rscale = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
 615 
 616                     if ref (1) ^= null & rlength = null then
 617                          if jump_index = 9 /* copy */ | jump_index = 24 /* decat */ | jump_index = 27 /* reverse */
 618                               | jump_index = 49 /* translate */ then do;
 619                               rlength = share_expression ((ref (1) -> reference.length));
 620                               string (rtype) = string (rtype) & ^varying_mask;
 621                          end;
 622 
 623                end;
 624 
 625           goto action (jump_index);
 626 ^L
 627 action (0):
 628           call semantic_translator$abort (131, builtin_symbol);
 629           goto ret;
 630 
 631 action (1):                                                 /* collate */
 632           tree = declare_constant$char (collating_sequence);
 633 
 634           goto ret;
 635 
 636 action (2):                                                 /* float */
 637           string (rtype) = float_mask;
 638 
 639           if arg_number = 2 then
 640                rprecision = constant_value (arg_symbol (2));
 641           else do;
 642                rprecision = 0;
 643                if pl1_stat_$check_ansi then
 644                     call semantic_translator$error (172, builtin_symbol);
 645           end;
 646 
 647           goto convert_to_arith;
 648 
 649 action (3):                                                 /* fixed */
 650                                                             /* Warn users away from fixed(<dec_integer_constant>...) */
 651           if arg (1) -> node.type = token_node then
 652                if arg (1) -> token.type = dec_integer then
 653                     call semantic_translator$error (484, null);
 654 
 655           string (rtype) = fixed_mask;
 656 
 657           if arg_number = 3 then
 658                rscale = constant_value (arg_symbol (3));
 659           else
 660                rscale = 0;
 661 
 662           if arg_number >= 2 then
 663                rprecision = constant_value (arg_symbol (2));
 664           else do;
 665                rprecision = 0;
 666                if pl1_stat_$check_ansi then
 667                     call semantic_translator$error (172, builtin_symbol);
 668           end;
 669 
 670           goto convert_to_arith;
 671 
 672 action (4):                                                 /* prec
 673    precision */
 674           if arg_type (1).char then
 675                string (rtype) = fixed_decimal_real_mask | aligned_mask;
 676           else if arg_type (1).bit then
 677                string (rtype) = fixed_binary_real_mask | aligned_mask;
 678 
 679           if arg_type (1).float & arg_number = 3 then
 680                call semantic_translator$abort (167, builtin_symbol);
 681 
 682           if arg_number = 3 then
 683                rscale = constant_value (arg_symbol (3));
 684 
 685           rprecision = constant_value (arg_symbol (2));
 686 
 687           full_attribute_set = "1"b;
 688 
 689           goto check_prec_scale;
 690 
 691 action (5):                                                 /* high */
 692           arg (2) = arg (1);
 693           ref (2) = ref (1);
 694           arg_symbol (2) = arg_symbol (1);
 695 
 696           arg (1), ref (1) = declare_constant ("001111111"b, char_type, 1, 0);
 697           arg_symbol (1) = arg (1) -> reference.symbol;
 698 
 699           arg_number = 2;
 700           string (rtype) = char_type;
 701 
 702           goto repeat;
 703 
 704 action (6):                                                 /* index */
 705           if arg_type (1).bit & arg_type (2).bit then
 706                string (type) = bit_mask;
 707           else
 708                string (type) = char_mask;
 709 
 710           do i = 1 to 2;
 711                call convert_arg;
 712           end;
 713 
 714           if type.char then
 715                if check_reverse (arg (1)) then do;
 716                     opcode = index_rev_fun;                 /* Will use reverse index */
 717                     arg (1) = arg (1) -> operator.operand (2);
 718                                                             /* Use the unreversed thing */
 719                     if check_reverse (arg (2)) /* If 2 is a reverse too, .. */ then
 720                          arg (2) = arg (2) -> operator.operand (2);
 721                                                             /* Eliminate it.. or */
 722                     else
 723                          arg (2) = make_builtin_reference ("reverse", 1, arg (2), null, null);
 724                end;
 725 
 726           string (rtype) = fixed_binary_real_mask;
 727           rprecision = max_length_precision;
 728 
 729           goto create_operator_node;
 730 
 731 action (7):                                                 /* length */
 732 action (65):                                                /* maxlength */
 733           if arg (1) -> node.type = operator_node then
 734                if arg (1) -> op_code = std_call then do;
 735                     s = create_statement (call_statement, (statement_ptr -> statement.back), null,
 736                          (statement_ptr -> statement.prefix));
 737                     s -> statement.root = share_expression (arg (1));
 738                end;
 739 
 740           if ref (1) -> reference.varying_ref then do;
 741                if jump_index = 7 then do;
 742 
 743 /* length */
 744 
 745                     string (rtype) = integer_type;
 746                     rprecision = max_length_precision;
 747                     goto create_operator_node;
 748                end;
 749 
 750                else do;
 751 
 752 /* maxlength */
 753 
 754                     if arg_symbol (1) -> symbol.dcl_size = null then
 755                          tree = declare_constant$integer ((arg_symbol (1) -> symbol.c_dcl_size));
 756                     else do;
 757                          tree = copy_expression (arg_symbol (1) -> symbol.dcl_size);
 758                          if arg_symbol (1) -> symbol.refer_extents then
 759                               call refer_extent (tree, (ref (1) -> reference.qualifier));
 760                          tree = expression_semantics ((arg_symbol (1) -> symbol.block_node), statement_ptr, tree, "0"b);
 761                          tree = convert$to_integer (tree, integer_type);
 762                     end;
 763 
 764                     goto ret;
 765                end;
 766           end;
 767 
 768           if ref (1) -> reference.length = null then
 769                tree = declare_constant$integer ((ref (1) -> reference.c_length));
 770           else
 771                tree = ref (1) -> reference.length;
 772 
 773           goto ret;
 774 
 775 action (8):                                                 /* low */
 776           arg (2) = arg (1);
 777           ref (2) = ref (1);
 778           arg_symbol (2) = arg_symbol (1);
 779 
 780           arg (1), ref (1) = declare_constant ("000000000"b, char_type, 1, 0);
 781           arg_symbol (1) = arg (1) -> reference.symbol;
 782 
 783           arg_number = 2;
 784           string (rtype) = char_type;
 785 
 786           goto repeat;
 787 
 788 action (9):                                                 /* copy */
 789 repeat:
 790           if symbol_is_constant (arg_symbol (2)) then
 791                m = constant_value (arg_symbol (2));
 792 
 793           if ref (1) -> reference.varying_ref then
 794                length = rlength;
 795           else if ref (1) -> reference.length ^= null then
 796                length = ref (1) -> reference.length;
 797           else if ^symbol_is_constant (arg_symbol (2)) then
 798                length = declare_constant$integer ((ref (1) -> reference.c_length));
 799           else
 800                length = null;
 801 
 802           if length ^= null then do;
 803                rprecision = 0;
 804                arg (2) = share_expression (arg (2));
 805                if ref (1) -> reference.c_length = 1 then
 806                     rlength = arg (2);
 807                else do;
 808                     rlength = create_operator (mult, 3);
 809                     rlength -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
 810                     rlength -> operand (2) = length;
 811                     rlength -> operand (3) = arg (2);
 812                     rlength -> operator.processed = "1"b;
 813                end;
 814           end;
 815           else do;
 816                rprecision = ref (1) -> reference.c_length * max (m, 0);
 817                if jump_index ^= 9 /* we have told users we will NOT optimize this for copy */ then
 818                     if m = 1 then
 819                          goto return_arg1;
 820           end;
 821 
 822           goto create_operator_node;
 823 ^L
 824 action (10):                                                /* string */
 825           if arg (1) -> node.type = token_node then do;
 826                i = 1;
 827                if arg_type (1).bit then
 828                     string (type) = defined_arg_type (1);
 829                else
 830                     string (type) = char_mask;
 831 
 832                call convert_arg;
 833 
 834                if def_context.left_side then
 835                     call semantic_translator$abort (141, builtin_symbol);
 836 
 837                goto return_arg1;
 838           end;
 839 
 840           if arg (1) -> node.type = reference_node & arg (1) = arg_symbol (1) -> symbol.reference then
 841                arg (1), ref (1) = copy_expression ((ref (1)));
 842 
 843           string (rtype) = defined_arg_type (1);
 844 
 845           if def_context.left_side then
 846                call propagate_bit (arg_symbol (1), set_bit);
 847 
 848           if arg (1) -> node.type = operator_node then do;
 849                if arg (1) -> operator.op_code = loop | arg (1) -> operator.op_code = join | arg_type (1).structure
 850                     | ref (1) -> reference.array_ref then
 851                     call semantic_translator$abort (294, builtin_symbol);
 852 
 853                i = 1;
 854                if arg_type (1).bit then
 855                     string (type) = defined_arg_type (1);
 856                else
 857                     string (type) = char_mask;
 858 
 859                call convert_arg;
 860 
 861                if def_context.left_side then
 862                     call semantic_translator$abort (141, builtin_symbol);
 863 
 864                goto return_arg1;
 865           end;
 866 
 867           if arg_type (1).structure then do;
 868                p = arg_symbol (1);
 869                do while (p -> symbol.structure);
 870                     p = p -> symbol.son;
 871                end;
 872 
 873                if p -> symbol.bit then
 874                     units = bit_;
 875                else if p -> symbol.char | p -> symbol.picture then
 876                     units = character_;
 877                else
 878                     goto err124;
 879 
 880                call check_strings ((arg_symbol (1) -> symbol.son));
 881 
 882                goto aggregate;
 883           end;
 884 
 885           if arg_type (1).bit | arg_type (1).char | arg_type (1).picture then do;
 886                if ^ref (1) -> reference.array_ref then do;
 887                     if ^arg_type (1).picture then
 888                          goto return_arg1;
 889                     else do;
 890                          units = character_;
 891                          c_length = ref (1) -> reference.c_length;
 892                          length = null;
 893                          goto make_reference;
 894                     end;
 895                end;
 896 
 897                if arg_type (1).bit then
 898                     units = bit_;
 899                else
 900                     units = character_;
 901 
 902                if arg_symbol (1) -> symbol.packed then
 903                     goto aggregate;
 904 
 905                if def_context.left_side then
 906                     call semantic_translator$abort (141, builtin_symbol);
 907                else
 908                     call semantic_translator$abort (142, builtin_symbol);
 909                goto ret;
 910           end;
 911           else do;
 912                if arg (1) -> reference.array_ref then
 913                     call semantic_translator$abort (139, arg_symbol (1));
 914 
 915                i = 1;
 916                string (type) = char_mask;
 917                call convert_arg;
 918 
 919                goto return_arg1;
 920           end;
 921 ^L
 922 action (11):                                                /* substr */
 923           if rtype.bit then
 924                units = bit_;
 925           else
 926                units = character_;
 927 
 928           if arg (1) -> node.type = operator_node then do;
 929                if def_context.left_side then
 930                     call semantic_translator$abort (148, builtin_symbol);
 931 
 932                ref (1) = arg (1) -> operand (1);
 933           end;
 934           else if def_context.left_side then do;
 935                call propagate_bit (arg_symbol (1), set_bit);
 936                arg_symbol (1) -> symbol.passed_as_arg = "1"b;
 937           end;
 938 
 939 /* If user didn't specify 3rd argument (new length), or stringrange is enabled, save info
 940              about length of first argument now. */
 941 
 942           if arg_number = 2 | substr (statement_ptr -> statement.prefix, 8, 1) /* stringrange */ then do;
 943                if ref (1) -> reference.varying_ref then do;
 944                     length = create_length_fun (arg (1));
 945                     c_length = 0;
 946                end;
 947                else do;
 948                     length = ref (1) -> reference.length;
 949                     c_length = ref (1) -> reference.c_length;
 950                     if length ^= null then
 951                          if arg (1) -> node.type = operator_node | ref (1) -> reference.ref_count > 1 then
 952                               length = share_expression (length);
 953                end;
 954 
 955                if arg_number = 2 & substr (statement_ptr -> statement.prefix, 8, 1) then
 956                     if length ^= null then
 957                          length = share_expression (length);
 958           end;
 959 
 960 /* Compute (offset - 1) and save it in "offset". */
 961 
 962           if symbol_is_constant (arg_symbol (2)) then do;
 963                offset = null;
 964                c_offset = constant_value (arg_symbol (2)) - 1;
 965           end;
 966           else do;
 967                c_offset = 0;
 968 
 969                if arg (2) -> node.type = operator_node then
 970                     if arg (2) -> operator.op_code = add then
 971                          if arg (2) -> operand (3) -> node.type = reference_node then
 972                               if symbol_is_constant ((arg (2) -> operand (3) -> reference.symbol)) then
 973                                    if constant_value ((arg (2) -> operand (3) -> reference.symbol)) = 1 then
 974                                         if fb1_value ((arg (2) -> operand (3) -> reference.symbol)) then do;
 975                                              r = arg (2) -> operand (2);
 976                                              if r -> node.type = operator_node then
 977                                                   r = r -> operand (1);
 978 
 979                                              if fb1_value ((r -> reference.symbol)) then do;
 980                                                   offset = arg (2) -> operand (2);
 981                                                   go to chk_context;
 982                                              end;
 983                                         end;
 984 
 985                offset = create_operator (sub, 3);
 986                offset -> operand (2) = arg (2);
 987                offset -> operand (3) = declare_constant$integer (1);
 988           end;
 989 
 990 chk_context:
 991           if def_context.arg_list then do;
 992                tree, p = create_operator (assign, 2);
 993                r = create_symbol (null, null, by_compiler);
 994                r -> symbol.temporary = "1"b;
 995                p -> operand (1) = r -> symbol.reference;
 996                p -> operand (2) = arg (1);
 997           end;
 998 
 999           if arg (1) -> node.type = operator_node | arg_symbol (1) -> symbol.picture then do;
1000                s = create_symbol (null, null, by_compiler);
1001                p = s -> symbol.reference;
1002                t = ref (1) -> reference.symbol;
1003                s -> symbol = t -> symbol;                   /* structure assignment */
1004                s -> symbol.next = null;
1005                s -> symbol.reference = p;
1006                s -> symbol.defined, s -> symbol.overlayed, s -> symbol.position = "1"b;
1007                s -> symbol.return_value, s -> symbol.temporary = "0"b;
1008                p -> reference.qualifier = arg (1);
1009                p -> reference.shared = "0"b;
1010                p -> reference.ref_count = 1;
1011 
1012                if s -> symbol.picture then do;
1013                     s -> symbol.picture = "0"b;
1014                     s -> symbol.char = "1"b;
1015                     s -> symbol.general = null;
1016                end;
1017 
1018                if arg (1) -> node.type ^= operator_node then do;
1019 
1020 /* move the offset from the defined variable up */
1021 
1022                     if ref (1) = arg_symbol (1) -> symbol.reference then
1023                          p -> reference.qualifier, ref (1) = copy_expression ((ref (1)));
1024                     else if ref (1) -> reference.ref_count > 1 then do;
1025                          ref (1) -> reference.ref_count = ref (1) -> reference.ref_count - 1;
1026                          r = create_reference (null);
1027                          r -> reference = ref (1) -> reference;
1028                          r -> reference.ref_count = 1;
1029                          call reuse_qual_and_offset (r);
1030                          p -> reference.qualifier, ref (1) = r;
1031                     end;
1032                     p -> reference.offset = ref (1) -> reference.offset;
1033                     p -> reference.c_offset = ref (1) -> reference.c_offset;
1034                     p -> reference.units = ref (1) -> reference.units;
1035                     p -> reference.modword_in_offset = ref (1) -> reference.modword_in_offset;
1036                     ref (1) -> reference.offset = null;
1037                     ref (1) -> reference.c_offset = 0;
1038                     ref (1) -> reference.modword_in_offset = "0"b;
1039 
1040 /* this must not be commoned by optimizer */
1041 
1042                     ref (1) -> reference.inhibit = "1"b;
1043                end;
1044           end;
1045           else do;
1046                p = create_reference ((ref (1) -> reference.symbol));
1047                p -> reference = ref (1) -> reference;       /* structure assignment */
1048                p -> reference.shared = "0"b;
1049                p -> reference.ref_count = 1;
1050                if ^ref (1) -> reference.shared then do;
1051                     rcount, ref (1) -> reference.ref_count = ref (1) -> reference.ref_count - 1;
1052                     if rcount > 0 then
1053                          call reuse_qual_and_offset (p);    /* we may have substr(varying,<expr>) */
1054                end;
1055           end;
1056 
1057 /* Begin filling in the new reference node expressing the
1058              result of substr.  Save the original argument because
1059              we still need some of the info in it. */
1060 
1061           save_arg_one = arg (1);
1062           arg (1) = p;
1063 
1064           arg (1) -> reference.varying_ref, arg (1) -> reference.padded_ref, arg (1) -> reference.aligned_ref = "0"b;
1065 
1066           off = arg (1) -> reference.offset;
1067           coff = arg (1) -> reference.c_offset;
1068           cunits = arg (1) -> reference.units;
1069           call offset_adder (off, coff, cunits, (arg (1) -> reference.modword_in_offset), (offset), (c_offset), units,
1070                "0"b, arg (1) -> reference.fo_in_qual);
1071           arg (1) -> reference.offset = off;
1072           arg (1) -> reference.c_offset = coff;
1073           arg (1) -> reference.units = cunits;
1074           arg (1) -> reference.modword_in_offset = "0"b;
1075 
1076           if ^pl1_stat_$eis_mode then
1077                if arg (1) -> reference.offset ^= null then
1078                     if arg (1) -> reference.units <= half_ then do;
1079                          if arg (1) -> reference.units = bit_ then
1080                               opcode = mod_bit;
1081                          else if arg (1) -> reference.units = character_ then
1082                               opcode = mod_byte;
1083                          else
1084                               opcode = mod_half;
1085 
1086                          p = create_operator (opcode, 3);
1087                          p -> operand (1), p -> operand (2) =
1088                               declare_temporary (integer_type, default_fix_bin_p, 0, null);
1089                          p -> operand (3) = arg (1) -> reference.offset;
1090 
1091                          arg (1) -> reference.offset = p;
1092                     end;
1093 
1094 /* Fill in length of result. */
1095 
1096           if arg_number = 2 then
1097                if length = null & offset = null then
1098                     arg (1) -> reference.c_length = c_length - c_offset;
1099                else do;
1100                     p = create_operator (sub, 3);
1101                     p -> operand (1) = declare_temporary (fixed_binary_real_mask, default_fix_bin_p, 0, null);
1102                     p -> operand (2) = length;
1103                     p -> operand (3) = offset;
1104 
1105                     arg (1) -> reference.length = p;
1106                     arg (1) -> reference.c_length = 0;
1107 
1108                     if length = null then
1109                          p -> operand (2) = declare_constant$integer (c_length);
1110 
1111                     if offset = null then
1112                          p -> operand (3) = declare_constant$integer (c_offset);
1113                     else do;
1114                          if offset -> node.type = operator_node then
1115                               offset = expression_semantics (cur_block, statement_ptr, offset, "0"b);
1116 
1117                          offset = share_expression (offset);
1118                     end;
1119                end;
1120           else if symbol_is_constant (arg_symbol (3)) then do;
1121                arg (1) -> reference.c_length = constant_value (arg_symbol (3));
1122                arg (1) -> reference.length = null;
1123           end;
1124           else do;
1125                arg (1) -> reference.c_length = 0;
1126                arg (1) -> reference.length = arg (3);
1127           end;
1128 
1129           if substr (statement_ptr -> statement.prefix, 8, 1) /* stringrange */ then
1130                if symbol_is_constant (arg_symbol (2)) /* if 2nd arg (offset) is a constant */
1131                     & arg (1) -> reference.length = null /* and new length is constant */
1132                     & length = null /* and old length is constant */ then do;
1133                                                             /* then make checks now */
1134                     substr_index = constant_value (arg_symbol (2));
1135 
1136                     if substr_index < 1 then
1137                          call semantic_translator$error (147, builtin_symbol);
1138 
1139 /* if there is a problem here, diagnose it later */
1140                     if arg (1) -> reference.c_length < 0 then
1141                          c_length = substr_index - 1;
1142 
1143                     if c_length < (substr_index + arg (1) -> reference.c_length - 1) then
1144                          call semantic_translator$error (147, builtin_symbol);
1145                end;
1146                else do;
1147                     if arg (1) -> reference.length = null then do;
1148                          arg (1) -> reference.length = declare_constant$integer ((arg (1) -> reference.c_length));
1149                          arg (1) -> reference.c_length = 0;
1150                     end;
1151 
1152 /* Generate operator to check that:
1153                                  0 <= new_length <= (orig_length - offset + 1) */
1154 
1155                     p = create_operator (range_ck, 4);
1156                     p -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1157                     p -> operand (2) = arg (1) -> reference.length;
1158                     p -> operand (3) = declare_constant$integer (0);
1159 
1160                     p -> operand (4) = create_operator (sub, 3);
1161                     p -> operand (4) -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1162 
1163 /* Fill in length of original argument */
1164 
1165                     if length = null then
1166                          p -> operand (4) -> operand (2) = declare_constant$integer (c_length);
1167                     else
1168                          p -> operand (4) -> operand (2) = length;
1169 
1170                     if offset = null then
1171                          p -> operand (4) -> operand (3) = declare_constant$integer (c_offset);
1172                     else
1173                          p -> operand (4) -> operand (3) = copy_expression ((offset));
1174 
1175                     if offset = null & length = null then
1176                          if c_offset < 0 | c_offset > c_length then
1177                               call semantic_translator$abort (147, builtin_symbol);
1178                          else
1179                               ;
1180                     else do;
1181                          r = create_operator (range_ck, 4);
1182                          r -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1183                          r -> operand (2) = p -> operand (4) -> operand (3);
1184                          r -> operand (3) = declare_constant$integer (0);
1185                          r -> operand (4) = copy_expression ((p -> operand (4) -> operand (2)));
1186 
1187                          p -> operand (4) -> operand (3) = r;
1188                     end;
1189 
1190                     arg (1) -> reference.length = p;
1191                end;
1192 
1193 /* fix to avoid problems later in convert
1194              if a constant substr length is < 0 */
1195           if arg (1) -> reference.c_length < 0 then do;
1196                call semantic_translator$error (147, builtin_symbol);
1197                arg (1) -> reference.c_length = 0;
1198           end;
1199 
1200           arg (1) -> reference.length =
1201                expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.length), "0"b);
1202           if arg (1) -> reference.length ^= null then
1203                arg (1) -> reference.length = convert$to_integer ((arg (1) -> reference.length), integer_type);
1204 
1205           arg (1) -> reference.offset =
1206                expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.offset), "0"b);
1207           if arg (1) -> reference.offset ^= null then
1208                arg (1) -> reference.offset = convert$to_integer ((arg (1) -> reference.offset), integer_type);
1209 
1210           arg (1) -> reference.substr = "1"b;
1211 
1212           call simplify_offset (arg (1), context);
1213 
1214           if def_context.arg_list then do;
1215                tree -> operand (2) = arg (1);
1216                tree = operator_semantics (cur_block, statement_ptr, tree, this_context);
1217                goto ret;
1218           end;
1219 
1220           goto return_arg1;
1221 ^L
1222 action (12):                                                /* unspec */
1223           if arg (1) -> node.type = token_node then do;
1224                call semantic_translator$error (485, null);
1225                i = 1;
1226                string (type) = defined_arg_type (1);
1227                call convert_arg;
1228           end;
1229 
1230           if arg (1) -> node.type = reference_node & arg (1) = arg_symbol (1) -> symbol.reference then
1231                arg (1), ref (1) = copy_expression ((ref (1)));
1232 
1233           string (rtype) = bit_mask;
1234           units = bit_;
1235 
1236           if def_context.left_side then
1237                if arg (1) -> node.type = operator_node then
1238                     call semantic_translator$abort (148, builtin_symbol);
1239                else do;
1240                     call propagate_bit (arg_symbol (1), set_bit);
1241                     arg_symbol (1) -> symbol.passed_as_arg = "1"b;
1242                end;
1243 
1244           if arg_type (1).structure | ref (1) -> reference.array_ref then do;
1245                if pl1_stat_$check_ansi then
1246                     call semantic_translator$error (172, builtin_symbol);
1247                goto aggregate;
1248           end;
1249 
1250           if ref (1) -> reference.varying_ref then do;
1251                length = create_length_fun (arg (1));
1252                c_length = 0;
1253           end;
1254           else do;
1255                length = ref (1) -> reference.length;
1256                c_length = ref (1) -> reference.c_length;
1257           end;
1258 
1259           if arg_symbol (1) -> symbol.bit then
1260                goto make_reference;
1261 
1262           if arg_symbol (1) -> symbol.char | arg_symbol (1) -> symbol.picture then do;
1263                if length ^= null then do;
1264                     p = create_operator (mult, 3);
1265                     p -> operand (2) = length;
1266                     p -> operand (3) = declare_constant$integer (bits_per_character);
1267                     length = p;
1268                end;
1269                else
1270                     c_length = c_length * bits_per_character;
1271 
1272                goto make_reference;
1273           end;
1274 
1275 aggregate:
1276           if arg (1) -> node.type = operator_node then
1277                call semantic_translator$abort (294, builtin_symbol);
1278 
1279           if arg_symbol (1) -> symbol.array ^= null & ^ref (1) -> reference.array_ref then do;
1280                c_length = arg_symbol (1) -> symbol.array -> array.c_element_size_bits;
1281                length = copy_expression (arg_symbol (1) -> symbol.array -> array.element_size_bits);
1282           end;
1283           else do;
1284                c_length = arg_symbol (1) -> symbol.c_bit_size;
1285                length = copy_expression (arg_symbol (1) -> symbol.bit_size);
1286 
1287                if ref (1) -> reference.offset ^= null then
1288                     if ref (1) -> reference.offset -> node.type = list_node then
1289                          call semantic_translator$abort (338, ref (1));
1290           end;
1291 
1292           if units = character_ then
1293                if length ^= null then do;
1294                     p = create_operator (bit_to_char, 2);
1295                     p -> operand (2) = length;
1296 
1297                     length = p;
1298                end;
1299                else
1300                     c_length = divide (c_length, bits_per_character, 15, 0);
1301 
1302 
1303           if arg_symbol (1) -> symbol.defined then
1304                if arg_symbol (1) -> symbol.structure | ref (1) -> reference.array_ref then
1305                     arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);
1306 
1307 make_reference:
1308           if arg (1) -> node.type = operator_node then do;
1309                call make_assignment;
1310 
1311                if agg_ref = null then
1312                     arg (1) = p -> operand (1);
1313                else do;
1314                     arg (1) = agg_ref;
1315                     defined_arg_type (1) = string (agg_ref -> reference.symbol -> symbol.attributes);
1316                     c_length = agg_ref -> reference.symbol -> symbol.c_bit_size;
1317                     length = copy_expression (agg_ref -> reference.symbol -> symbol.bit_size);
1318                end;
1319 
1320                if arg_type (1).bit | jump_index = 12 then
1321                     units = bit_;
1322                else
1323                     units = character_;
1324           end;
1325 
1326           if def_context.arg_list then do;
1327                tree, p = create_operator (assign, 2);
1328                r = create_symbol (null, null, by_compiler);
1329                r -> symbol.temporary = "1"b;
1330                p -> operand (1) = r -> symbol.reference;
1331                p -> operand (2) = arg (1);
1332           end;
1333 
1334           if units = character_ then
1335                string (rtype) = char_mask;
1336           else
1337                string (rtype) = bit_mask;
1338 
1339           rtype.unaligned = arg_symbol (1) -> symbol.packed;
1340 
1341           if ^arg_symbol (1) -> symbol.overlayed_by_builtin then
1342                call propagate_bit (arg_symbol (1), overlayed_by_builtin_bit);
1343 
1344           p = declare_defined_overlay (string (rtype), c_length, 0, length, arg (1));
1345 
1346 /* we omit setting ref(1)->reference.c_length=0 because ref(1) might be a constant and,
1347              therefore, still a symbol.reference since copy_expression works differently here */
1348           ref (1) -> reference.length = null;
1349 
1350           p -> reference.padded_ref = "0"b;
1351 
1352 
1353 /*  move the offsets from the defined variable up */
1354 
1355           p -> reference.qualifier = arg (1);
1356           p -> reference.fo_in_qual = ref (1) -> reference.fo_in_qual;
1357           p -> reference.offset = arg (1) -> reference.offset;
1358           p -> reference.c_offset = arg (1) -> reference.c_offset;
1359           p -> reference.units = arg (1) -> reference.units;
1360           p -> reference.modword_in_offset = arg (1) -> reference.modword_in_offset;
1361 
1362           if ^pl1_stat_$eis_mode then
1363                if p -> reference.offset ^= null then
1364                     if p -> reference.units <= half_ then do;
1365                          if p -> reference.units = bit_ then
1366                               opcode = mod_bit;
1367                          else if p -> reference.units = character_ then
1368                               opcode = mod_byte;
1369                          else
1370                               opcode = mod_half;
1371 
1372                          offset = create_operator (opcode, 3);
1373                          offset -> operand (1), offset -> operand (2) =
1374                               declare_temporary (integer_type, default_fix_bin_p, 0, null);
1375                          offset -> operand (3) = p -> reference.offset;
1376 
1377                          p -> reference.offset = offset;
1378                     end;
1379 
1380           if (p -> reference.units = character_ | p -> reference.units = digit_) & units = bit_ & pl1_stat_$eis_mode
1381           then do;                                          /* string(bit_structure) or unspec */
1382                p -> reference.c_offset = p -> reference.c_offset * bits_per_character;
1383 
1384                if p -> reference.units = digit_ then
1385                     p -> reference.c_offset = divide (p -> reference.c_offset, packed_digits_per_character, 24, 0);
1386 
1387                if p -> reference.offset ^= null & ^p -> reference.modword_in_offset then
1388                     if p -> reference.units = character_ then do;
1389                          offset = create_operator (mult, 3);
1390                          offset -> operand (2) = declare_constant$integer (bits_per_character);
1391                          offset -> operand (3) = p -> reference.offset;
1392                          p -> reference.offset = offset;
1393                     end;
1394                     else do;
1395                          offset = create_operator (digit_to_bit, 2);
1396                          offset -> operand (2) = p -> reference.offset;
1397                          p -> reference.offset = offset;
1398                     end;
1399                p -> reference.units = bit_;
1400           end;
1401 
1402           if p -> reference.qualifier -> node.type = reference_node then do;
1403                p -> reference.qualifier -> reference.c_offset = 0;
1404                p -> reference.qualifier -> reference.offset = null;
1405                p -> reference.qualifier -> reference.modword_in_offset = "0"b;
1406                p -> reference.qualifier -> reference.inhibit = "1"b;
1407           end;
1408 
1409           p -> reference.length = fill_refer ((p -> reference.length), (ref (1) -> reference.qualifier), "1"b);
1410           p -> reference.length = expression_semantics (cur_block, statement_ptr, (p -> reference.length), "0"b);
1411           if p -> reference.length ^= null then
1412                p -> reference.length = convert$to_integer ((p -> reference.length), integer_type);
1413 
1414           p -> reference.offset = expression_semantics (cur_block, statement_ptr, (p -> reference.offset), "0"b);
1415           if p -> reference.offset ^= null then
1416                p -> reference.offset = convert$to_integer ((p -> reference.offset), integer_type);
1417 
1418           call simplify_offset (p, context);
1419 
1420           if def_context.arg_list then do;
1421                tree -> operand (2) = p;
1422                tree = operator_semantics (cur_block, statement_ptr, tree, this_context);
1423           end;
1424           else
1425                tree = p;
1426 
1427           goto ret;
1428 ^L
1429 action (13):                                                /* abs */
1430           string (rtype) = defined_arg_type (1) & ^unaligned_mask & ^complex_mask | real_mask | aligned_mask;
1431 
1432           goto create_operator_node;
1433 
1434 action (14):                                                /* add
1435    divide
1436    multiply
1437    subtract */
1438           string (rtype) = "0"b;
1439 
1440           do i = 1 to 2;
1441                defined_as_if_type (i) = defined_arg_type (i);
1442 
1443                if as_if_type (i).bit then
1444                     defined_as_if_type (i) = fixed_binary_real_mask;
1445                else if as_if_type (i).char then
1446                     defined_as_if_type (i) = fixed_decimal_real_mask;
1447                else if as_if_type (i).picture then
1448                     if arg_symbol (i) -> symbol.complex then
1449                          if arg_symbol (i) -> symbol.pix.pic_float then
1450                               defined_as_if_type (i) = float_decimal_complex_mask;
1451                          else
1452                               defined_as_if_type (i) = fixed_decimal_complex_mask;
1453                     else if arg_symbol (i) -> symbol.pix.pic_float then
1454                          defined_as_if_type (i) = float_decimal_real_mask;
1455                     else
1456                          defined_as_if_type (i) = fixed_decimal_real_mask;
1457           end;
1458 
1459           if as_if_type (1).fixed & as_if_type (2).fixed then
1460                string (rtype) = string (rtype) | fixed_mask;
1461           else
1462                string (rtype) = string (rtype) & ^fixed_mask | float_mask;
1463 
1464           if as_if_type (1).decimal & as_if_type (2).decimal then
1465                string (rtype) = string (rtype) | decimal_mask;
1466           else
1467                string (rtype) = string (rtype) & ^decimal_mask | binary_mask;
1468 
1469           if ^as_if_type (1).complex & ^as_if_type (2).complex then
1470                string (rtype) = string (rtype) | real_mask;
1471           else
1472                string (rtype) = string (rtype) & ^real_mask | complex_mask;
1473 
1474           string (type) = string (rtype);
1475 
1476           do i = 1 to 2;
1477                call convert_arg;
1478           end;
1479 
1480           if rtype.float & arg_number = 4 then
1481                call semantic_translator$abort (167, builtin_symbol);
1482 
1483           if arg_number = 4 then
1484                rscale = constant_value (arg_symbol (4));
1485 
1486           rprecision = constant_value (arg_symbol (3));
1487 
1488           if rtype.decimal & rprecision > max_p_dec then
1489                goto err146;
1490 
1491           if rtype.fixed & rprecision > max_p_fix_bin_2 | rtype.float & rprecision > max_p_flt_bin_2 then
1492                goto err146;
1493 
1494           arg_number = 2;
1495 
1496           goto create_operator_node;
1497 
1498 action (15):                                                /* bin
1499    binary
1500    dec
1501    decimal */
1502           string (rtype) = pl1_data$builtin_name.description (builtin_number).descriptor (1).type | aligned_mask;
1503 
1504           if arg_number = 3 then
1505                rscale = constant_value (arg_symbol (3));
1506           else
1507                rscale = 0;
1508 
1509           if arg_number >= 2 then
1510                rprecision = constant_value (arg_symbol (2));
1511           else
1512                rprecision = 0;
1513 
1514           goto convert_to_arith;
1515 
1516 action (16):                                                /* ceil
1517    floor
1518    trunc */
1519           if arg_type (1).complex then
1520                goto err124;
1521 
1522           if arg_type (1).fixed then
1523                if arg_type (1).binary then
1524                     rprecision = min (max_p_fix_bin_2, max (rprecision - rscale + 1, 1));
1525                else
1526                     rprecision = min (max_p_dec, max (rprecision - rscale + 1, 1));
1527           rscale = 0;
1528 
1529           goto create_operator_node;
1530 
1531 action (17):                                                /* complex
1532    cplx */
1533           string (rtype) = "0"b;
1534 
1535           do i = 1 to 2;
1536                defined_as_if_type (i) = defined_arg_type (i);
1537 
1538                if as_if_type (i).bit then
1539                     defined_as_if_type (i) = fixed_binary_real_mask;
1540                else if as_if_type (i).char then
1541                     defined_as_if_type (i) = fixed_decimal_real_mask;
1542                else if as_if_type (i).picture then
1543                     if arg_symbol (i) -> symbol.pix.pic_float then
1544                          defined_as_if_type (i) = float_decimal_real_mask;
1545                     else
1546                          defined_as_if_type (i) = fixed_decimal_real_mask;
1547 
1548                if as_if_type (i).complex then
1549                     goto err124;
1550           end;
1551 
1552           if as_if_type (1).fixed & as_if_type (2).fixed then
1553                string (rtype) = string (rtype) | fixed_mask;
1554           else
1555                string (rtype) = string (rtype) & ^fixed_mask | float_mask;
1556 
1557           if as_if_type (1).decimal & as_if_type (2).decimal then
1558                string (rtype) = string (rtype) | decimal_mask;
1559           else
1560                string (rtype) = string (rtype) & ^decimal_mask | binary_mask;
1561 
1562           string (type) = string (rtype);
1563           string (rtype) = string (rtype) & ^real_mask | complex_mask;
1564 
1565           do i = 1 to 2;
1566                call convert_arg;
1567           end;
1568 
1569           p1 = arg_symbol (1) -> symbol.c_dcl_size;
1570           p2 = arg_symbol (2) -> symbol.c_dcl_size;
1571           q1 = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
1572           q2 = fixed (arg_symbol (2) -> symbol.scale, 31, 0);
1573 
1574           rscale = max (q1, q2);
1575 
1576           if rtype.fixed & rtype.binary then
1577                rprecision = min (max_p_fix_bin_2, max (p1 - q1, p2 - q2) + rscale);
1578           else
1579                rprecision = min (max_p_flt_bin_2, max (p1 - q1, p2 - q2) + rscale);
1580 
1581           if rtype.decimal then
1582                rprecision = min (max_p_dec, max (p1 - q1, p2 - q2) + rscale);
1583 
1584           goto create_operator_node;
1585 
1586 action (18):                                                /* bit
1587    char */
1588           string (rtype) = pl1_data$builtin_name.description (builtin_number).descriptor (1).type | aligned_mask;
1589 
1590           string_size_ck = "1"b;
1591 
1592           if arg_number = 2 then
1593                if symbol_is_constant (arg_symbol (2)) then do;
1594                     rprecision = constant_value (arg_symbol (2));
1595                     rlength = null;
1596                end;
1597                else do;
1598                     rprecision = 0;
1599                     rlength = copy_expression ((arg (2)));
1600                end;
1601 
1602           full_attribute_set = arg_number > 1;
1603 
1604           if arg (1) -> node.type = token_node then do;
1605                arg (1) = convert$from_builtin (arg (1), string (rtype));
1606                if ^full_attribute_set then
1607                     rprecision = arg (1) -> reference.c_length;
1608                opcode = assign;
1609                arg_number = 1;
1610 
1611                goto create_operator_node;
1612           end;
1613 
1614           goto convert_label;
1615 
1616 action (19):                                                /* imag
1617    real */
1618           string (rtype) = string (rtype) & ^complex_mask | real_mask;
1619 
1620           if ^def_context.arg_list then do;
1621                if arg_symbol (1) -> symbol.packed then
1622                     string (rtype) = string (rtype) & ^aligned_mask | unaligned_mask;
1623 
1624                t = declare_defined_overlay (string (rtype), rprecision, (rscale), rlength, arg (1));
1625                s = t -> reference.symbol;
1626 
1627                s -> symbol.boundary = arg_symbol (1) -> symbol.boundary;
1628 
1629                if def_context.left_side then
1630                     call propagate_bit (arg_symbol (1), set_bit);
1631 
1632                arg_symbol (1) -> symbol.overlayed_by_builtin = "1"b;
1633 
1634                if opcode = imag_fun /* imag */ then
1635                     if s -> symbol.decimal then do;
1636                          if s -> symbol.unaligned then do;
1637                               t -> reference.units = digit_;
1638                               t -> reference.c_offset = divide (s -> symbol.c_bit_size, bits_per_digit, 15, 0);
1639                          end;
1640                          else do;
1641                               t -> reference.units = character_;
1642                               t -> reference.c_offset = divide (s -> symbol.c_bit_size, bits_per_character, 15, 0);
1643                          end;
1644                     end;
1645                     else do;
1646                          if s -> symbol.packed then do;
1647                               t -> reference.units = bit_;
1648                               t -> reference.c_offset = s -> symbol.c_bit_size;
1649                          end;
1650                          else do;
1651                               t -> reference.units = word_;
1652                               t -> reference.c_offset = s -> symbol.c_word_size;
1653                          end;
1654                     end;
1655 
1656                if arg (1) -> node.type = operator_node then do;
1657                     r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
1658                          (statement_ptr -> statement.prefix));
1659                     r -> statement.root = share_expression (arg (1));
1660                     r -> statement.generated = "1"b;
1661 
1662                     ref (1) = arg (1) -> operand (1);
1663                end;
1664                else if arg (1) = arg_symbol (1) -> symbol.reference then
1665                     arg (1), ref (1) = copy_expression ((arg (1)));
1666 
1667                off = t -> reference.offset;
1668                coff = t -> reference.c_offset;
1669                cunits = t -> reference.units;
1670 
1671                call offset_adder (off, coff, cunits, "0"b, (ref (1) -> reference.offset), (ref (1) -> reference.c_offset),
1672                     (ref (1) -> reference.units), (ref (1) -> reference.modword_in_offset),
1673                     ref (1) -> reference.fo_in_qual);
1674 
1675                t -> reference.offset = off;
1676                t -> reference.c_offset = coff;
1677                t -> reference.units = cunits;
1678                ref (1) -> reference.offset = null;
1679                ref (1) -> reference.c_offset = 0;
1680                ref (1) -> reference.modword_in_offset = "0"b;
1681                ref (1) -> reference.inhibit = "1"b;
1682                t -> reference.qualifier = arg (1);
1683                t -> reference.fo_in_qual = ref (1) -> reference.fo_in_qual;
1684 
1685                if t -> reference.offset ^= null then do;
1686                     t -> reference.offset =
1687                          expression_semantics (cur_block, statement_ptr, (t -> reference.offset), "0"b);
1688                     call simplify_offset (t, "0"b);
1689                end;
1690 
1691 
1692                tree = t;
1693                goto ret;
1694           end;
1695 
1696           goto create_operator_node;
1697 
1698 action (20):                                                /* max
1699    min */
1700           string (rtype) = "0"b;
1701           rprecision, rscale = 0;
1702 
1703           do i = 1 to arg_number;
1704                defined_as_if_type (i) = defined_arg_type (i);
1705 
1706                if as_if_type (i).bit then
1707                     defined_as_if_type (i) = fixed_binary_real_mask;
1708                else if as_if_type (i).char then
1709                     defined_as_if_type (i) = fixed_decimal_real_mask;
1710                else if as_if_type (i).picture then
1711                     if arg_symbol (i) -> symbol.pix.pic_float then
1712                          defined_as_if_type (i) = float_decimal_real_mask;
1713                     else
1714                          defined_as_if_type (i) = fixed_decimal_real_mask;
1715 
1716                if as_if_type (i).complex then
1717                     goto err124;
1718           end;
1719 
1720           do i = 1 to arg_number;
1721                rtype.float = rtype.float | as_if_type (i).float;
1722                rtype.binary = rtype.binary | as_if_type (i).binary;
1723           end;
1724 
1725           if ^rtype.float then
1726                rtype.fixed = "1"b;
1727 
1728           if ^rtype.binary then
1729                rtype.decimal = "1"b;
1730 
1731           rtype.real = "1"b;
1732 
1733           string (type) = string (rtype);
1734 
1735           do i = 1 to arg_number;
1736                call convert_arg;
1737                rprecision = max (rprecision, arg_symbol (i) -> symbol.c_dcl_size);
1738                rscale = max (rscale, fixed (arg_symbol (i) -> symbol.scale, 31, 0));
1739           end;
1740 
1741           goto create_operator_node;
1742 
1743 action (21):                                                /* mod */
1744           string (rtype) = real_mask | aligned_mask;
1745           rprecision, rscale = 0;
1746 
1747           do i = 1 to 2;
1748                defined_as_if_type (i) = defined_arg_type (i);
1749 
1750                if as_if_type (i).bit then
1751                     defined_as_if_type (i) = fixed_binary_real_mask;
1752                else if as_if_type (i).char then
1753                     defined_as_if_type (i) = fixed_decimal_real_mask;
1754                else if as_if_type (i).picture then
1755                     if arg_symbol (i) -> symbol.pix.pic_float then
1756                          defined_as_if_type (i) = float_decimal_real_mask;
1757                     else
1758                          defined_as_if_type (i) = fixed_decimal_real_mask;
1759 
1760                if as_if_type (i).complex then
1761                     goto err124;
1762           end;
1763 
1764           if as_if_type (1).fixed & as_if_type (2).fixed then
1765                string (rtype) = string (rtype) | fixed_mask;
1766           else
1767                string (rtype) = string (rtype) & ^fixed_mask | float_mask;
1768 
1769           if as_if_type (1).decimal & as_if_type (2).decimal then
1770                string (rtype) = string (rtype) | decimal_mask;
1771           else
1772                string (rtype) = string (rtype) & ^decimal_mask | binary_mask;
1773 
1774           string (type) = string (rtype);
1775 
1776           do i = 1 to 2;
1777                call convert_arg;
1778           end;
1779 
1780           p1 = arg_symbol (1) -> symbol.c_dcl_size;
1781           p2 = arg_symbol (2) -> symbol.c_dcl_size;
1782           q1 = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
1783           q2 = fixed (arg_symbol (2) -> symbol.scale, 31, 0);
1784 
1785           rscale = max (q1, q2);
1786 
1787           if rtype.float then
1788                rprecision = max (p1, p2);
1789           else if rtype.binary then
1790                rprecision = min (max_p_fix_bin_2, p2 - q2 + rscale);
1791           else
1792                rprecision = min (max_p_dec, p2 - q2 + rscale);
1793 
1794           goto create_operator_node;
1795 
1796 action (22):                                                /* round */
1797           i = constant_value (arg_symbol (2));
1798 
1799           if rtype.fixed then do;
1800                if rtype.decimal then
1801                     rprecision =
1802                          max (1,
1803                          min (arg_symbol (1) -> symbol.c_dcl_size - arg_symbol (1) -> symbol.scale + 1 + i, max_p_dec));
1804                else
1805                     rprecision =
1806                          max (1,
1807                          min (arg_symbol (1) -> symbol.c_dcl_size - arg_symbol (1) -> symbol.scale + 1 + i,
1808                          max_p_fix_bin_2));
1809                rscale = i;
1810           end;
1811           if rtype.float then do;
1812                if i <= 0 then
1813                     call semantic_translator$abort (271, builtin_symbol);
1814 
1815                if rtype.decimal then
1816                     rprecision = min (i, max_p_dec);
1817                else
1818                     rprecision = min (i, max_p_flt_bin_2);
1819           end;
1820 
1821           goto create_operator_node;
1822 
1823 action (23):                                                /* bool */
1824           do i = 1 to 2;
1825                if ref (i) -> reference.varying_ref then
1826                     cur_length (i) = create_length_fun (arg (i));
1827                else if ref (i) -> reference.length ^= null then
1828                     cur_length (i) = share_expression ((ref (i) -> reference.length));
1829                else
1830                     cur_length (i) = null;
1831           end;
1832 
1833           if cur_length (1) = null & cur_length (2) = null then
1834                rprecision = max (ref (1) -> reference.c_length, ref (2) -> reference.c_length);
1835           else do;
1836                rprecision = 0;
1837                rlength = create_operator (max_fun, 3);
1838                rlength -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1839                rlength -> operand (2) = cur_length (1);
1840                rlength -> operand (3) = cur_length (2);
1841 
1842                if cur_length (1) = null then
1843                     rlength -> operand (2) = declare_constant$integer ((ref (1) -> reference.c_length));
1844 
1845                if cur_length (2) = null then
1846                     rlength -> operand (3) = declare_constant$integer ((ref (2) -> reference.c_length));
1847           end;
1848 
1849           if ^arg_symbol (3) -> symbol.constant then do;
1850                t = declare_temporary (bit_mask, 4, 0, null);
1851                arg (3) = convert$to_target (arg (3), t);
1852                goto create_operator_node;
1853           end;
1854 
1855           if rlength ^= null | rprecision > bits_per_double then
1856                goto create_operator_node;
1857 
1858           bit4 = substr (arg_symbol (3) -> symbol.initial -> based_type, 1, 4);
1859           not_flag = substr (bit4, 1, 1);
1860 
1861           if not_flag then
1862                bit4 = ^bit4;
1863 
1864           if bit4 = "0000"b then do;
1865                tree = create_operator (assign, 2);
1866                tree -> operand (2) = declare_constant$bit ("000000000000000000000000000000000000"b);
1867           end;
1868           else if bit4 = "0011"b then do;
1869                tree = create_operator (assign, 2);
1870                tree -> operand (2) = arg (1);
1871           end;
1872           else if bit4 = "0101"b then do;
1873                tree = create_operator (assign, 2);
1874                tree -> operand (2) = arg (2);
1875           end;
1876 
1877           else do;
1878                if bit4 = "0001"b then
1879                     opcode = and_bits;
1880                else if bit4 = "0111"b then
1881                     opcode = or_bits;
1882                else if bit4 = "0110"b then
1883                     opcode = xor_bits;
1884 
1885                else do;
1886                     opcode = and_bits;
1887 
1888                     if bit4 = "0100"b then
1889                          m = 1;
1890                     else
1891                          m = 2;
1892 
1893                     r = create_operator (assign, 2);
1894                     r -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1895                     r -> operand (2) = arg (m);
1896 
1897                     p = create_operator (not_bits, 2);
1898                     p -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1899                     p -> operand (2) = r;
1900 
1901                     arg (m) = p;
1902                end;
1903 
1904                tree = create_operator (opcode, 3);
1905                tree -> operand (2) = arg (1);
1906                tree -> operand (3) = arg (2);
1907           end;
1908 
1909           tree -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1910 
1911           if not_flag then do;
1912                p = create_operator (not_bits, 2);
1913                p -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1914                p -> operand (2) = tree;
1915 
1916                tree = p;
1917           end;
1918 
1919           goto ret;
1920 
1921 action (24):                                                /* decat */
1922           if arg_type (1).bit & arg_type (2).bit then
1923                string (type) = bit_mask;
1924           else do;
1925                string (type) = char_mask;
1926                reserved_number = reserved_number + 1;
1927           end;
1928 
1929           do i = 1 to 2;
1930                call convert_arg;
1931           end;
1932 
1933           string (type) = bit_mask;                         /* i will be 3 at this point */
1934           call convert_arg;
1935 
1936           do i = 1 to arg_number;
1937                if ref (i) -> reference.varying_ref then do;
1938                     length = create_length_fun (arg (i));
1939 
1940                     p = create_operator (assign, 2);
1941                     ref (i), p -> operand (1) = declare_temporary (string (rtype) & ^varying_mask, 0, 0, length);
1942                     p -> operand (2) = arg (i);
1943 
1944                     arg (i) = p;
1945                     arg_symbol (i) = ref (i) -> reference.symbol;
1946                end;
1947           end;
1948 
1949           desc_reqd = "1"b;
1950 
1951           goto create_call;
1952 
1953 action (25):                                                /* atanh
1954    cosh
1955    erf
1956    erfc
1957    sinh
1958    tanh */
1959           if arg_type (1).complex then
1960                reserved_number = reserved_number + 2;
1961 
1962           if rprecision > max_p_flt_bin_1 then
1963                reserved_number = reserved_number + 1;
1964 
1965           goto create_call;
1966 
1967 action (26):                                                /* dim
1968    hbound
1969    lbound */
1970           if arg_symbol (1) = null then
1971                call semantic_translator$abort (127, builtin_symbol);
1972 
1973           if arg_symbol (1) -> node.type = label_node then do;
1974                                                             /* bug 2193: Error 127 is printed when the first argument
1975                          to hbound is not an array value */
1976                if ^(arg_symbol (1) -> label.array) then
1977                     call semantic_translator$abort (127, builtin_symbol);
1978                if reserved_number = 1 then
1979                     number = arg_symbol (1) -> label.low_bound;
1980                else if reserved_number = 2 then
1981                     number = arg_symbol (1) -> label.high_bound;
1982                else
1983                     number = arg_symbol (1) -> label.high_bound - arg_symbol (1) -> label.low_bound + 1;
1984 
1985                tree = declare_constant (unspec (number), integer_type, max_offset_precision, 0);
1986 
1987                goto ret;
1988           end;
1989 
1990           if arg_symbol (1) -> symbol.array = null then
1991                call semantic_translator$abort (127, builtin_symbol);
1992 
1993           if arg_symbol (1) -> symbol.defined then
1994                arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);
1995 
1996           p = arg_symbol (1) -> symbol.array;
1997 
1998           if ^symbol_is_constant (arg_symbol (2)) then do;
1999                ref (3), arg (3) = declare_constant$integer ((p -> array.number_of_dimensions));
2000                arg_symbol (3) = arg (3) -> reference.symbol;
2001 
2002                ref (4), arg (4) = declare_constant$integer (reserved_number);
2003                arg_symbol (4) = arg (4) -> reference.symbol;
2004 
2005                reserved_number = 6;
2006                arg_number = 4;
2007                string (rtype) = fixed_binary_real_mask;
2008                rprecision = max_offset_precision;
2009                rscale = 0;
2010 
2011                goto create_call;
2012           end;
2013 
2014           integer = constant_value (arg_symbol (2));
2015 
2016           if integer > p -> array.number_of_dimensions | integer < 1 then
2017                call semantic_translator$abort (128, builtin_symbol);
2018 
2019           p = p -> array.bounds;
2020           do i = 1 to arg_symbol (1) -> symbol.array -> array.number_of_dimensions - integer;
2021                p = p -> bound.next;
2022           end;
2023 
2024           if p -> bound.lower ^= null then do;
2025                call simplify_expression ((p -> bound.lower), constant, modified);
2026                if modified then do;
2027                     p -> bound.c_lower = constant;
2028                     p -> bound.lower = null;
2029                end;
2030           end;
2031 
2032           if p -> bound.upper ^= null then do;
2033                call simplify_expression ((p -> bound.upper), constant, modified);
2034                if modified then do;
2035                     p -> bound.c_upper = constant;
2036                     p -> bound.upper = null;
2037                end;
2038           end;
2039 
2040           if reserved_number = 1 then
2041                if p -> bound.lower = null then do;
2042                     tree = declare_constant (unspec (p -> bound.c_lower), integer_type, max_offset_precision, 0);
2043                     goto ret;
2044                end;
2045                else do;
2046                     tree = copy_expression (p -> bound.lower);
2047                     tree = fill_refer (tree, (ref (1) -> reference.qualifier), "1"b);
2048                     tree = expression_semantics (cur_block, statement_ptr, tree, this_context);
2049 
2050                     arg (1) = tree;
2051                     goto create_assign;
2052                end;
2053 
2054           if reserved_number = 2 then
2055                if p -> bound.upper = null then do;
2056                     tree = declare_constant (unspec (p -> bound.c_upper), integer_type, max_offset_precision, 0);
2057                     goto ret;
2058                end;
2059                else do;
2060                     tree = copy_expression (p -> bound.upper);
2061                     tree = fill_refer (tree, (ref (1) -> reference.qualifier), "1"b);
2062                     tree = expression_semantics (cur_block, statement_ptr, tree, this_context);
2063 
2064                     arg (1) = tree;
2065                     goto create_assign;
2066                end;
2067 
2068           if p -> bound.upper = null & p -> bound.lower = null then do;
2069                number = p -> bound.c_upper - p -> bound.c_lower + 1;
2070                tree = declare_constant (unspec (number), integer_type, max_offset_precision, 0);
2071 
2072                goto ret;
2073           end;
2074 
2075           arg (1) = copy_expression (p -> bound.upper);
2076           if arg (1) = null then
2077                arg (1) = declare_constant$integer ((p -> bound.c_upper));
2078           else do;
2079                arg (1) = fill_refer (arg (1), (ref (1) -> reference.qualifier), "1"b);
2080 
2081                if arg (1) -> node.type = token_node then
2082                     arg (1) = expression_semantics (cur_block, statement_ptr, arg (1), "0"b);
2083 
2084                if arg (1) -> node.type = reference_node then
2085                     if arg (1) -> reference.symbol -> symbol.arg_descriptor then do;
2086                          t = create_operator (assign, 2);
2087                          t -> operand (1) = declare_temporary (integer_type, max_offset_precision, 0, null);
2088                          t -> operand (2) = arg (1);
2089                          arg (1) = t;
2090                     end;
2091           end;
2092 
2093           arg (2) = copy_expression (p -> bound.lower);
2094           if arg (2) = null then
2095                arg (2) = declare_constant$integer (p -> bound.c_lower - 1);
2096           else do;
2097                arg (2) = fill_refer (arg (2), (ref (1) -> reference.qualifier), "1"b);
2098 
2099                if arg (2) -> node.type = token_node then
2100                     arg (2) = expression_semantics (cur_block, statement_ptr, arg (2), "0"b);
2101 
2102                if arg (2) -> node.type = reference_node then
2103                     if arg (2) -> reference.symbol -> symbol.arg_descriptor then do;
2104                          t = create_operator (assign, 2);
2105                          t -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
2106                          t -> operand (2) = arg (2);
2107                          arg (2) = t;
2108                     end;
2109 
2110                p = create_operator (sub, 3);
2111                p -> operand (1) = declare_temporary (fixed_binary_real_mask, max_offset_precision, 0, null);
2112                p -> operand (2) = arg (2);
2113                p -> operand (3) = declare_constant$integer (1);
2114 
2115                arg (2) = p;
2116           end;
2117 
2118           do i = 1 to 2;
2119                arg (i) = expression_semantics (cur_block, statement_ptr, arg (i), "0"b);
2120           end;
2121 
2122           string (rtype) = fixed_binary_real_mask;
2123           rprecision = max_offset_precision;
2124           rscale = 0;
2125 
2126           goto create_operator_node;
2127 
2128 action (27):                                                /* reverse */
2129           if check_reverse (arg (1)) then do;               /* reverse (reverse (..)) */
2130                tree = arg (1) -> operator.operand (2);
2131                go to ret;
2132           end;
2133           if is_this_constant (arg (1)) then do;
2134                constant_string_length = arg (1) -> reference.c_length;
2135                if arg_type (1).bit then
2136                     tree = declare_constant$bit (reverse (arg_symbol (1) -> symbol.initial -> constant_bit_string));
2137                else
2138                     tree = declare_constant$char (reverse (arg_symbol (1) -> symbol.initial -> constant_char_string));
2139                go to exit;
2140           end;
2141           if ref (1) -> reference.c_length = 1 then do;     /* reverse of 1 doesn't reverse */
2142                tree = arg (1);
2143                go to ret;
2144           end;
2145           goto create_operator_node;
2146 
2147 action (28):                                                /* empty */
2148           if pl1_stat_$cur_statement -> statement.root -> operand (2) ^= tree
2149                & pl1_stat_$cur_statement -> statement.root -> operand (2) ^= tree -> reference.symbol -> symbol.token then
2150                call semantic_translator$abort (187, builtin_symbol);
2151 
2152           arg (2) = pl1_stat_$cur_statement -> statement.root -> operand (1);
2153           arg_symbol (2) = arg (2) -> reference.symbol;
2154 
2155           if string (arg_symbol (2) -> symbol.data_type) = "0"b then do;
2156                arg_symbol (2) -> symbol.area = "1"b;
2157                arg_symbol (2) -> symbol.c_dcl_size, arg_symbol (2) -> symbol.c_word_size = min_area_size;
2158                integer_24 = min_area_size;
2159           end;
2160           else if ^arg_symbol (2) -> symbol.area then
2161                call semantic_translator$abort (188, arg (2));
2162           else if arg_symbol (2) -> symbol.dcl_size = null then
2163                integer_24 = arg_symbol (2) -> symbol.c_dcl_size;
2164           else
2165                integer_24 = 0;                              /* this will get reset anyway if dcl_size^=0      */
2166 
2167 
2168           if arg_symbol (2) -> symbol.structure then
2169                call semantic_translator$abort (265, arg_symbol (2));
2170 
2171           if arg (2) -> reference.array_ref then do;
2172                t = expand_primitive (cur_block, statement_ptr, arg (2), "0"b);
2173 
2174                do r = t repeat t -> operand (1) while (r -> operand (1) -> node.type = operator_node);
2175                end;
2176 
2177                arg (2) = r -> operand (1);
2178           end;
2179           else
2180                r = null;
2181 
2182           if ^pl1_stat_$use_old_area then do;
2183                p = create_operator (empty_area, 2);         /* op(1) of empty is the area, op(2) is its size */
2184                p -> operand (1) = arg (2);
2185                if integer_24 ^= 0 then
2186                     p -> operand (2) = declare_constant$integer ((integer_24));
2187                else do;
2188                     q = copy_expression (arg_symbol (2) -> symbol.dcl_size);
2189 
2190                     if arg_symbol (2) -> symbol.refer_extents then
2191                          q = fill_refer (q, (arg (2) -> reference.qualifier), "1"b);
2192 
2193                     q = expression_semantics (cur_block, statement_ptr, q, "0"b);
2194                     p -> operand (2) = q;
2195                end;
2196           end;
2197 
2198           else do;
2199 
2200                p = create_operator (copy_words, 3);
2201                p -> operand (1) = arg (2);
2202                p -> operand (2) = declare_constant$bit ((84)"0"b || bit (integer_24, 24) || (36)"0"b);
2203                p -> operand (3) = declare_constant$integer (4);
2204 
2205                if arg_symbol (2) -> symbol.dcl_size ^= null then do;
2206                     if arg (2) -> reference.offset ^= null | arg (2) -> reference.c_offset ^= 0 then do;
2207                                                             /* not to destroy the offsets of arg(2) used in copy_words */
2208                          q = create_reference (null);
2209                          q -> reference = arg (2) -> reference;
2210                          arg (2) = q;
2211                          if ^q -> reference.shared then do;
2212                               q -> reference.ref_count = 0;
2213                               if q -> reference.offset ^= null then
2214                                    q -> reference.offset = copy_expression (q -> reference.offset);
2215                               if q -> reference.qualifier ^= null then
2216                                    q -> reference.qualifier = copy_expression (q -> reference.qualifier);
2217                          end;
2218                     end;
2219 
2220                     q = create_operator (assign, 2);
2221                     q -> operand (1) = declare_integer (cur_block);
2222                     q -> operand (2) = copy_expression (arg_symbol (2) -> symbol.dcl_size);
2223 
2224                     if arg_symbol (2) -> symbol.refer_extents then
2225                          q -> operand (2) = fill_refer ((q -> operand (2)), (arg (2) -> reference.qualifier), "1"b);
2226 
2227                     q -> operand (2) = expression_semantics (cur_block, p, (q -> operand (2)), "0"b);
2228 
2229                     arg (2) = expression_semantics (cur_block, statement_ptr, arg (2), "0"b);
2230 
2231                     q -> operand (1) -> reference.units = word_;
2232                     q -> operand (1) -> reference.offset = arg (2) -> reference.offset;
2233                     q -> operand (1) -> reference.c_offset = arg (2) -> reference.c_offset + 2;
2234 
2235                     q -> operand (1) -> reference.qualifier = copy_expression ((arg (2)));
2236 
2237                     arg (2) -> reference.offset = null;
2238                     arg (2) -> reference.c_offset = 0;
2239 
2240                     q -> operand (1) -> reference.symbol -> symbol.defined,
2241                          q -> operand (1) -> reference.symbol -> symbol.position,
2242                          q -> operand (1) -> reference.symbol -> symbol.overlayed, q -> operator.processed = "1"b;
2243 
2244                     q -> operand (1) -> reference.shared, q -> operand (1) -> reference.symbol -> symbol.auto = "0"b;
2245                     q -> operand (1) -> reference.ref_count = 1;
2246 
2247 
2248                     tree = create_operator (join, 2);
2249                     tree -> operand (1) = p;
2250                     tree -> operand (2) = q;
2251 
2252                     p = tree;
2253                end;
2254           end;
2255 
2256           if r ^= null then do;
2257                r -> operand (1) = p;
2258                tree = t;
2259           end;
2260           else
2261                tree = p;
2262 
2263 
2264           def_context.return_from_empty = "1"b;
2265 
2266           goto ret;
2267 
2268 action (29):                                                /* null */
2269           p = null;
2270           tree = declare_constant (unspec (p), pointer_type, 0, 0);
2271 
2272           goto exit;
2273 
2274 action (30):                                                /* lineno
2275    pageno */
2276           if def_save_context.aggregate then
2277                goto err124;
2278           if def_context.left_side then do;
2279                tree = create_operator (std_call, 3);
2280                tree -> operand (2) = reserve$declare_lib (reserved_number - 7);
2281                tree -> operand (3) = create_operator (std_arg_list, 3);
2282                tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 6, 0, null);
2283                tree -> operand (3) -> operand (2) = create_list (2);
2284                tree -> operand (3) -> operand (2) -> element (1) = arg (1);
2285 
2286                tree -> operand (3) -> operand (2) -> element (2) =
2287                     convert$to_integer ((pl1_stat_$cur_statement -> statement.root -> operand (2)), integer_type);
2288 
2289                def_context.return_from_empty = "1"b;
2290 
2291                goto ret;
2292           end;
2293 
2294           rprecision = max_p_fix_bin_1;
2295           string (rtype) = integer_type;
2296 
2297           goto create_call;
2298 
2299 action (31):                                                /* date */
2300           string (rtype) = char_mask;
2301           rprecision = 6;
2302 
2303           goto create_call;
2304 
2305 action (32):                                                /* time */
2306           string (rtype) = char_mask;
2307           rprecision = 12;
2308 
2309           goto create_call;
2310 
2311 action (33):                                                /* addr */
2312           if arg (1) -> node.type ^= reference_node & pl1_stat_$check_ansi then
2313                call semantic_translator$abort (132, builtin_symbol);
2314           else if arg (1) -> reference.temp_ref then
2315                call semantic_translator$error (299, builtin_symbol);
2316                                                             /* temp must mean an expression */
2317 
2318           if arg_symbol (1) -> symbol.constant then
2319                if arg_symbol (1) -> symbol.initial ^= null then
2320                     call semantic_translator$abort (132, builtin_symbol);
2321 
2322           call propagate_bit (arg_symbol (1), aliasable_bit);
2323           call propagate_bit (arg_symbol (1), set_bit);
2324           if arg_symbol (1) -> symbol.cross_references ^= null then
2325                arg_symbol (1) -> symbol.cross_references -> cross_reference.set_reference = "0"b;
2326                                                             /* Arg of "addr" is not considered a set xref */
2327 
2328           if arg_symbol (1) -> symbol.defined & (arg (1) -> reference.array_ref | arg_symbol (1) -> symbol.structure)
2329           then do;
2330                arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);
2331                if arg (1) -> reference.offset ^= null then
2332                     arg (1) -> reference.offset =
2333                          expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.offset), "0"b);
2334           end;
2335 
2336           if arg (1) -> reference.units < word_ & arg (1) -> reference.units ^= 0 | arg (1) -> reference.fo_in_qual then
2337                opcode = addr_fun_bits;
2338 
2339           goto prepare_pointer;
2340 
2341 action (34):                                                /* pointer
2342    ptr */
2343           if def_save_context.aggregate then
2344                goto err124;
2345           if arg_type (1).offset then
2346                if ^arg_type (2).area then
2347                     call semantic_translator$abort (437, arg (2));
2348                else
2349                     goto prepare_pointer;
2350 
2351           if ^arg_type (1).ptr then
2352                call semantic_translator$abort (438, arg (1));
2353 
2354           if pl1_stat_$check_ansi then
2355                call semantic_translator$error (172, builtin_symbol);
2356 
2357           if ^arg_type (1).aligned then do;
2358                p = create_operator (assign, 2);
2359                p -> operand (1) = declare_temporary (pointer_type, 0, 0, null);
2360                p -> operand (2) = arg (1);
2361                arg (1) = p;
2362           end;
2363 
2364           if arg_type (2).bit then do;
2365                i = 2;
2366                string (type) = bit_mask;
2367                call convert_arg;
2368 
2369                goto prepare_pointer;
2370           end;
2371 
2372           if arg_type (2).char | defined_arg_type (2) & arithmetic_mask then do;
2373                i = 2;
2374                string (type) = fixed_binary_real_mask;
2375                call convert_arg;
2376 
2377                goto prepare_pointer;
2378           end;
2379           else
2380                call semantic_translator$abort (436, arg (2));
2381 
2382 action (35):                                                /* offset */
2383           if def_save_context.aggregate then
2384                goto err124;
2385           string (rtype) = offset_mask;
2386 
2387           goto create_operator_node;
2388 
2389 action (36):                                                /* allocation */
2390           if arg_symbol (1) -> symbol.father ^= null | ^arg_symbol (1) -> symbol.controlled then
2391                call semantic_translator$abort (124, builtin_symbol);
2392 
2393 /* prevent evaluation of a length expression when allocation = 0
2394              (fixes bug 1645) */
2395 
2396           if ^arg (1) -> reference.shared then
2397                arg (1) -> reference.length = null;
2398 
2399           string (rtype) = integer_type;
2400           rprecision = default_fix_bin_p;
2401           rscale = 0;
2402           rlength = null;
2403 
2404           goto create_operator_node;
2405 
2406 action (37):                                                /* search
2407    verify */
2408           if check_reverse (arg (1)) then do;
2409                arg (1) = arg (1) -> operator.operand (2);
2410                if opcode = search_fun then
2411                     opcode = search_rev_fun;
2412                else
2413                     opcode = verify_rev_fun;
2414           end;
2415 
2416           string (rtype) = fixed_binary_real_mask;
2417           rprecision = max_length_precision;
2418 
2419           goto create_operator_node;
2420 
2421 action (38):                                                /* sign */
2422           if rtype.complex then
2423                goto err124;
2424 
2425           string (rtype) = fixed_binary_real_mask;
2426           rprecision = default_fix_bin_p;
2427           rscale = 0;
2428 
2429           goto create_operator_node;
2430 
2431 action (39):                                                /* baseno
2432    rel */
2433           if def_save_context.aggregate then
2434                goto err124;
2435           if ^arg_type (1).ptr then
2436                goto err124;
2437 
2438           string (rtype) = bit_mask;
2439           rprecision = 18;
2440 
2441           goto create_operator_node;
2442 
2443 action (70):                                                /* segno */
2444           rprecision = 15;
2445           go to pointer_decomp_common;
2446 action (71):                                                /* wordno */
2447           rprecision = 18;
2448           go to pointer_decomp_common;
2449 action (72):                                                /* charno */
2450           rprecision = 21;
2451           go to pointer_decomp_common;
2452 action (73):                                                /* bitno */
2453           rprecision = 24;
2454 
2455 pointer_decomp_common:
2456           if def_save_context.aggregate then
2457                goto err124;
2458           if ^arg_type (1).ptr then
2459                goto err124;
2460 
2461           string (rtype) = fixed_binary_real_mask;
2462           rscale = 0;
2463           rlength = null;
2464 
2465           goto create_operator_node;
2466 
2467 action (74):                                                /* setcharno ... addbitno */
2468           if def_save_context.aggregate then
2469                goto err124;
2470 
2471           go to prepare_pointer;
2472 
2473 action (40):                                                /* stac */
2474           string (rtype) = bit_mask;
2475           rprecision = 1;
2476 
2477           goto create_operator_node;
2478 
2479 action (41):                                                /* addrel
2480    baseptr */
2481           if def_save_context.aggregate then
2482                goto err124;
2483           goto prepare_pointer;
2484 
2485 action (42):                                                /* onfield
2486    onfile
2487    onkey
2488    onloc */
2489           arg (1) = declare_temporary (char_mask, 256, 0, null);
2490           arg_symbol (1) = arg (1) -> reference.symbol;
2491 
2492           desc_reqd = "1"b;
2493 
2494           goto create_call;
2495 
2496 action (43):                                                /* prod
2497    sum */
2498           if arg_symbol (1) = null then
2499                call semantic_translator$abort (127, builtin_symbol);
2500 
2501           if arg_type (1).bit then do;
2502                string (rtype) = fixed_binary_real_mask;
2503                rprecision = max_p_fix_bin_2;
2504                rscale = 0;
2505           end;
2506           else if arg_type (1).char then do;
2507                string (rtype) = fixed_decimal_real_mask;
2508                rprecision = max_p_dec;
2509                rscale = 0;
2510           end;
2511           else if arg_type (1).picture then do;
2512                rprecision = arg_symbol (1) -> symbol.pix.pic_size;
2513                rscale = arg_symbol (1) -> symbol.pix.pic_scale;
2514                if arg_type (1).complex then
2515                     if arg_symbol (1) -> symbol.pix.pic_float then
2516                          string (rtype) = float_decimal_complex_mask;
2517                     else
2518                          string (rtype) = fixed_decimal_complex_mask;
2519                else if arg_symbol (1) -> symbol.pix.pic_float then
2520                     string (rtype) = float_decimal_real_mask;
2521                else
2522                     string (rtype) = fixed_decimal_real_mask;
2523           end;
2524 
2525           if rtype.fixed then
2526                if opcode = mult & rscale ^= 0 then do;
2527                     if rtype.binary then
2528                          rprecision = max_p_flt_bin_2;
2529                     else
2530                          rprecision = max_p_dec;
2531                     rscale = 0;
2532                     string (type), string (rtype) = string (rtype) & ^fixed_mask | float_mask;
2533                end;
2534                else if rtype.binary then
2535                     rprecision = max_p_fix_bin_2;
2536                else
2537                     rprecision = max_p_dec;
2538 
2539           if arg (1) -> node.type ^= operator_node then
2540                arg (1) = expand_primitive (cur_block, statement_ptr, arg (1), "0"b);
2541 
2542           if arg (1) -> operator.op_code ^= loop then
2543                call semantic_translator$abort (127, builtin_symbol);
2544 
2545 product:
2546           p = arg (1);
2547           do while (p -> operand (1) -> node.type = operator_node);
2548                if p -> operand (1) -> operator.op_code = loop then
2549                     p = p -> operand (1);
2550                else
2551                     goto leave;
2552           end;
2553 
2554 leave:
2555           r = create_operator (opcode, 3);
2556           r -> operand (3) = p -> operand (1);
2557 
2558           q = create_operator (assign, 2);
2559           q -> operand (2) = r;
2560 
2561           t = create_symbol (cur_block, null, by_compiler);
2562           substr (string (t -> symbol.attributes), 1, 36) = string (rtype) & undesirable_mask & ^unaligned_mask;
2563           t -> symbol.c_dcl_size = rprecision;
2564           t -> symbol.scale = rscale;
2565           t -> symbol.auto, t -> symbol.precision, t -> symbol.allocate = "1"b;
2566 
2567           call declare (t);
2568 
2569           t = t -> symbol.reference;
2570 
2571           q -> operand (1), r -> operand (2) = t;
2572 
2573           p -> operand (1) = expression_semantics (cur_block, statement_ptr, q, this_context);
2574 
2575           r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
2576                (statement_ptr -> statement.prefix));
2577           r -> statement.generated = "1"b;
2578 
2579           p = create_operator (assign, 2);
2580           p -> operand (1) = t;
2581           if opcode = add then
2582                p -> operand (2) = create_token ("0", dec_integer);
2583           else
2584                p -> operand (2) = create_token ("1", dec_integer);
2585 
2586           r -> statement.root = operator_semantics (cur_block, r, p, this_context);
2587 
2588           r = create_statement (assignment_statement, r, null, (r -> statement.prefix));
2589           r -> statement.generated = "1"b;
2590           r -> statement.root = operator_semantics (cur_block, r, arg (1), this_context);
2591 
2592           tree = t;
2593 
2594           goto ret;
2595 
2596 action (44):                                                /* nullo */
2597           i = -1;
2598           tree = declare_constant (unspec (i), offset_mask, 0, 0);
2599 
2600           goto exit;
2601 
2602 action (45):                                                /* dot */
2603           p = create_operator (mult, 3);
2604           p -> operand (2) = arg (1);
2605           p -> operand (3) = arg (2);
2606 
2607           p = expand_infix (cur_block, statement_ptr, p, "0"b);
2608 
2609           if p -> operator.op_code ^= loop then
2610                call semantic_translator$abort (190, builtin_symbol);
2611           if p -> operand (1) -> operator.op_code ^= mult then
2612                call semantic_translator$abort (190, builtin_symbol);
2613 
2614           r = p -> operand (1) -> operand (1);
2615           string (rtype) = string (r -> reference.symbol -> symbol.attributes);
2616           rprecision = constant_value (arg_symbol (3));
2617           if arg_number = 4 then
2618                rscale = constant_value (arg_symbol (4));
2619 
2620           arg (1) = p;
2621 
2622           goto product;
2623 
2624 action (46):                                                /* convert */
2625           arith_size_ck, string_size_ck = "1"b;
2626 
2627           if def_save_context.aggregate then
2628                goto err124;
2629           if arg (1) -> node.type ^= reference_node then
2630                goto err124;
2631 
2632           tree = convert$to_target_fb (arg (2), arg (1));
2633 
2634           goto ret;
2635 
2636 action (47):                                                /* size */
2637 action (64):                                                /* currentsize */
2638           if arg (1) -> node.type ^= reference_node then
2639                goto err124;
2640           if arg (1) -> reference.symbol -> symbol.father ^= null then
2641                goto err124;
2642 
2643           p = arg (1) -> reference.symbol -> symbol.word_size;
2644 
2645           if p = null then
2646                tree =
2647                     declare_constant (unspec (arg (1) -> reference.symbol -> symbol.c_word_size), integer_type,
2648                     max_offset_precision, 0);
2649           else do;
2650                tree = copy_expression ((p));
2651                if jump_index = 64 then
2652                     if arg_symbol (1) -> symbol.refer_extents then
2653                          call refer_extent (tree, (arg (1) -> reference.qualifier));
2654 
2655                tree =
2656                     expression_semantics ((arg (1) -> reference.symbol -> symbol.block_node), statement_ptr, tree,
2657                     this_context);
2658                arg (1) = tree;
2659 
2660                goto create_assign;
2661           end;
2662 
2663           goto ret;
2664 
2665 action (48):                                                /* valid */
2666           if def_save_context.aggregate then
2667                goto err124;
2668           if arg (1) -> node.type ^= reference_node then
2669                goto err124;
2670           if ^arg_symbol (1) -> symbol.picture then
2671                goto err124;
2672 
2673           string (rtype) = bit_mask;
2674           rprecision = 1;
2675 
2676           arg_number = 2;
2677           arg (2) = arg_symbol (1) -> symbol.general;
2678           if arg (2) -> node.type ^= reference_node then
2679                call semantic_translator$abort (440, arg_symbol (1));
2680 
2681           goto create_call;
2682 
2683 action (49):                                                /* translate */
2684           goto create_operator_node;
2685 
2686 action (50):                                                /* conjg */
2687           goto create_operator_node;
2688 
2689 action (51):                                                /* onchar */
2690           string (rtype) = char_mask;
2691           rprecision = 1;
2692 
2693           goto create_call;
2694 
2695 action (52):                                                /* onsource */
2696           goto action (42);
2697 
2698 make_call:                                                  /* this code is entered only for onsource & onchar pseudovariables */
2699           if pl1_stat_$cur_statement -> statement.root -> operand (1) ^= input_tree
2700                & pl1_stat_$cur_statement -> statement.root -> operand (1)
2701                ^= input_tree -> reference.symbol -> symbol.token then
2702                if pl1_stat_$cur_statement -> statement.root -> op_code = assign then
2703                     call semantic_translator$abort (187, builtin_symbol);
2704                else
2705                     arg (1) = null;                         /*   get list(onchar | onsource);   */
2706 
2707           else do;                                          /*   onsource | onchar = ...;   */
2708                def_context.return_from_empty = "1"b;
2709                arg (1) =
2710                     expression_semantics (cur_block, statement_ptr,
2711                     (pl1_stat_$cur_statement -> statement.root -> operand (2)), "0"b);
2712 
2713                if arg (1) -> node.type = token_node then
2714                     arg (1) = convert (arg (1), char_mask);
2715 
2716                if arg (1) -> node.type = operator_node then
2717                     ref (1) = arg (1) -> operand (1);
2718                else
2719                     ref (1) = arg (1);
2720           end;
2721 
2722           if arg (1) = null | jump_index = 52 /*   get list(onchar|onsource);  |  onsource = ...;   */ then do;
2723                s = create_symbol (cur_block, null, by_compiler);
2724                s -> symbol.char, s -> symbol.auto, s -> symbol.passed_as_arg, s -> symbol.reference -> reference.shared =
2725                     "1"b;
2726 
2727                if jump_index = 52 then do;
2728                     s -> symbol.varying = "1"b;
2729                     s -> symbol.c_dcl_size = 256;
2730                end;
2731                else
2732                     s -> symbol.c_dcl_size = 1;
2733 
2734                s -> symbol.reference -> reference.c_length = s -> symbol.c_dcl_size;
2735 
2736                call declare (s);
2737 
2738                if ^def_context.return_from_empty then
2739                     arg (1) = s -> symbol.reference;
2740                else do;
2741                     p = create_operator (assign, 2);
2742                     p -> operand (1) = s -> symbol.reference;
2743                     p -> operand (2) = arg (1);
2744 
2745                     p -> operand (1) -> reference.c_length = t -> operand (1) -> reference.c_length;
2746                     p -> operand (1) -> reference.length = share_expression ((t -> operand (1) -> reference.length));
2747 
2748                     q = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
2749                          (statement_ptr -> statement.prefix));
2750                     q -> statement.root = p;
2751 
2752                     arg (1) = p -> operand (1);
2753                end;
2754           end;
2755 
2756           tree = create_operator (std_call, 3);
2757           tree -> operand (2) = reserve$declare_lib ((reserved_number));
2758           tree -> operand (3) = create_operator (std_arg_list, 3);
2759           tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 4, 0, null);
2760           tree -> operand (3) -> operand (2) = create_list (1);
2761           tree -> operand (3) -> operand (2) -> element (1) = arg (1);
2762 
2763           if ^def_context.return_from_empty then do;
2764                p = tree;
2765                tree = create_operator (join, 3);
2766                tree -> operand (1) = create_operator (assign, 2);
2767                tree -> operand (1) -> operand (1) = share_expression (arg (1));
2768                tree -> operand (1) -> operand (2) = share_expression (t);
2769                                                             /*   result of create_call, to get_onchar or to getonsource   */
2770                tree -> operand (2) = share_expression (arg (1));
2771                tree -> operand (3) = p;
2772           end;
2773 
2774           goto exit;
2775 
2776 action (53):                                                /* oncode */
2777           string (rtype) = integer_type;
2778           rprecision = default_fix_bin_p;
2779 
2780           goto create_call;
2781 
2782 action (54):                                                /* acos
2783    asin
2784    atan
2785    atand
2786    cos
2787    cosd
2788    exp
2789    log
2790    log10
2791    log2
2792    sin
2793    sind
2794    sqrt
2795    tan
2796    tand */
2797           if arg_number > 1 then
2798                rprecision = max (rprecision, arg_symbol (2) -> symbol.c_dcl_size);
2799 
2800           if arg_type (1).complex then
2801                goto action (25);
2802 
2803           goto create_operator_node;
2804 
2805 action (55):                                                /* after */
2806           if arg_type (1).bit & arg_type (2).bit then
2807                string (type) = bit_mask;
2808           else
2809                string (type) = char_mask;
2810 
2811           do i = 1 to 2;
2812                call convert_arg;
2813           end;
2814 
2815 make_add:
2816           offset = create_operator (add, 3);
2817           offset -> operand (2) = create_index_or_verify ();
2818           offset -> operand (3) = declare_constant$integer (1);
2819 
2820           tree = make_builtin_reference ("substr", 2, arg (1), offset, null);
2821           go to exit;
2822 
2823 action (56):                                                /* before */
2824           if arg_type (1).bit & arg_type (2).bit then
2825                string (type) = bit_mask;
2826           else
2827                string (type) = char_mask;
2828 
2829           do i = 1 to 2;
2830                call convert_arg;
2831           end;
2832 
2833           tree = make_builtin_reference ("substr", 3, arg (1), declare_constant$integer (1), create_index_or_verify ());
2834           go to exit;
2835 
2836 action (57):                                                /* ltrim */
2837           if arg_number = 1 then
2838                arg (2) = declare_constant$char (" ");       /* <blank> */
2839 
2840           go to make_add;
2841 
2842 action (58):                                                /* rtrim */
2843           if arg_number = 1 then
2844                arg (2) = declare_constant$char (" ");       /* <blank> */
2845 
2846           if ref (1) -> reference.varying_ref then
2847                p = create_length_fun (arg (1));
2848           else if ref (1) -> reference.length = null then
2849                p = declare_constant$integer ((ref (1) -> reference.c_length));
2850           else
2851                p = share_expression ((ref (1) -> reference.length));
2852 
2853           length = create_operator (sub, 3);
2854           length -> operand (2) = p;
2855           length -> operand (3) = create_index_or_verify ();
2856 
2857           tree = make_builtin_reference ("substr", 3, arg (1), declare_constant$integer (1), length);
2858           go to exit;
2859 
2860 action (59):                                                /* collate9 */
2861           tree = declare_constant$char (pl1_data$long_collating_sequence);
2862 
2863           goto ret;
2864 
2865 action (60):                                                /* high9 */
2866           arg (2) = arg (1);
2867           ref (2) = ref (1);
2868           arg_symbol (2) = arg_symbol (1);
2869 
2870           arg (1), ref (1) = declare_constant ("111111111"b, char_type, 1, 0);
2871           arg_symbol (1) = ref (1) -> reference.symbol;
2872 
2873           arg_number = 2;
2874           string (rtype) = char_type;
2875 
2876           goto repeat;
2877 
2878 action (61):                                                /* stackbaseptr */
2879                                                             /* stackframeptr */
2880           go to prepare_pointer;
2881 
2882 action (62):                                                /* clock */
2883                                                             /* vclock */
2884           string (rtype) = integer_type;
2885           rprecision = 71;
2886           go to create_operator_node;
2887 
2888 action (63):                                                /* codeptr */
2889                                                             /* environmentptr */
2890           go to prepare_pointer;
2891 
2892 action (66):                                                /* stacq */
2893           string (rtype) = bit_mask;
2894           rprecision = 1;
2895           go to create_operator_node;
2896 
2897 action (67):                                                /* substraddr */
2898           go to err359;
2899 
2900 action (68):                                                /* byte */
2901           string (rtype) = char_type;
2902           rprecision = 1;
2903           go to create_operator_node;
2904 
2905 action (69):                                                /* rank */
2906           if ^constant_length (ref (1), 1) then
2907                call semantic_translator$abort (390, arg_symbol (1));
2908                                                             /* first arg to rank must be char(1) */
2909 
2910           string (rtype) = integer_type;
2911           rprecision = 9;
2912           go to create_operator_node;
2913 ^L
2914 prepare_pointer:
2915           rprecision, rscale = 0;
2916 
2917           rlength = null;
2918 
2919           string (rtype) = pointer_type;
2920 
2921           goto create_operator_node;
2922 
2923 create_call:
2924           p = create_list (arg_number + 1);
2925           do i = 1 to arg_number;
2926                p -> element (i) = arg (i);
2927           end;
2928 
2929           tree = create_operator (std_call, 3);
2930           tree -> operand (2) = reserve$declare_lib ((reserved_number));
2931 
2932           if jump_index = 24 /* decat */ | jump_index = 25 /* math bifs */ | jump_index = 26 /* lbound, hbound, dim */
2933           then do;
2934                tree -> operand (2) -> reference.symbol -> symbol.irreducible = "0"b;
2935                tree -> operand (2) -> reference.symbol -> symbol.reducible = "1"b;
2936           end;
2937 
2938           tree -> operand (3) = create_operator (std_arg_list, 3);
2939           tree -> operand (3) -> operand (2) = p;
2940 
2941           if desc_reqd then do;
2942 
2943 /* we will have star extents return value */
2944 
2945                tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 4 * arg_number + 6, 0, null);
2946                q, tree -> operand (3) -> operand (3) = create_list (arg_number + 1);
2947 
2948                s = create_symbol (cur_block, null, by_compiler);
2949 
2950                string (s -> symbol.data_type) = string (arg_symbol (1) -> symbol.data_type);
2951                string (s -> symbol.misc_attributes) = string (arg_symbol (1) -> symbol.misc_attributes);
2952 
2953                s -> symbol.dimensioned, s -> symbol.initialed, s -> symbol.variable, s -> symbol.position,
2954                     s -> symbol.internal, s -> symbol.external, s -> symbol.like, s -> symbol.member = "0"b;
2955 
2956                s -> symbol.return_value, s -> symbol.passed_as_arg, s -> symbol.star_extents = "1"b;
2957 
2958                s -> symbol.dcl_size = create_token ("*", asterisk);
2959 
2960                call declare (s);
2961 
2962                q -> element (arg_number + 1) = s -> symbol.descriptor;
2963 
2964                do i = 1 to arg_number;
2965                     q -> element (i) =
2966                          declare_descriptor (cur_block, statement_ptr, arg_symbol (i), (ref (i) -> reference.qualifier),
2967                          "0"b);
2968                end;
2969 
2970                p -> element (p -> list.number), tree -> operand (1) = s -> symbol.reference;
2971 
2972                tree -> operand (1) -> reference.ref_count = 3;
2973                tree -> operand (1) -> reference.shared = "0"b;
2974                tree -> operand (1) -> reference.length -> operand (1) =
2975                     declare_temporary (integer_type, max_offset_precision, 0, null);
2976                tree -> operand (1) -> reference.length -> operator.processed = "1"b;
2977 
2978                call check_star_extents ((tree -> operand (2) -> reference.symbol), p);
2979 
2980                statement_ptr -> statement.force_nonquick = "1"b;
2981                call make_non_quick ((statement_ptr -> statement.root), "001"b);
2982 
2983                p = create_statement (call_statement, (statement_ptr -> statement.back), null,
2984                     (statement_ptr -> statement.prefix));
2985                p -> statement.root = tree;
2986                p -> statement.processed = "1"b;
2987           end;
2988           else do;
2989                t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
2990                s = copy_expression (t -> reference.symbol);
2991                s -> symbol.passed_as_arg = "1"b;
2992                q = s -> symbol.reference;
2993                q -> reference.shared = "0"b;
2994                q -> reference.ref_count = 2;
2995 
2996                p -> element (p -> list.number), tree -> operand (1) = q;
2997 
2998                temp_size = 2 * (arg_number + 1) + 2;
2999 
3000                if jump_index = 26 /*   hbound, lbound, dim   */ then do;
3001 
3002 /* this has star_extent args but constant extent return_value */
3003 
3004                     temp_size = 4 * (arg_number + 1) + 2;
3005 
3006                     tree -> operand (3) -> operand (3), q = create_list (arg_number + 1);
3007 
3008                     ref (5) = q;
3009                     arg_symbol (5) = s;
3010 
3011                     do i = 1 to q -> list.number;
3012                          q -> element (i) =
3013                               declare_descriptor (cur_block, statement_ptr, arg_symbol (i),
3014                               (ref (i) -> reference.qualifier), (ref (i) -> reference.array_ref));
3015                     end;
3016                end;
3017 
3018                tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, temp_size, 0, null);
3019           end;
3020 
3021           if def_context.left_side /*   only onchar and onsource has this property   */ then do;
3022                if jump_index = 51 /*   onchar   */ then
3023                     reserved_number = 11;                   /*   on_data_$set_onchar   */
3024                else
3025                     reserved_number = 194;                  /*   on_data_$setonsource   */
3026 
3027                tree -> operand (2) -> reference.symbol -> symbol.irreducible = "1"b;
3028                t = tree;
3029 
3030                goto make_call;
3031           end;
3032 
3033           goto exit;
3034 
3035 create_assign:
3036           t = create_operator (assign, 2);
3037           t -> operand (1) = declare_temporary (integer_type, max_offset_precision, 0, null);
3038           t -> operand (2) = arg (1);
3039 
3040           tree = t;
3041 
3042           goto exit;
3043 
3044 convert_to_arith:
3045           arith_size_ck = "1"b;                             /* This makes us check size-enabled after assign_op  is made */
3046           string (rtype) = string (rtype) | aligned_mask;
3047 
3048           if arg_type (1).char then
3049                defined_arg_type (1) = fixed_decimal_real_mask;
3050           else if arg_type (1).bit then
3051                defined_arg_type (1) = fixed_binary_real_mask;
3052           else if arg_type (1).picture then
3053                if arg_symbol (1) -> symbol.complex then
3054                     if arg_symbol (1) -> symbol.pix.pic_float then
3055                          defined_arg_type (1) = float_decimal_complex_mask;
3056                     else
3057                          defined_arg_type (1) = fixed_decimal_complex_mask;
3058                else if arg_symbol (1) -> symbol.pix.pic_float then
3059                     defined_arg_type (1) = float_decimal_real_mask;
3060                else
3061                     defined_arg_type (1) = fixed_decimal_real_mask;
3062 
3063           if ^rtype.fixed & ^rtype.float then do;
3064                rtype.fixed = arg_type (1).fixed;
3065                rtype.float = arg_type (1).float;
3066           end;
3067 
3068           if ^rtype.decimal & ^rtype.binary then do;
3069                rtype.decimal = arg_type (1).decimal;
3070                rtype.binary = arg_type (1).binary;
3071           end;
3072 
3073           if ^rtype.real & ^rtype.complex then do;
3074                rtype.real = arg_type (1).real;
3075                rtype.complex = arg_type (1).complex;
3076           end;
3077 
3078           full_attribute_set = arg_number > 1;
3079 
3080 check_prec_scale:
3081           rlength = null;
3082 
3083           if rscale < min_scale | rscale > max_scale then
3084                goto err146;
3085 
3086           if rtype.decimal then
3087                if rprecision > max_p_dec then
3088                     goto err146;
3089                else
3090                     ;
3091 
3092           else if rtype.fixed then
3093                if rprecision > max_p_fix_bin_2 then
3094                     goto err146;
3095                else
3096                     ;
3097           else if rprecision > max_p_flt_bin_2 then
3098                goto err146;
3099 
3100 convert_label:
3101           if rprecision < 0 then
3102                goto err481;
3103 
3104           if full_attribute_set then do;
3105                t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
3106                tree = convert$to_target_fb (arg (1), t);
3107           end;
3108           else
3109                tree = convert$from_builtin (arg (1), string (rtype));
3110 
3111           goto ret;
3112 
3113 create_operator_node:
3114           if rprecision < 0 then
3115                goto err481;
3116 
3117           t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
3118 
3119           tree = create_operator (opcode, arg_number + 1);
3120           tree -> operand (1) = t;
3121 
3122           do i = 1 to arg_number;
3123                tree -> operand (i + 1) = arg (i);
3124           end;
3125 
3126           tree -> operator.processed = "1"b;
3127 
3128           goto exit;
3129 
3130 return_arg1:
3131           tree = arg (1);
3132 
3133           goto ret;
3134 ^L
3135 expand_arguments:
3136      proc () returns (ptr);
3137 
3138           dcl      (p, q, r) ptr,
3139                    (lpp, jpp) ptr init (null),
3140                    (lp, jp, cp) (128) ptr init ((128) null),
3141                    (i, j, k, lll) fixed bin (15),
3142                    (jcount, lcount) fixed bin (15) init (0),
3143                    ll (128) fixed bin (15) init ((128) 0);
3144 
3145           dcl      (full_processing, pure_array) bit (1) aligned init ("0"b);
3146 
3147           do i = 1 to arg_number;
3148                p = subscripts -> element (i);
3149 
3150                if p -> node.type = operator_node then
3151                     if p -> op_code = loop then do;
3152                          lp (i) = p;
3153                          lcount = lcount + 1;
3154 
3155                          do q = p repeat q -> operand (1) while (q -> op_code = loop);
3156                               ll (i) = ll (i) + 1;
3157                          end;
3158 
3159                          p = q;
3160 
3161                          if lpp = null then do;
3162                               lpp = lp (i);
3163                               lll = ll (i);
3164                          end;
3165                     end;
3166 
3167                if p -> node.type = operator_node then
3168                     if p -> op_code = join then do;
3169                          jp (i) = p;
3170                          jcount = jcount + 1;
3171                     end;
3172 
3173                if jp (i) ^= null then
3174                     if jpp = null then
3175                          jpp = p;
3176                     else
3177                          ;
3178                else
3179                     cp (i) = p;
3180 
3181                if lp (i) ^= null & cp (i) ^= null then
3182                     pure_array = "1"b;
3183           end;
3184 
3185           if lpp ^= null then
3186                do i = 1 to arg_number;
3187                     if ll (i) ^= lll & ll (i) ^= 0 then
3188                          call semantic_translator$abort (79, null);
3189                end;
3190 
3191           if pure_array then
3192                if jpp ^= null then
3193                     call semantic_translator$abort (79, null);
3194                else do;
3195                     p = create_list ((arg_number));
3196                     do i = 1 to arg_number;
3197                          p -> element (i) = cp (i);
3198                     end;
3199 
3200                     p = builtin (cur_block, statement_ptr, tree, p, builtin_symbol, "0"b);
3201                end;
3202 
3203           if jpp ^= null then
3204                jpp = merge (jpp, jp);
3205 
3206           if lpp = null then
3207                return (jpp);
3208 
3209           q = lpp;
3210 
3211           do i = 2 to lll;
3212                q = q -> operand (1);
3213           end;
3214 
3215           if jpp ^= null then
3216                q -> operand (1) = jpp;
3217           else
3218                q -> operand (1) = p;
3219 
3220           if lcount = 1 then
3221                return (lpp);
3222 
3223           do i = 1 to arg_number;
3224 
3225                p = lpp;
3226                q = lp (i);
3227 
3228                if q ^= null & q ^= p then
3229                     do j = 1 to lll;
3230 
3231                          if ^compare_expression ((p -> operand (4)), (q -> operand (4))) then do;
3232                               if p -> operand (4) -> node.type = reference_node then
3233                                    if p -> operand (4) -> reference.symbol -> symbol.constant then
3234                                         if q -> operand (4) -> node.type = reference_node then
3235                                              if q -> operand (4) -> reference.symbol -> symbol.constant then
3236                                                   call semantic_translator$abort (79, null);
3237 
3238                               full_processing = "1"b;
3239                          end;
3240 
3241                          p = p -> operand (1);
3242                          q = q -> operand (1);
3243                     end;
3244           end;
3245 
3246           if ^full_processing then
3247                return (lpp);
3248 
3249           if lcount = 2 then do;
3250                p = lpp;
3251                q = null;
3252 
3253                do i = arg_number to 1 by -1 while (q = null);
3254                     q = lp (i);
3255                end;
3256 
3257                do i = 1 to lll;
3258 
3259                     jpp = create_operator (bound_ck, 4);
3260                     jpp -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
3261                     jpp -> operand (2) = p -> operand (4);
3262                     jpp -> operand (3) = q -> operand (4);
3263                     jpp -> operand (4) = share_expression ((q -> operand (4)));
3264 
3265                     p -> operand (4) = jpp;
3266                     p = p -> operand (1);
3267                     q = q -> operand (1);
3268                end;
3269 
3270                return (lpp);
3271           end;
3272 
3273           r = lpp;
3274 
3275           do i = 1 to lll;
3276 
3277                jpp = create_operator (bound_ck, 4);
3278                p = create_operator (min_fun, lcount + 1);
3279                q = create_operator (max_fun, lcount + 1);
3280                p -> operand (1), q -> operand (1), jpp -> operand (1) =
3281                     declare_temporary (integer_type, default_fix_bin_p, 0, null);
3282                jpp -> operand (2) = p;
3283                jpp -> operand (3) = q;
3284                jpp -> operand (4) = share_expression (q);
3285 
3286                r -> operand (4) = jpp;
3287                r = r -> operand (1);
3288 
3289                k = 2;
3290 
3291                do j = 1 to arg_number;
3292                     if lp (j) ^= null then do;
3293                          p -> operand (k) = share_expression ((lp (j) -> operand (4)));
3294                          q -> operand (k) = share_expression ((lp (j) -> operand (4)));
3295 
3296                          k = k + 1;
3297                          lp (j) = lp (j) -> operand (1);
3298                     end;
3299                end;
3300           end;
3301 
3302           return (lpp);
3303 ^L
3304 merge:
3305      proc (p, rp) returns (ptr);
3306 
3307           dcl      (
3308                    p,
3309                    pp,
3310                    q,
3311                    o1,
3312                    o2,
3313                    o3,
3314                    rp (128),
3315                    rpp (128)
3316                    ) ptr,
3317                    (i, j, k) fixed bin (15),
3318                    unmatch_bound bit (1) aligned init ("0"b);
3319 
3320           if p -> node.type = operator_node then do;
3321                if p -> op_code = loop then do;
3322                     do i = 1 to arg_number;
3323                          if cp (i) = null then do;
3324                               if rp (i) -> node.type ^= operator_node then
3325                                    call semantic_translator$abort (79, null);
3326                               if rp (i) -> op_code ^= loop then
3327                                    call semantic_translator$abort (79, null);
3328 
3329                               if ^compare_expression ((p -> operand (4)), (rp (i) -> operand (4))) then
3330                                    unmatch_bound = "1"b;
3331                          end;
3332                     end;
3333 
3334                     if unmatch_bound then do;
3335                          o1 = create_operator (bound_ck, 4);
3336                          o2 = create_operator (min_fun, jcount + 1);
3337                          o3 = create_operator (max_fun, jcount + 1);
3338 
3339                          o2 -> operand (1), o3 -> operand (1), o1 -> operand (1) =
3340                               declare_temporary (integer_type, default_fix_bin_p, 0, null);
3341                          o1 -> operand (2) = o2;
3342                          o1 -> operand (3) = o3;
3343                          o1 -> operand (4) = share_expression (o3);
3344 
3345                          k = 2;
3346 
3347                          do i = 1 to arg_number;
3348                               if cp (i) = null then do;
3349                                    o2 -> operand (k) = share_expression ((rp (i) -> operand (4)));
3350                                    o3 -> operand (k) = share_expression ((rp (i) -> operand (4)));
3351                                    k = k + 1;
3352                               end;
3353                          end;
3354 
3355                          p -> operand (4) = o1;
3356                     end;
3357 
3358                     pp = p -> operand (1);
3359 
3360                     do i = 1 to arg_number;
3361                          if cp (i) = null then
3362                               rpp (i) = rp (i) -> operand (1);
3363                     end;
3364 
3365                     p -> operand (1) = merge (pp, rpp);
3366 
3367                     return (p);
3368                end;
3369 
3370                if p -> op_code = join then do;
3371                     do i = 1 to arg_number;
3372                          if cp (i) = null then do;
3373                               if rp (i) -> node.type ^= operator_node then
3374                                    call semantic_translator$abort (79, null);
3375                               if rp (i) -> op_code ^= join then
3376                                    call semantic_translator$abort (79, null);
3377                          end;
3378                     end;
3379 
3380                     do j = 1 to p -> operator.number;
3381                          pp = p -> operand (j);
3382 
3383                          do i = 1 to arg_number;
3384                               if cp (i) = null then
3385                                    rpp (i) = rp (i) -> operand (j);
3386                               else if j > 1 then
3387                                    cp (i) = share_expression (cp (i));
3388                          end;
3389 
3390                          p -> operand (j) = merge (pp, rpp);
3391                     end;
3392 
3393                     return (p);
3394                end;
3395           end;
3396 
3397           do i = 1 to arg_number;
3398                if cp (i) = null then
3399                     if rp (i) -> node.type = operator_node then
3400                          if rp (i) -> op_code = loop | rp (i) -> op_code = join then
3401                               call semantic_translator$abort (79, null);
3402           end;
3403 
3404           q = create_list ((arg_number));
3405 
3406           do i = 1 to arg_number;
3407                if cp (i) = null then
3408                     q -> element (i) = rp (i);
3409                else
3410                     q -> element (i) = cp (i);
3411           end;
3412 
3413           return (builtin (cur_block, statement_ptr, tree, q, builtin_symbol, "0"b));
3414 
3415      end merge;
3416 
3417      end expand_arguments;
3418 ^L
3419 check_reverse:
3420      proc (p) returns (bit (1) aligned);
3421 
3422 /* See if pointer points to a call on reverse operator, unshared */
3423           dcl      p ptr;
3424 
3425           if p -> node.type = operator_node then
3426                if p -> operator.op_code = reverse_fun then
3427                     if p -> operator.operand (1) -> reference.shared
3428                          | p -> operator.operand (1) -> reference.ref_count = 1 then
3429                          return ("1"b);
3430           return ("0"b);
3431 
3432      end check_reverse;
3433 ^L
3434 is_this_constant:
3435      proc (p) returns (bit (1) aligned);
3436 
3437           dcl      p ptr;
3438 
3439           if p -> node.type = reference_node then
3440                if p -> reference.symbol -> symbol.constant then
3441                     if ^p -> reference.varying_ref then
3442                          if p -> reference.length = null & p -> reference.offset = null & p -> reference.c_offset = 0 then
3443                               return ("1"b);
3444           return ("0"b);
3445 
3446      end is_this_constant;
3447 ^L
3448 check_strings:
3449      proc (pt);
3450 
3451           dcl      (p, pt) ptr;
3452 
3453           p = pt;
3454 
3455           do while (p ^= null);
3456 
3457                if p -> symbol.structure then
3458                     call check_strings ((p -> symbol.son));
3459 
3460                else if units = bit_ & ^p -> symbol.bit | units = character_ & ^p -> symbol.char & ^p -> symbol.picture
3461                     then
3462                     call semantic_translator$abort (139, arg_symbol (1));
3463 
3464                p = p -> symbol.brother;
3465           end;
3466 
3467      end check_strings;
3468 ^L
3469 convert_arg:
3470      proc;
3471 
3472           dcl      suppress_diagnostic bit (1) aligned;
3473 
3474           if defined_arg_type (i) & structure_mask then
3475                return;
3476 
3477           if string (type) & arithmetic_mask then do;
3478                if defined_arg_type (i) & arithmetic_mask then
3479                     ;
3480                else if arg_type (i).bit then do;
3481                     type.fixed = ^type.float;
3482                     type.binary = ^type.decimal;
3483                     type.real = ^type.complex;
3484                end;
3485 
3486                else if arg_type (i).char then do;
3487                     type.fixed = ^type.float;
3488                     type.decimal = ^type.binary;
3489                     type.real = ^type.complex;
3490                end;
3491 
3492                if ^type.fixed & ^type.float then do;
3493                     type.fixed = arg_type (i).fixed;
3494                     type.float = arg_type (i).float;
3495                end;
3496 
3497                if ^type.decimal & ^type.binary then do;
3498                     type.decimal = arg_type (i).decimal;
3499                     type.binary = arg_type (i).binary;
3500                end;
3501 
3502                if ^type.real & ^type.complex then do;
3503                     type.real = arg_type (i).real;
3504                     type.complex = arg_type (i).complex;
3505                end;
3506           end;
3507 
3508           suppress_diagnostic = i = 1 & (jump_index = 17 | jump_index = 19);
3509 
3510           if arg (i) -> node.type = token_node then
3511                if suppress_diagnostic then
3512                     arg (i) = convert$from_builtin (arg (i), string (type));
3513                else
3514                     arg (i) = convert (arg (i), string (type));
3515 
3516           else if type.decimal & arg_type (i).decimal & ^arg_symbol (i) -> symbol.char then
3517                ;
3518           else if type.binary & arg_type (i).binary & type.real = arg_type (i).real & type.fixed = arg_type (i).fixed then
3519                ;
3520           else if suppress_diagnostic then
3521                arg (i) = convert$from_builtin (arg (i), string (type));
3522           else
3523                arg (i) = convert (arg (i), string (type));
3524 
3525           ref (i) = arg (i);
3526           defined_arg_type (i) = string (type);
3527 
3528           if ref (i) -> node.type = operator_node then do;
3529                ref (i) -> operator.processed = "1"b;        /* to prevent operator_semantics from calling convert$validate */
3530                ref (i) = ref (i) -> operand (1);
3531           end;
3532 
3533           arg_symbol (i) = ref (i) -> reference.symbol;
3534 
3535      end convert_arg;
3536 ^L
3537 make_assignment:
3538      proc;
3539 
3540           p = create_operator (assign, 2);
3541           r = create_symbol (null, null, by_compiler);
3542           r -> symbol.temporary = "1"b;
3543           p -> operand (1) = r -> symbol.reference;
3544           p -> operand (2) = arg (1);
3545 
3546           r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
3547                (statement_ptr -> statement.prefix));
3548           r -> statement.root = p;
3549           r -> statement.generated = "1"b;
3550 
3551           if arg (1) -> node.type = operator_node then
3552                if arg (1) -> operator.op_code = loop | arg (1) -> operator.op_code = join then do;
3553                     def_this_context.RHS_aggregate = "1"b;
3554 
3555                     r -> statement.root = expand_assign (cur_block, r, (r -> statement.root), this_context, agg_ref);
3556                     return;
3557                end;
3558 
3559           r -> statement.root = operator_semantics (cur_block, r, (r -> statement.root), this_context);
3560           agg_ref = r -> statement.root -> operand (1);
3561           if agg_ref -> reference.shared then do;
3562                agg_ref -> reference.shared = "0"b;
3563                agg_ref -> reference.ref_count = 1;
3564           end;
3565 
3566      end make_assignment;
3567 
3568 /*^L*/
3569 declare_defined_overlay:
3570      proc (p_type, p_precision, p_scale, p_length, qual) returns (ptr);
3571 
3572 /* pools defined overlays in a similar fashion as declare_temporary
3573              pools temporarys.  Used for unspec, string, imag, real */
3574 
3575           dcl      p_type bit (36) aligned,
3576                    (p_precision, precision) fixed bin (31),
3577                    (p_scale, scale) fixed bin (15),
3578                    (p_length, length) ptr,
3579                    qual ptr;
3580 
3581           dcl      units fixed bin (3);
3582           dcl      c_offset fixed bin (24);
3583           dcl      (r, s, t) ptr;
3584           dcl      pl1_stat_$defined_list ptr ext;
3585           dcl      (addr, null) builtin;
3586           dcl      bit36 bit (36) based (addr (s -> symbol.data_type));
3587           dcl      found bit (1) aligned;
3588 
3589 /* Assumption:  if length is not null, then length must not be an
3590              unshared processed tree, because otherwise ref_count goes too
3591              high */
3592 
3593           precision = p_precision;
3594           scale = p_scale;
3595           length = p_length;
3596 
3597 /* the qualifier's units and c_offset are used so that simplify_offset
3598              will correctly handle cases of substr(string(..),<expr>...) */
3599 
3600           if qual -> node.type = reference_node then do;
3601                units = qual -> reference.units;
3602                c_offset = qual -> reference.c_offset;
3603           end;
3604           else
3605                units, c_offset = 0;
3606 
3607           found = "0"b;
3608 
3609 /* search for suitable symbol */
3610 
3611           s = pl1_stat_$defined_list;
3612 
3613           do while (s ^= null & ^found);
3614                if bit36 = p_type & s -> symbol.position = "1"b & s -> symbol.c_dcl_size = precision
3615                     & s -> symbol.scale = scale & s -> symbol.dcl_size = length
3616                     & s -> symbol.reference -> reference.shared & s -> symbol.reference -> reference.c_offset = c_offset
3617                     & s -> symbol.reference -> reference.units = units then
3618                     found = "1"b;
3619                else
3620                     s = s -> symbol.multi_use;
3621           end;
3622 
3623           if ^found then do;
3624 
3625 /* None found -- make one with declare_temporary's help.
3626                   Note that although declare_temporary makes unshared
3627                   temporaries if length ^= null, that they are unique. */
3628 
3629                r = copy_expression (declare_temporary (p_type, precision, scale, length));
3630 
3631                s = create_symbol (null, null, by_compiler);
3632                t = r -> reference.symbol;
3633                s -> symbol = t -> symbol;
3634                s -> symbol.next = null;
3635                s -> symbol.reference = r;
3636                r -> reference.symbol = s;
3637                r -> reference.units = units;
3638                r -> reference.c_offset = c_offset;
3639 
3640                s -> symbol.packed = s -> symbol.unaligned;
3641                s -> symbol.defined, s -> symbol.overlayed, s -> symbol.position = "1"b;
3642                s -> symbol.temporary = "0"b;
3643 
3644                s -> symbol.multi_use = pl1_stat_$defined_list;
3645                pl1_stat_$defined_list = s;
3646           end;
3647 
3648 /* we need a unique reference node */
3649 
3650           r = copy_expression (s -> symbol.reference);
3651           r -> reference.shared = "0"b;
3652           r -> reference.ref_count = 1;
3653           r -> reference.units = 0;
3654           r -> reference.c_offset = 0;
3655 
3656           return (r);
3657 
3658      end;
3659 
3660 /* ^L subroutine to create a length_fun operator and return a ptr to it  */
3661 
3662 create_length_fun:
3663      proc (op2) returns (ptr);
3664 
3665           dcl      (op2, p) pointer;
3666           p = create_operator (length_fun, 2);
3667           p -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
3668           p -> operand (2) = share_expression (op2);
3669           p -> operator.processed = "1"b;
3670           return (p);
3671      end create_length_fun;
3672 
3673 
3674 
3675 
3676 
3677 
3678 /*  subroutine to increment a reference node's qualifier and offset's reference count     */
3679 
3680 reuse_qual_and_offset:
3681      proc (p_param);
3682 
3683           dcl      (p, p_param) ptr;
3684 
3685           p = p_param;
3686 
3687           if p -> reference.qualifier ^= null then
3688                p -> reference.qualifier = share_expression ((p -> reference.qualifier));
3689           if p -> reference.offset ^= null then
3690                p -> reference.offset = share_expression ((p -> reference.offset));
3691 
3692      end reuse_qual_and_offset;
3693 
3694 
3695 /* function to see if a symbol represents an unpacked real fixed binary integer value */
3696 
3697 fb1_value:
3698      proc (s) returns (bit (1) aligned);
3699 
3700           dcl      s ptr;
3701 
3702           if s -> symbol.fixed & s -> symbol.binary & ^s -> symbol.complex & ^s -> symbol.packed
3703                & s -> symbol.c_dcl_size <= max_p_fix_bin_1 & s -> symbol.scale = 0 then
3704                return ("1"b);
3705 
3706           else
3707                return ("0"b);
3708 
3709      end fb1_value;
3710 
3711 
3712 /* function to create an index or verify operator and operands for after, before, ltrim, or rtrim */
3713 
3714 create_index_or_verify:
3715      proc returns (ptr);
3716 
3717           dcl      p ptr;
3718 
3719           p = create_operator (opcode, 3);
3720           p -> operand (1) = declare_temporary (fixed_binary_real_mask, max_length_precision, 0, null);
3721           p -> operand (2) = share_expression (arg (1));
3722           p -> operand (3) = arg (2);
3723           p -> operator.processed = "1"b;
3724           return (p);
3725 
3726      end create_index_or_verify;
3727 
3728 /* get the initial value of a fixed binary integer variable with a scale factor of zero */
3729 
3730 constant_value:
3731      procedure (sym_ptr) returns (fixed bin (17));
3732 
3733 /* parameter */
3734 
3735           dcl      sym_ptr ptr;
3736 
3737 /* based */
3738 
3739           dcl      integer_1 based fixed bin (35);
3740           dcl      integer_2 based fixed bin (71);
3741 
3742 /* constant */
3743 
3744           dcl      max_24_bit_integer fixed bin (24) int static options (constant) init (111111111111111111111111b);
3745 
3746 /* builtin */
3747 
3748           dcl      abs builtin;
3749 
3750 /* automatic */
3751 
3752           dcl      initial_value fixed bin (71);
3753 
3754           dcl      convert builtin;
3755 
3756 /* Accept the constant's bit pattern. */
3757 
3758           if sym_ptr -> symbol.constant then
3759                if sym_ptr -> symbol.c_dcl_size > max_p_fix_bin_1 then
3760                     initial_value = sym_ptr -> symbol.initial -> integer_2;
3761                else
3762                     initial_value = sym_ptr -> symbol.initial -> integer_1;
3763 
3764 /* Convert the symbol's initializing token string. */
3765 
3766           else if sym_ptr -> symbol.alloc_in_text then
3767                if sym_ptr -> symbol.initial -> list.element (1) -> token.string = "1" then
3768                     initial_value =
3769                          convert (initial_value, sym_ptr -> symbol.initial -> list.element (2) -> token.string);
3770 
3771                else
3772                     initial_value = max_24_bit_integer + 1; /* ERROR */
3773           else
3774                initial_value = max_24_bit_integer + 1;      /* ERROR */
3775 
3776           if abs (initial_value) > max_24_bit_integer then
3777                go to err146;
3778 
3779           return (initial_value);
3780 
3781      end /* constant_value */;
3782 
3783 /* Return true if symbol is a constant. */
3784 
3785 symbol_is_constant:
3786      proc (sym_ptr) returns (bit (1));
3787 
3788           dcl      sym_ptr ptr;
3789 
3790           if sym_ptr -> symbol.constant | (sym_ptr -> symbol.alloc_in_text & sym_ptr -> symbol.array = null ()) then
3791                return ("1"b);
3792           else
3793                return ("0"b);
3794      end symbol_is_constant;                                /*^L*/
3795 make_builtin_reference:
3796      proc (builtin_name, nargs, arg1, arg2, arg3) returns (ptr);
3797 
3798 /* constructs a builtin reference and processes it.  the context given to builtin
3799    is passed through */
3800 
3801           dcl      builtin_name char (*),
3802                    nargs fixed bin (15),
3803                    (arg1, arg2, arg3) ptr;
3804 
3805           dcl      (p, s, subs) ptr;
3806           dcl      (i, n) fixed bin (15);
3807 
3808 /* since we don't know if the builtin is declared, we declare
3809              a special symbol in the root block */
3810 
3811           n = nargs;
3812           p = create_token ("cp.bif." || builtin_name, identifier);
3813 
3814           if p -> token.declaration = null then do;
3815 
3816 /* we must make a symbol */
3817 
3818                do i = number_of_names to 1 by -1 while (pl1_data$builtin_name (i).name ^= builtin_name);
3819                end;
3820 
3821                s = create_symbol ((pl1_stat_$root), p, by_compiler);
3822 
3823                s -> symbol.builtin = "1"b;
3824                s -> symbol.c_dcl_size = i;
3825                p -> token.declaration = s;
3826           end;
3827 
3828           else
3829                s = p -> token.declaration;
3830 
3831           subs = create_list (n);
3832           if n > 0 then do;
3833                subs -> element (n) = arg1;
3834                if n > 1 then do;
3835                     subs -> element (n - 1) = arg2;
3836                     if n > 2 then
3837                          subs -> element (n - 2) = arg3;
3838                end;
3839           end;
3840 
3841           return (builtin (cur_block, statement_ptr, (s -> symbol.reference), subs, s, context));
3842 
3843      end;
3844 
3845 /*   ^L   */
3846 err124:
3847           error_number = 124;
3848           goto abort;
3849 
3850 err146:
3851           error_number = 146;
3852           goto abort;
3853 
3854 err481:
3855           error_number = 481;
3856           goto abort;
3857 
3858 err359:
3859           error_number = 359;
3860           goto abort;
3861 
3862 err381:
3863           error_number = 381;
3864           goto abort;
3865 
3866 abort:
3867           call semantic_translator$abort (error_number, builtin_symbol);
3868 
3869 ret:
3870           if def_context.arg_list & tree -> node.type = reference_node & ^pseudo_variable then do;
3871                arg (1) = tree;
3872                string (rtype) = string (tree -> reference.symbol -> symbol.attributes);
3873                if jump_index ^= 46 /* we dont change result type for convert!   */ then
3874                     rtype.varying = "0"b;
3875                arg_number = 1;
3876                opcode = assign;
3877                goto create_operator_node;
3878           end;
3879 
3880           if arith_size_ck then                             /* since we will mark the operator as processed, we must do the */
3881                                                             /* work of op_semantics in changeing an assign to an assign_size_ck */
3882                                                             /* if size or stringrange are enabled and the left hand side of the  */
3883                                                             /* assignment is subject to the condition.        */
3884                if substr (statement_ptr -> statement.prefix, 6, 1) then
3885                     if arg_type (1).fixed | arg_type (1).float then
3886                          if tree -> node.type = operator_node then
3887                               if tree -> operator.op_code = assign then
3888                                    tree -> operator.op_code = assign_size_ck;
3889 
3890           if string_size_ck then
3891                if substr (statement_ptr -> statement.prefix, 9, 1) then
3892                     if arg_type (1).char | arg_type (1).bit then
3893                          if tree -> node.type = operator_node then
3894                               if tree -> operator.op_code = assign then
3895                                    tree -> operator.op_code = assign_size_ck;
3896 
3897 exit:
3898           if decimal_result then do;
3899                targ_type = targ_type & ^dimensioned_mask & ^initialed_mask;
3900                t = declare_temporary (targ_type, targ_prec, 0, null);
3901                tree = convert$to_target_fb (tree, t);
3902           end;
3903 
3904           if tree -> node.type = operator_node then
3905                tree -> operator.processed = "1"b;
3906           else
3907                tree -> reference.processed = "1"b;
3908 
3909           return (tree);
3910 
3911 /* include files */
3912 
3913 %include semant;
3914 %include array;
3915 %include block;
3916 %include boundary;
3917 %include builtin_table;
3918 %include cross_reference;
3919 %include decoded_token_types;
3920 %include declare_type;
3921 %include label;
3922 %include list;
3923 %include mask;
3924 %include nodes;
3925 %include operator;
3926 %include op_codes;
3927 %include reference;
3928 %include semantic_bits;
3929 %include statement;
3930 %include statement_types;
3931 %include symbol;
3932 %include pl1_symbol_type;
3933 %include symbol_bits;
3934 %include system;
3935 %include token;
3936 %include token_types;
3937 
3938      end builtin;