1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Bull Inc., 1987                *
   6         *                                                         *
   7         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   8         *                                                         *
   9         * Copyright (c) 1972 by Massachusetts Institute of        *
  10         * Technology and Honeywell Information Systems, Inc.      *
  11         *                                                         *
  12         *********************************************************** */
  13 
  14 
  15 
  16 
  17 /****^  HISTORY COMMENTS:
  18   1) change(86-07-15,Ginter), approve(86-07-15,MCR7287), audit(86-07-16,Mabey),
  19      install(86-07-28,MR12.0-1105):
  20      Bug fixes for the MR12.0 release of the compiler.
  21   2) change(87-04-15,RWaters), approve(87-04-15,MCR7635), audit(87-04-28,Huen),
  22      install(87-05-21,MR12.1-1033):
  23      Fix bug #2124
  24   3) change(89-02-28,RWaters), approve(89-02-28,MCR8068), audit(89-09-07,Vu),
  25      install(89-09-19,MR12.3-1068):
  26      Fix bug 1819.
  27                                                    END HISTORY COMMENTS */
  28 
  29 
  30 /* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
  31 expand_assign:
  32      proc (blk, stmnt, input_tree, context, agg_ref) returns (ptr);
  33 
  34 /* Modified 780619 by PG for unsigned */
  35 /* Modified 780814 by RAB to fix 1743 */
  36 /* Modified 790806 by RAB to fix 1841 (return((*) bit(*)) gets FATAL ERROR 310) */
  37 /* Modified 790807 by RAB to fix 1847 (bad descriptor built when char(*) varying
  38    promoted to array.  Bug caused by maker not setting symbol.exp_extents) */
  39 /* Modified: 17 Mar 1980 by PCK to implement by name assignment */
  40 /* Modified 830427 BIM to not check refer extents when the assignment */
  41 /*          is not an array assignment. */
  42 /* Modified 850607 MM to fix 2109 by name assignments to retain the token */
  43 /*          pointer from the original structure in any temporary structures */
  44 /*          that are generated in the assignment. */
  45 /* Modified 871504 RW to fix 2124 incompatible attributes in compiler variable */
  46 /* Modified 880101 RW diagnose passing a label array as a parameter */
  47 
  48 dcl      (agg_ref, blk, stmnt, tree, input_tree, a, b, s, sa, sb, t, p, q, qual, aqual, bqual) ptr,
  49          (a_for_return, sa_for_return) ptr,
  50          image ptr init (null);
  51 
  52 dcl      k fixed bin (15),                                  /* used by fill_desc and descendants */
  53          constant fixed bin,
  54          (have_varying, modified) bit (1) aligned,
  55          (cross_section, doing_return, no_data_type, interleaved) bit (1) init ("0"b) aligned;
  56 
  57 dcl      based_integer fixed bin (15) based;
  58 
  59 dcl      pl1_stat_$locator (128) ptr ext static;
  60 dcl      pl1_stat_$index fixed bin (15) ext static;
  61 
  62 dcl      (addr, string, fixed, hbound, null, substr) builtin;
  63 %page;
  64           s = stmnt;
  65           tree = input_tree;
  66 
  67           a = tree -> operand (1);
  68           b = tree -> operand (2);
  69 
  70           if a -> node.type ^= reference_node then
  71                if a -> node.type = operator_node then
  72                     if a -> op_code = loop | a -> op_code = join then
  73                          goto infix;
  74                     else
  75                          call semantic_translator$abort (90, null);
  76                else
  77                     call semantic_translator$abort (90, null);
  78 
  79           sa = a -> reference.symbol;
  80 
  81           if sa -> node.type ^= symbol_node then
  82                call semantic_translator$abort (91, null);
  83 
  84           if sa -> symbol.constant then
  85                call semantic_translator$abort (91, null);
  86 
  87           if a -> reference.array_ref then do;
  88                if sa -> symbol.array -> array.interleaved then
  89                     interleaved = "1"b;
  90 
  91                if a -> reference.offset ^= null then
  92                     if a -> reference.offset -> node.type = list_node then
  93                          cross_section = "1"b;
  94           end;
  95 
  96           if ^a -> reference.array_ref & ^sa -> symbol.structure & string (sa -> symbol.data_type) ^= "0"b then
  97                call semantic_translator$abort (93, b);
  98 
  99           if b -> node.type
 100                =
 101                token_node
 102                /* we need a symbol node for use now but real processing of this */
 103                /* token node will be done when op_semantics gets it later.                */ then
 104                b = convert (b, decoded_type (fixed (b -> token.type, 9)));
 105 
 106           if b -> node.type = reference_node then do;
 107                sb = b -> reference.symbol;
 108                qual = b -> reference.qualifier;
 109 
 110                if b -> reference.array_ref then do;
 111 
 112                     if sb -> node.type = label_node then    /* passing a label array as a prarmeter */
 113                          call semantic_translator$abort (83, b);
 114                     else if sb -> node.type ^= symbol_node then
 115                          call semantic_translator$abort (195, null);
 116                                                             /* somewhat inapropriate, but it shouldnt happen anyway */
 117 
 118                     if b -> reference.offset ^= null then
 119                          if b -> reference.offset -> node.type = list_node then
 120                               cross_section = "1"b;
 121 
 122                     if sb -> symbol.array -> array.interleaved then
 123                          interleaved = "1"b;
 124                end;
 125           end;
 126 
 127           if ^def_context.RHS_aggregate then
 128                goto check_context;
 129 
 130           if b -> node.type ^= reference_node then
 131                if b -> op_code = loop | b -> op_code = join then
 132                     sb, qual = null;
 133                else do;
 134 
 135 /* expression is an aggregate-valued function reference.
 136                                  This has been pulled out into its own statement, so
 137                                  we can replace the operator with its result in this
 138                                  tree. */
 139 
 140                     tree -> operand (2), b = b -> operand (1);
 141                     sb = b -> reference.symbol;
 142                end;
 143 
 144           if stmnt -> statement.LHS_in_RHS then do;
 145                stmnt -> statement.LHS_in_RHS = "0"b;
 146 
 147 /*   a(*) = . . .   */
 148                s = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
 149 
 150 /*   t0 = b   */
 151                q = create_operator (assign, 2);
 152                p = create_symbol (null, null, by_compiler);
 153                p -> symbol.temporary = "1"b;
 154                q -> operand (1) = p -> symbol.reference;
 155                q -> operand (2) = b;
 156 
 157                s -> statement.root = expand_assign (blk, s, q, context, image);
 158 
 159 /*   a = t0   */
 160                b, tree -> operand (2) = image;
 161                sb = b -> reference.symbol;
 162           end;
 163 
 164 /* If the left hand side (LHS) is a temporary with no data type, replace it with a
 165    temporary whose type and extents are given by the right hand side (RHS).  */
 166 
 167           if string (sa -> symbol.data_type) = "0"b then do;
 168                no_data_type = "1"b;
 169 
 170 /*   to = . . .   */
 171                if sb = null then
 172                     sb = declare_expression (b, null, 1);
 173 
 174                call maker (sb, sb, sa, "1"b, 1, b);
 175 
 176                tree -> operand (1), agg_ref, a = copy_expression (sa -> symbol.reference);
 177 
 178                if b -> node.type = reference_node then
 179                     a -> reference.array_ref = b -> reference.array_ref;
 180           end;
 181 
 182 check_context:
 183           if def_context.arg_list | def_context.return then do;
 184                if ^sa -> symbol.star_extents then do;
 185                     qual = a -> reference.qualifier;
 186                     call maker (sa, sa, t, "0"b, 1, null);
 187                end;
 188                else do;
 189                     if b -> node.type = operator_node then
 190                          if b -> operator.op_code ^= loop & b -> operator.op_code ^= join then do;
 191 
 192 /* we are promoting scalar expression to aggregate (fixes 1743) */
 193 
 194                               b = b -> operand (1);
 195                               sb = b -> reference.symbol;
 196                          end;
 197 
 198                     if sb = null then
 199                          sb = declare_expression (b, null, 1);
 200 
 201 
 202                     doing_return = def_context.return;
 203                     call maker (sa, sb, t, "0"b, 1, b);     /* pass sa to provide template for the temporary,
 204                                                                sb to fill in star_extents info.               */
 205                end;
 206 
 207                a_for_return = a;
 208                sa_for_return = sa;
 209 
 210                tree -> operand (1), agg_ref, a = copy_expression (t -> symbol.reference);
 211 
 212                sa = t;
 213 
 214                a -> reference.shared = "0"b;
 215                a -> reference.ref_count = 2;
 216 
 217                s = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
 218           end;
 219           else
 220                s = stmnt;
 221 
 222           if ^def_context.RHS_aggregate | def_context.by_name_assignment then
 223                goto infix;
 224 
 225           if b -> node.type ^= reference_node | cross_section | interleaved then
 226                goto infix;
 227 
 228           if ^compare_declaration (a, (b -> reference.symbol), "0"b) then
 229                goto infix;
 230 
 231 
 232           if sa -> symbol.defined | sb -> symbol.defined then
 233                goto infix;
 234 
 235           if a -> reference.array_ref ^= b -> reference.array_ref then
 236                goto infix;
 237 
 238           if a -> reference.array_ref then
 239                if substr (stmnt -> statement.prefix, 7, 1) then
 240                     if sa -> symbol.refer_extents then do;
 241                          aqual = a -> reference.qualifier;
 242                          bqual = b -> reference.qualifier;
 243                          call check_refers (sa, sb);
 244                     end;
 245 
 246           call process_offset (a);
 247           call process_offset (b);
 248 
 249           tree = make_copy (a, b);
 250 
 251           goto ret;
 252 
 253 infix:
 254           tree = expand_infix (blk, s, tree, context);
 255 
 256           goto ret;
 257 %page;
 258 ret:
 259           if def_context.arg_list then do;
 260                s -> statement.root = tree;
 261                return (t -> symbol.reference);
 262           end;
 263 
 264           if def_context.return then do;
 265                s -> statement.root = tree;
 266 
 267                if sa_for_return -> symbol.star_extents then do;
 268                     k = 0;
 269                     call fill_desc (sa);
 270 
 271 /* since the cg ignores the length expr when
 272                                  compiling the return_words or return_bits
 273                                  operators, and since prepare_operand expects
 274                                  to see processed length exprs or no length exprs,
 275                                  null the length expr */
 276 
 277                     a -> reference.length = null;
 278 
 279                     return (a);
 280                end;
 281 
 282                p = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
 283                p -> statement.root, tree = make_copy (a_for_return, a);
 284           end;
 285 
 286           return (tree);
 287 %page;
 288 process_offset:
 289      proc (pt);
 290 
 291 /* processes raw offset exprs */
 292 
 293 dcl      (pt, a, sa, p) ptr;
 294 dcl      i fixed bin;
 295 
 296           a = pt;
 297 
 298 /* since the code generator ignores the length expr when compiling
 299              the copy operators, and since prepare_operand expects to see
 300              either processed length exprs or null length exprs, null the
 301              length expr */
 302 
 303           a -> reference.length = null;
 304 
 305 /* now, process the offset expr , if any */
 306 
 307           if a -> reference.offset ^= null then
 308                if a -> reference.offset -> node.type = list_node then do;
 309                     p = a -> reference.offset;
 310 
 311                     do i = 1 to p -> list.number;
 312                          if p -> element (i) -> node.type = token_node then
 313                               if p -> element (i) -> token.type = asterisk then
 314                                    goto infix;
 315                     end;
 316 
 317                     if a -> reference.qualifier ^= null then do;
 318                          pl1_stat_$index = pl1_stat_$index + 1;
 319                          if pl1_stat_$index > hbound (pl1_stat_$locator, 1) then
 320                               call semantic_translator$abort (70, null);
 321                          pl1_stat_$locator (pl1_stat_$index) = a;
 322                     end;
 323 
 324                     sa = a -> reference.symbol;
 325                     a -> reference.offset = copy_expression (sa -> symbol.reference -> reference.offset);
 326                     a = subscripter (blk, s, a, p, sa);
 327 
 328                     if a -> reference.offset ^= null then do;
 329                          a -> reference.offset = expression_semantics (blk, s, (a -> reference.offset), "0"b);
 330                          a -> reference.offset = convert$to_integer ((a -> reference.offset), integer_type);
 331 
 332                          call simplify_offset (a, "0"b);
 333                     end;
 334 
 335                     if a -> reference.qualifier ^= null then
 336                          pl1_stat_$index = pl1_stat_$index - 1;
 337                end;
 338 
 339      end;
 340 %page;
 341 /* subroutine to check that refer array extents are compatable.   */
 342 
 343 check_refers:
 344      proc (asym, bsym);
 345 
 346 dcl      (asym, bsym, anext, bnext, abound, bbound, p, q) ptr;
 347 dcl      (own_bounds, processed_bounds) fixed bin;
 348 
 349           if asym -> symbol.array ^= null then do;
 350                processed_bounds = 0;
 351                bbound = bsym -> symbol.array -> array.bounds;
 352                own_bounds = asym -> symbol.array -> own_number_of_dimensions;
 353 
 354                do abound = asym -> symbol.array -> array.bounds repeat abound -> bound.next
 355                     while (processed_bounds < own_bounds);
 356                     if is_refer ((abound -> bound.upper)) then
 357                          if is_refer ((abound -> bound.lower)) then do;
 358                               p = subtract_bounds (abound);
 359                               q = subtract_bounds (bbound);
 360                               call make_check_stmnt (p, q);
 361                          end;
 362                          else
 363                               call make_check_stmnt (copy_expression (abound -> bound.upper),
 364                                    copy_expression (bbound -> bound.upper));
 365                     else if is_refer ((abound -> bound.lower)) then
 366                          call make_check_stmnt (copy_expression (abound -> bound.lower),
 367                               copy_expression (bbound -> bound.lower));
 368                     processed_bounds = processed_bounds + 1;
 369                     bbound = bbound -> bound.next;
 370                end;
 371           end;
 372 
 373           bnext = bsym -> symbol.son;
 374 
 375           do anext = asym -> symbol.son repeat anext -> symbol.brother while (anext ^= null);
 376                call check_refers (anext, bnext);
 377                bnext = bnext -> symbol.brother;
 378           end;
 379 
 380      end;
 381 %page;
 382 /* subroutine to test if a node is a refer operator node.   */
 383 
 384 is_refer:
 385      proc (p) returns (bit (1) aligned);
 386 
 387 dcl      p ptr;
 388 
 389           if p ^= null then
 390                if p -> node.type = operator_node then
 391                     if p -> operator.op_code = refer then
 392                          return ("1"b);
 393 
 394           return ("0"b);
 395 
 396      end;
 397 %page;
 398 /* subroutine to create an operator that subtracts the lower bound node from the upper bound node.   */
 399 
 400 subtract_bounds:
 401      proc (p) returns (ptr);
 402 
 403 dcl      (p, r) ptr;
 404 
 405           r = create_operator (sub, 3);
 406           r -> operator.operand (2) = copy_expression (p -> bound.upper);
 407           r -> operator.operand (3) = copy_expression (p -> bound.lower);
 408           return (r);
 409 
 410      end;
 411 %page;
 412 /* subroutine to create a bound_ck operator.   */
 413 
 414 make_check_stmnt:
 415      proc (p, q);
 416 
 417 dcl      (p, q, r) ptr;
 418 
 419           r = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
 420           r -> statement.root = create_operator (bound_ck, 4);
 421           call refer_extent (p, aqual);
 422           call refer_extent (q, bqual);
 423           r -> statement.root -> operator.operand (2) = p;
 424           r -> statement.root -> operator.operand (3) = q;
 425           r -> statement.root -> operator.operand (4) = copy_expression ((q));
 426           r -> statement.root = expression_semantics (blk, r, (r -> statement.root), "0"b);
 427      end;
 428 %page;
 429 /* subroutine to create assignments that fill in the descriptor of the left side.  */
 430 
 431 fill_desc:
 432      proc (sp);
 433 
 434 dcl      (sp, s, b) ptr;
 435 
 436           s = sp;
 437 
 438           call fill (s);
 439 
 440           if s -> symbol.dimensioned then do;
 441                do b = s -> symbol.array -> array.bounds repeat b -> bound.next while (b ^= null);
 442                     call fill (b);
 443                     k = k + 3;
 444                end;
 445           end;
 446 
 447           do b = s -> symbol.son repeat b -> symbol.brother while (b ^= null);
 448                k = k + 1;
 449                call fill_desc (b);
 450           end;
 451 %page;
 452 fill:
 453           proc (pt);
 454 
 455 dcl      (pt, p, r, q, dr, size, d_template) ptr;
 456 dcl      i fixed bin (15);
 457 
 458 %include pl1_descriptor;
 459 
 460                p = pt;
 461 
 462                if p -> node.type = symbol_node then do;
 463                     d_template =
 464                          sa_for_return -> symbol.descriptor -> reference.symbol -> symbol.descriptor -> symbol.initial;
 465                     if s -> symbol.bit | s -> symbol.char then do;
 466                          r = copy_expression (p -> symbol.reference);
 467                          r = expression_semantics (blk, stmnt, r, context);
 468                          if r -> reference.varying_ref then do;
 469                               if k > 0 | r -> reference.array_ref then do;
 470                                    if p -> symbol.dcl_size = null then
 471                                         size = declare_constant$integer ((p -> symbol.c_dcl_size));
 472                                    else do;
 473                                         size = copy_expression (p -> symbol.dcl_size);
 474                                         if p -> symbol.refer_extents then
 475                                              call refer_extent (size, (a_for_return -> reference.qualifier));
 476                                         size = expression_semantics (blk, stmnt, size, "0"b);
 477                                    end;
 478                               end;
 479                               else do;
 480                                    size = create_operator ((length_fun), 2);
 481                                    size -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
 482                                    size -> operand (2) = r;
 483                               end;
 484                          end;
 485                          else if r -> reference.length = null then
 486                               size = declare_constant$integer ((r -> reference.c_length));
 487                          else
 488                               size = r -> reference.length;
 489                          q = create_operator (make_desc, 3);
 490                          q -> operand (3) = size;
 491                          q -> operand (2) = declare_constant$desc (string (d_template -> descriptor (k).bit_type));
 492                     end;
 493                     else do;
 494                          q = create_operator (assign, 2);
 495                          q -> operand (2) = declare_constant$desc (string (d_template -> descriptor (k)));
 496                     end;
 497                     q -> operand (1), r = copy_expression (sa_for_return -> symbol.descriptor);
 498                     r -> reference.c_offset = k;
 499                     r -> reference.shared = "0"b;
 500                     r -> reference.ref_count = 1;
 501                     r = expression_semantics (blk, stmnt, r, context);
 502                     dr = create_statement (assignment_statement, (stmnt -> statement.back), null,
 503                          (stmnt -> statement.prefix));
 504                     dr -> statement.root = q;
 505                end;
 506                else do;
 507                     if p -> bound.lower = null then
 508                          p -> bound.lower = declare_constant$integer ((p -> bound.c_lower));
 509                     if p -> bound.upper = null then
 510                          p -> bound.upper = declare_constant$integer ((p -> bound.c_upper));
 511 
 512                     i = 0;
 513                     do r = p -> bound.lower, p -> bound.upper, p -> bound.desc_multiplier;
 514                          i = i + 1;
 515                          q = create_operator (assign, 2);
 516                          q -> operand (1), dr = copy_expression (sa_for_return -> symbol.descriptor);
 517                          dr -> reference.units = word_;
 518                          dr -> reference.c_offset = k + i;
 519                          r = copy_expression ((r));
 520                          if s -> symbol.refer_extents then
 521                               call refer_extent (r, (a_for_return -> reference.qualifier));
 522                          q -> operand (2) = expression_semantics (blk, stmnt, r, context);
 523                          dr = create_statement (assignment_statement, (stmnt -> statement.back), null,
 524                               (stmnt -> statement.prefix));
 525                          dr -> statement.root = q;
 526                     end;
 527                end;
 528 
 529           end fill;
 530 
 531      end fill_desc;
 532 %page;
 533 /* subroutine to create a copy operator.  */
 534 
 535 make_copy:
 536      proc (a, b) returns (ptr);
 537 
 538 dcl      (a, b, sb, p, q, ref, arrayp) ptr;
 539 dcl      opcode bit (9) aligned;
 540 
 541 /* Because get_array_size pads out the array element size if each
 542              element must start on a > word_ boundary, a dangerous anomaly
 543              could arise if the target is a nondimensioned structure while
 544              the source is an array element.  Therefore, in such a case
 545              the size of the nondimensioned structure must be used for
 546              the assignment rather than the source size.  This fixes bug
 547              1500.  */
 548 
 549           if b -> reference.symbol -> symbol.dimensioned & ^a -> reference.symbol -> symbol.dimensioned then
 550                ref = a;
 551           else
 552                ref = b;
 553 
 554           sb = ref -> reference.symbol;
 555 
 556           if sb -> symbol.dimensioned then
 557                arrayp = sb -> symbol.array;
 558           else
 559                arrayp = null;
 560 
 561           if sb -> symbol.packed then
 562                opcode = copy_string;
 563           else
 564                opcode = copy_words;
 565 
 566           if arrayp ^= null & ^ref -> reference.array_ref then
 567                if sb -> symbol.packed then
 568                     if arrayp -> array.element_size_bits = null then
 569                          p = declare_constant$integer ((arrayp -> array.c_element_size_bits));
 570                     else
 571                          p = arrayp -> array.element_size_bits;
 572                else if arrayp -> array.element_size = null then
 573                     p = declare_constant$integer ((arrayp -> array.c_element_size));
 574                else
 575                     p = arrayp -> array.element_size;
 576 
 577           else if sb -> symbol.packed then
 578                if sb -> symbol.bit_size = null then
 579                     p = declare_constant$integer ((sb -> symbol.c_bit_size));
 580                else
 581                     p = sb -> symbol.bit_size;
 582           else if sb -> symbol.word_size = null then
 583                p = declare_constant$integer ((sb -> symbol.c_word_size));
 584           else do;
 585                p = sb -> symbol.word_size;
 586                if sb -> symbol.temporary then
 587                     sb -> symbol.word_size = expression_semantics (blk, stmnt, copy_expression ((p)), "0"b);
 588           end;
 589 
 590           this_context = "0"b;
 591           p = copy_expression ((p));
 592           if sb -> symbol.refer_extents then
 593                call refer_extent (p, (b -> reference.qualifier));
 594           p = expression_semantics (blk, stmnt, p, this_context);
 595 
 596           call simplify_expression (p, constant, modified);
 597           if modified then
 598                p = declare_constant$integer ((constant));
 599 
 600           q = create_operator (opcode, 3);
 601           q -> operand (1) = a;
 602           q -> operand (2) = b;
 603           q -> operand (3) = p;
 604 
 605           return (q);
 606 
 607      end make_copy;
 608 %page;
 609 /* subroutine to make a source-like declaration of a temporary.  */
 610 
 611 maker:
 612      proc (t, e, s, given, level_number, er);
 613 
 614 dcl      (s, p, q, f, a, r, t1, e1, s1, eb, subs) ptr;
 615 dcl      (t, e) ptr;                                        /* t points to the param_desc (the target) symbol, e points to the expression symbol */
 616 dcl      er ptr;                                            /* er points to the expression reference or is null */
 617 dcl      (n, i, level_number, sdims) fixed bin (15);
 618 dcl      (given, refer_extents, have_subs, ignore_e_array) aligned bit (1);
 619 
 620           n = 0;
 621           ignore_e_array, have_subs = "0"b;
 622           if ^given then
 623                s = create_symbol (blk, null, by_compiler);
 624           string (s -> symbol.data_type) = string (t -> symbol.data_type);
 625           string (s -> symbol.misc_attributes) = string (t -> symbol.misc_attributes);
 626           s -> symbol.star_extents, s -> symbol.member, s -> symbol.external, s -> symbol.initialed = "0"b;
 627 
 628           refer_extents = e -> symbol.refer_extents;
 629 
 630           if t -> symbol.array ^= null then
 631                if level_number = 1 then do;
 632                     n, sdims = t -> symbol.array -> array.number_of_dimensions;
 633                     if er ^= null then
 634                          if er -> node.type = reference_node then
 635                               if ^er -> reference.array_ref then
 636                                    if t = e then
 637                                         n, sdims = 0;
 638                                    else
 639                                         ignore_e_array = "1"b;
 640                               else if er -> reference.offset ^= null then
 641                                    if er -> reference.offset -> node.type = list_node then do;
 642                                         subs = er -> reference.offset;
 643                                         have_subs = "1"b;
 644                                         sdims = 0;
 645                                    end;
 646                end;
 647 
 648                else
 649                     n, sdims = t -> symbol.array -> array.own_number_of_dimensions;
 650 
 651           s -> symbol.dimensioned = (n ^= 0);
 652           s -> symbol.block_node = t -> symbol.block_node;
 653           s -> symbol.general = t -> symbol.general;
 654 
 655           s -> symbol.pix = t -> symbol.pix;
 656 
 657           s -> symbol.c_dcl_size = t -> symbol.c_dcl_size;
 658 
 659           if t -> symbol.param_desc then
 660                if t -> symbol.dcl_size ^= null then
 661                     if t -> symbol.dcl_size -> node.type = token_node then
 662                          if t -> symbol.dcl_size -> token.type = asterisk then
 663                               if e -> symbol.fixed | e -> symbol.float then do;
 664                                    a = convert$from_builtin ((e -> symbol.reference),
 665                                         (substr (string (t -> symbol.attributes), 1, 36) & string_mask));
 666                                    s -> symbol.c_dcl_size =
 667                                         a -> operator.operand (1) -> reference.symbol -> symbol.c_dcl_size;
 668                               end;
 669                               else
 670                                    s -> symbol.c_dcl_size = e -> symbol.c_dcl_size;
 671 
 672           if doing_return then
 673                if t -> symbol.dcl_size ^= null then
 674                     if t -> symbol.dcl_size -> node.type = operator_node then
 675                          if t -> symbol.dcl_size -> operator.op_code = desc_size then
 676                               if e -> symbol.fixed | e -> symbol.float then do;
 677                                    a = convert$from_builtin ((e -> symbol.reference),
 678                                         (substr (string (t -> symbol.attributes), 1, 36) & string_mask));
 679                                    s -> symbol.c_dcl_size =
 680                                         a -> operator.operand (1) -> reference.symbol -> symbol.c_dcl_size;
 681                               end;
 682                               else
 683                                    s -> symbol.c_dcl_size = e -> symbol.c_dcl_size;
 684 
 685           if s -> symbol.entry then
 686                s -> symbol.dcl_size = t -> symbol.dcl_size;
 687           else do;
 688                s -> symbol.dcl_size = e -> symbol.dcl_size;
 689                if s -> symbol.dcl_size ^= null then do;
 690                     s -> symbol.exp_extents = "1"b;
 691                     if s -> symbol.dcl_size -> node.type = token_node then
 692                          if s -> symbol.dcl_size -> token.type = dec_integer then
 693                               s -> symbol.exp_extents = "0"b;
 694                end;
 695           end;
 696 
 697           if refer_extents then do;
 698                r = copy_expression (s -> symbol.dcl_size);
 699                call refer_extent (r, qual);
 700                s -> symbol.dcl_size = r;
 701           end;
 702 
 703           s -> symbol.scale = t -> symbol.scale;
 704           s -> symbol.level = level_number;
 705 
 706           if n ^= 0 then do;
 707                s -> symbol.array, a = create_array ();
 708                p = t -> symbol.array -> array.bounds;
 709 
 710                if ^ignore_e_array then
 711                     eb = e -> symbol.array;
 712                else
 713                     eb = null;
 714 
 715                if eb ^= null then
 716                     eb = eb -> array.bounds;
 717 
 718                do i = 1 to n while (p ^= null);
 719                     if have_subs then do;
 720                          if subs -> element (i) -> node.type ^= token_node then
 721                               goto step;
 722                          if subs -> element (i) -> token.type ^= asterisk then
 723                               goto step;
 724 
 725                          sdims = sdims + 1;
 726                     end;
 727 
 728                     q = create_bound ();
 729                     q -> bound.c_lower = p -> bound.c_lower;
 730                     q -> bound.c_upper = p -> bound.c_upper;
 731 
 732                     q -> bound.lower = p -> bound.lower;
 733                     q -> bound.upper = p -> bound.upper;
 734 
 735                     if t -> symbol.param_desc then
 736                          if q -> bound.lower ^= null then
 737                               if q -> bound.lower -> node.type = token_node then
 738                                    if q -> bound.lower -> token.type = asterisk /* fill in star_extents from e */ then
 739                                         call use_eb;
 740 
 741                     if doing_return then
 742                          if q -> bound.lower ^= null then
 743                               if q -> bound.lower -> node.type = reference_node then
 744                                    if q -> bound.lower -> reference.symbol -> node.type = symbol_node then
 745                                         if q -> bound.lower -> reference.symbol -> symbol.arg_descriptor then
 746                                              call use_eb;
 747 
 748                     if refer_extents then do;
 749                          r = copy_expression (q -> bound.lower);
 750                          call refer_extent (r, qual);
 751                          q -> bound.lower = r;
 752                          r = copy_expression (q -> bound.upper);
 753                          call refer_extent (r, qual);
 754                          q -> bound.upper = r;
 755                     end;
 756 
 757                     if q -> bound.lower ^= null then do;
 758                          call simplify_expression ((q -> bound.lower), constant, modified);
 759 
 760                          if modified then do;
 761                               q -> bound.lower = null;
 762                               q -> bound.c_lower = constant;
 763                          end;
 764                          else
 765                               s -> symbol.exp_extents = "1"b;
 766                     end;
 767 
 768                     if q -> bound.upper ^= null then do;
 769                          call simplify_expression ((q -> bound.upper), constant, modified);
 770 
 771                          if modified then do;
 772                               q -> bound.upper = null;
 773                               q -> bound.c_upper = constant;
 774                          end;
 775                          else
 776                               s -> symbol.exp_extents = "1"b;
 777                     end;
 778 
 779                     if a -> array.bounds = null then
 780                          a -> array.bounds = q;
 781                     else
 782                          f -> bound.next = q;
 783 
 784                     f = q;
 785 
 786 step:
 787                     p = p -> bound.next;
 788 
 789                     if eb ^= null then
 790                          eb = eb -> bound.next;
 791                end;
 792 
 793                a -> array.own_number_of_dimensions = sdims;
 794           end;
 795 
 796           f = null;
 797           t1 = t -> symbol.son;
 798           e1 = e -> symbol.son;
 799 
 800           do while (t1 ^= null);
 801                if e -> symbol.son = null then
 802                     e1 = e;
 803 
 804                if def_context.by_name_assignment /* Fixes 2109 */ then do;
 805                     s1 = create_symbol (blk, (e1 -> symbol.token), by_compiler);
 806                     call maker (t1, e1, s1, "1"b, level_number + 1, null);
 807                end;
 808                else
 809                     call maker (t1, e1, s1, "0"b, level_number + 1, null);
 810 
 811                s1 -> symbol.member = "1"b;
 812                s1 -> symbol.father = s;
 813                if f = null then
 814                     s -> symbol.son = s1;
 815                else
 816                     f -> symbol.brother = s1;
 817                f = s1;
 818                t1 = t1 -> symbol.brother;
 819                e1 = e1 -> symbol.brother;
 820           end;
 821 
 822           if level_number = 1 then do;
 823                if s -> symbol.dcl_size ^= null then do;
 824                     call simplify_expression ((s -> symbol.dcl_size), constant, modified);
 825 
 826                     if modified then do;
 827                          s -> symbol.dcl_size = null;
 828                          s -> symbol.c_dcl_size = constant;
 829                     end;
 830                end;
 831 
 832                s -> symbol.temporary = "1"b;
 833                s -> symbol.position = "0"b;                 /* fixes bug #2124 */
 834                call declare (s);
 835 
 836                if s -> symbol.word_size ^= null then do;    /* process aggregrate expression size for use by code generator */
 837                     s -> symbol.word_size =
 838                          expression_semantics (blk, stmnt, copy_expression (s -> symbol.word_size), "0"b);
 839 
 840                     call simplify_expression ((s -> symbol.word_size), constant, modified);
 841 
 842                     if modified then do;
 843                          s -> symbol.word_size = null;
 844                          s -> symbol.c_word_size = constant;
 845                     end;
 846                end;
 847           end;
 848 
 849 
 850 use_eb:
 851           proc;
 852 
 853                if eb ^= null then do;
 854                     q -> bound.lower = eb -> bound.lower;
 855                     q -> bound.upper = eb -> bound.upper;
 856                     q -> bound.c_lower = eb -> bound.c_lower;
 857                     q -> bound.c_upper = eb -> bound.c_upper;
 858                end;
 859                else do;
 860                     q -> bound.lower, q -> bound.upper = null;
 861                     q -> bound.c_lower, q -> bound.c_upper = 1;
 862                end;
 863 
 864           end use_eb;
 865 
 866      end maker;
 867 %page;
 868 /* subroutine to create a declaration which represents the result of an aggregate valued expression.  */
 869 
 870 declare_expression:
 871      proc (tree, last, level_number) returns (ptr);
 872 
 873 dcl      (tree, last, s, f, a, b) ptr;
 874 dcl      (i, level_number) fixed bin (15);
 875 
 876           if tree = null then
 877                return (null);
 878 
 879           if tree -> node.type = reference_node then do;
 880                call maker ((tree -> reference.symbol), (tree -> reference.symbol), a, "0"b, level_number, null);
 881                return (a);
 882           end;
 883 
 884           if tree -> node.type ^= operator_node then
 885                return (tree);
 886 
 887           if tree -> operator.op_code = join then do;
 888                b = null;
 889                f = create_symbol (blk, null, by_compiler);
 890                f -> symbol.structure = "1"b;
 891 
 892                do i = 1 to tree -> operator.number;
 893                     s = declare_expression ((tree -> operand (i)), null, level_number + 1);
 894                     s -> symbol.father = f;
 895                     s -> symbol.member = "1"b;
 896 
 897                     if b ^= null then
 898                          b -> symbol.brother = s;
 899                     else
 900                          f -> symbol.son = s;
 901 
 902                     b = s;
 903                end;
 904 
 905                f -> symbol.level = level_number;
 906 
 907                return (f);
 908           end;
 909 
 910           if tree -> operator.op_code = loop then do;
 911                b = create_bound ();
 912                b -> bound.next = last;
 913                last = b;
 914                b -> bound.c_lower = 1;
 915                b -> bound.upper = tree -> operand (4);
 916                if tree -> operand (4) -> node.type = reference_node then
 917                     if tree -> operand (4) -> reference.symbol -> symbol.constant then do;
 918                          b -> bound.upper = null;
 919                          b -> bound.c_upper = tree -> operand (4) -> reference.symbol -> symbol.initial -> based_integer;
 920                     end;
 921 
 922                s = declare_expression ((tree -> operand (1)), last, level_number);
 923 
 924                if last ^= null then do;
 925                     s -> symbol.dimensioned = "1"b;
 926                     s -> symbol.array = create_array ();
 927                     s -> symbol.array -> array.bounds = last;
 928 
 929                     s -> symbol.array -> array.own_number_of_dimensions =
 930                          s -> symbol.array -> array.own_number_of_dimensions + 1;
 931                     s -> symbol.array -> array.number_of_dimensions = s -> symbol.array -> array.number_of_dimensions + 1;
 932 
 933                     last = null;
 934 
 935                     s -> symbol.reference -> reference.array_ref = "1"b;
 936                end;
 937 
 938                s -> symbol.array -> array.own_number_of_dimensions =
 939                     s -> symbol.array -> array.own_number_of_dimensions + 1;
 940                s -> symbol.array -> array.number_of_dimensions = s -> symbol.array -> array.number_of_dimensions + 1;
 941 
 942                return (s);
 943           end;
 944 
 945           s = tree -> operand (1) -> reference.symbol;
 946           call maker (s, s, a, "0"b, level_number, null);
 947 
 948           if last ^= null & (s -> symbol.bit | s -> symbol.char) then do;
 949                have_varying = "0"b;
 950                a -> symbol.c_dcl_size = 0;
 951                a -> symbol.dcl_size = size (tree);
 952 
 953                if no_data_type & have_varying then do;
 954                     a -> symbol.varying, a -> symbol.aligned = "1"b;
 955                     a -> symbol.unaligned, a -> symbol.packed = "0"b;
 956                end;
 957                a -> symbol.exp_extents = "1"b;
 958           end;
 959 
 960           if a -> symbol.dcl_size ^= null then do;
 961                call simplify_expression ((a -> symbol.dcl_size), constant, modified);
 962 
 963                if modified then do;
 964                     a -> symbol.dcl_size = null;
 965                     a -> symbol.c_dcl_size = constant;
 966                end;
 967           end;
 968 
 969           if level_number = 1 then do;
 970                a -> symbol.temporary = "1"b;
 971                call declare (a);
 972 
 973                if a -> symbol.word_size ^= null then do;
 974                     a -> symbol.word_size =
 975                          expression_semantics (blk, stmnt, copy_expression (a -> symbol.word_size), "0"b);
 976                     call simplify_expression ((a -> symbol.word_size), constant, modified);
 977 
 978                     if modified then do;
 979                          a -> symbol.word_size = null;
 980                          a -> symbol.c_word_size = constant;
 981                     end;
 982                end;
 983           end;
 984 
 985           return (a);
 986 
 987      end declare_expression;
 988 %page;
 989 /* subroutine to determine the size of a string array temporary.  */
 990 
 991 size:
 992      proc (e) returns (ptr);
 993 
 994 dcl      (e, s, q) ptr;
 995 dcl      opcode bit (9) aligned;
 996 
 997           if e = null then
 998                call semantic_translator$abort (195, null);
 999 
1000           if e -> node.type = reference_node then do;
1001                s = e -> reference.symbol;
1002                if s -> symbol.dcl_size = null then
1003                     q = declare_constant$integer ((s -> symbol.c_dcl_size));
1004                else
1005                     q = s -> symbol.dcl_size;
1006 
1007                if s -> symbol.varying then
1008                     have_varying = "1"b;
1009 
1010                q = copy_expression ((q));
1011                this_context = "0"b;
1012                if s -> symbol.refer_extents then
1013                     call refer_extent (q, (e -> reference.qualifier));
1014                q = expression_semantics (blk, stmnt, q, this_context);
1015                return (q);
1016           end;
1017 
1018           if e -> node.type ^= operator_node then
1019                call semantic_translator$abort (195, null);
1020 
1021           opcode = e -> operator.op_code;
1022 
1023           if opcode = cat_string then do;
1024                q = create_operator (add, 3);
1025                q -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1026                q -> operand (2) = size ((e -> operand (2)));
1027                q -> operand (3) = size ((e -> operand (3)));
1028                return (q);
1029           end;
1030 
1031           if opcode = or_bits | opcode = and_bits | opcode = xor_bits | opcode = bool_fun then do;
1032                q = create_operator (max_fun, 3);
1033                q -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1034                q -> operand (2) = size ((e -> operand (2)));
1035                q -> operand (3) = size ((e -> operand (3)));
1036                return (q);
1037           end;
1038 
1039           if opcode = repeat_fun then do;
1040                q = create_operator (mult, 3);
1041                q -> operand (2) = size ((e -> operand (2)));
1042                q -> operand (3) = copy_expression (e -> operand (3));
1043                return (q);
1044           end;
1045 
1046           q = size ((e -> operand (1)));
1047 
1048           if q -> node.type = operator_node then
1049                if q -> operator.op_code = length_fun then
1050                     if q -> operand (2) = e -> operand (2) then do;
1051                          if ^q -> operand (1) -> reference.shared then
1052                               q -> operand (1) -> reference.ref_count = q -> operand (1) -> reference.ref_count - 1;
1053                          else do;
1054                               q = q -> operand (2);
1055                               if q -> node.type = operator_node then
1056                                    q = q -> operand (1);
1057                               if ^q -> reference.shared then
1058                                    q -> reference.ref_count = q -> reference.ref_count - 1;
1059                          end;
1060                          return (size ((e -> operand (2))));
1061                     end;
1062 
1063           return (q);
1064 
1065      end size;
1066 %page;
1067 %include semant;
1068 %include array;
1069 %include block;
1070 %include boundary;
1071 %include declare_type;
1072 %include decoded_token_types;
1073 %include list;
1074 %include mask;
1075 %include nodes;
1076 %include op_codes;
1077 %include operator;
1078 %include reference;
1079 %include semantic_bits;
1080 %include statement;
1081 %include statement_types;
1082 %include symbol;
1083 %include symbol_bits;
1084 %include system;
1085 %include token;
1086 %include token_types;
1087 
1088      end expand_assign;