1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4    *                                                         *
   5    * Copyright (c) 1972 by Massachusetts Institute of        *
   6    * Technology and Honeywell Information Systems, Inc.      *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 
  11 /* format: style3 */
  12 expression_semantics:
  13      proc (blk, stmnt, input_tree, context) returns (ptr);
  14 
  15 /* Modified 770520 by PG to get defaulting of constants to agree with ANSI standard */
  16 /* Modified 770701 by PG to fix 1609 (invalid initialization of automatic variables in prologue) */
  17 /* Modified 770708 by PG to fix 1641 (default statements shouldn't be applied to string constants) */
  18 /* Modified 780314 by PG to fix 1673 (don't default constants unless default statement explicitly touches constants) */
  19 /* Modified 780322 by RAB to diagnose non array_or_entry followed by parenthesized list */
  20 /* Modified Nov 1978 by DS to suppress redundant label and entry cross-references */
  21 /* Modified 26 Dec 1979 by PCK to implement by name assignment */
  22 /*        Modified: 28 April 1980 by PCK to fix 1959        */
  23 
  24 /* parameters */
  25 
  26 dcl       (blk, stmnt, input_tree)
  27                               ptr parameter;
  28 
  29 /* automatic */
  30 
  31 dcl       (tree, s, subs, d, p, q, b)
  32                               ptr;
  33 dcl       (i, n, t, asterisk_count)
  34                               fixed bin (15);
  35 dcl       opcode              bit (9) aligned;
  36 dcl       (LHS_aggregate, pds, cross_section)
  37                               bit (1) aligned;
  38 
  39 /* builtins */
  40 
  41 dcl       (addr, index, null, string)
  42                               builtin;
  43 
  44 /* external static */
  45 
  46 dcl       pl1_stat_$LHS       ptr ext static;
  47 dcl       pl1_stat_$LHS_ref   ptr ext static;
  48 dcl       pl1_stat_$root      ptr ext static;
  49 dcl       pl1_stat_$locator   (128) ptr ext static;
  50 dcl       pl1_stat_$index     fixed bin (15) ext static;
  51 
  52 /* program */
  53 
  54           tree = input_tree;
  55 
  56           subs = null;
  57           cross_section, this_context = "0"b;
  58           def_this_context.ignore_based = def_context.ignore_based;
  59           def_this_context.suppress_cross_ref = def_context.suppress_cross_ref;
  60 
  61           if tree = null
  62           then goto ret;
  63 
  64           if tree -> node.type = operator_node
  65           then do;
  66                     if tree -> operator.processed
  67                     then goto ret;
  68 
  69                     opcode = tree -> operator.op_code;
  70 
  71                     if opcode < r_parn | opcode > lock_file
  72                     then goto not_io;
  73 
  74                     if ((opcode >= get_file) & (opcode <= locate_file) | (opcode >= rewrite_file) & (opcode <= lock_file))
  75                     then do;
  76                               call io_semantics (blk, stmnt, tree);
  77                               if opcode ^= open_file & opcode ^= close_file
  78                               then tree = null;             /* 7-18-72: all others handled
  79                                                      by recio or stream_prep */
  80 
  81                               goto ret;
  82                          end;
  83 
  84                     if opcode >= r_parn & opcode <= bn_format
  85                     then do;
  86                               call io_data_list_semantics$format_list_semantics (blk, stmnt, tree);
  87                               tree -> operator.processed = "1"b;
  88                               goto ret;
  89                          end;
  90 
  91                     if opcode = put_data_trans
  92                     then do;
  93                               q = tree -> operand (2);
  94                               if q -> node.type = token_node
  95                               then do;
  96                                         p = create_reference (q);
  97                                         q, tree -> operand (2) = p;
  98                                    end;
  99                               if q -> node.type = reference_node
 100                               then q -> reference.put_data_sw = "1"b;
 101                          end;
 102 
 103                     if opcode = get_list_trans | opcode = get_edit_trans
 104                     then def_this_context.left_side = "1"b;
 105 
 106 not_io:
 107                     if opcode = assign_by_name
 108                     then do;
 109                               call expand_by_name (blk, stmnt, tree);
 110 
 111                               if stmnt -> statement.root = null
 112                               then go to ret;
 113                               else opcode = assign;
 114                          end;
 115 
 116                     if opcode = refer | opcode = bit_pointer
 117                     then if pl1_stat_$index > 0
 118                          then do;
 119                                    p = pl1_stat_$locator (pl1_stat_$index) -> reference.qualifier;
 120 
 121                                    if opcode = refer
 122                                    then do;
 123                                              tree = copy_expression (tree -> operand (2));
 124                                              if tree -> node.type = token_node
 125                                              then tree = create_reference (tree);
 126 
 127                                              tree -> reference.qualifier = share_expression (p);
 128                                              tree = expression_semantics (blk, stmnt, tree, this_context);
 129 
 130                                              goto ret;
 131                                         end;
 132                                    else do;
 133                                              if p -> node.type = operator_node
 134                                              then if p -> operator.op_code = assign
 135                                                   then if p -> operand (1) -> reference.symbol -> symbol.aligned
 136                                                        then p = p -> operand (2);
 137                                              tree -> operand (2) = share_expression (p);
 138                                         end;
 139                               end;
 140                          else do;
 141                                    if opcode = bit_pointer
 142                                    then call semantic_translator$abort (291, null);
 143 
 144                                    tree = tree -> operand (1);
 145                                    tree = expression_semantics (blk, stmnt, tree, this_context);
 146                                    goto ret;
 147                               end;
 148 
 149 
 150                     if opcode = assign
 151                     then do;
 152                               def_this_context.left_side = "1"b;
 153 
 154                               if def_context.top
 155                               then def_this_context.by_name_assignment = stmnt -> statement.expanded_by_name;
 156 
 157                               tree -> operand (1) = expression_semantics (blk, stmnt, (tree -> operand (1)), this_context);
 158                               LHS_aggregate = def_this_context.aggregate;
 159 
 160                               if def_this_context.return_from_empty
 161                               then do;
 162                                         tree = tree -> operand (1);
 163                                         goto ret;
 164                                    end;
 165 
 166                               do p = tree -> operand (1) repeat p -> operand (1) while (p -> node.type = operator_node);
 167                               end;
 168 
 169                               if p -> node.type ^= reference_node
 170                               then call print (145);
 171 
 172                               if def_context.top
 173                               then do;
 174                                         pl1_stat_$LHS_ref = p;
 175                                         pl1_stat_$LHS = p -> reference.symbol;
 176                                    end;
 177 
 178                               if stmnt -> statement.expanded_by_name
 179                               then def_this_context.by_name_assignment = def_context.top | def_context.by_name_assignment;
 180 
 181                               def_this_context.aggregate, def_this_context.left_side = "0"b;
 182                               tree -> operand (2) = expression_semantics (blk, stmnt, (tree -> operand (2)), this_context);
 183                               def_context.RHS_aggregate = def_this_context.aggregate;
 184                               def_this_context.aggregate = def_this_context.aggregate | LHS_aggregate;
 185 
 186                               if def_this_context.return_from_empty
 187                               then do;
 188                                         tree = tree -> operand (2);
 189 
 190                                         goto ret;
 191                                    end;
 192                          end;
 193                     else do;
 194                               def_this_context.by_name_assignment = def_context.by_name_assignment;
 195                               if opcode = do_fun
 196                               then do;
 197                                         def_this_context.left_side = "1"b;
 198                                         tree -> operand (2) =
 199                                              expression_semantics (blk, stmnt, (tree -> operand (2)), this_context);
 200                                         def_this_context.left_side = "0"b;
 201                                    end;
 202 
 203                               if opcode = do_spec           /* do loop while, repeat specs are only processed inside the loop */
 204                               then do i = 1 to 3, 6;
 205                                         if tree -> operand (i) ^= null
 206                                         then tree -> operand (i) =
 207                                                   expression_semantics (blk, stmnt, (tree -> operand (i)), this_context);
 208                                    end;
 209                               else do i = 1 to tree -> operator.number;
 210                                                             /* normal operator...process all operands */
 211                                         if tree -> operand (i) ^= null
 212                                         then tree -> operand (i) =
 213                                                   expression_semantics (blk, stmnt, (tree -> operand (i)), this_context);
 214                                    end;
 215                          end;
 216 
 217                     if opcode = return_value
 218                     then do;
 219                               tree = operator_semantics (blk, stmnt, tree, this_context);
 220 
 221                               if tree ^= null
 222                               then tree -> operator.processed = "1"b;
 223 
 224                               goto ret;
 225                          end;
 226 
 227                     if ^def_this_context.aggregate | opcode = allot_var | opcode = free_var | opcode = std_entry
 228                     then do;
 229                               tree = operator_semantics (blk, stmnt, tree, context);
 230 
 231                               if tree ^= null
 232                               then tree -> operator.processed = "1"b;
 233 
 234                               goto ret;
 235                          end;
 236 
 237 /*   Only aggregates will reach this point   */
 238                     if opcode = std_entry | opcode = join
 239                     then do;
 240                               tree -> operator.processed = "1"b;
 241                               goto ret;
 242                          end;
 243 
 244                     if opcode >= jump
 245                     then if opcode = prefix_plus | opcode = join | opcode >= get_list_trans & opcode <= put_data_trans
 246                          then ;
 247                          else call print (62);
 248 
 249                     if opcode = assign & (def_context.arg_list | def_context.top)
 250                     then do;
 251                               this_context = context;
 252 
 253                               if def_this_context.top
 254                               then def_this_context.by_name_assignment = stmnt -> statement.expanded_by_name;
 255 
 256                               tree = expand_assign (blk, stmnt, tree, this_context, null);
 257                               tree -> operator.processed = "1"b;
 258                               goto ret;
 259                          end;
 260 
 261                     def_context.aggregate = "1"b;
 262 
 263                     if opcode = copy_words
 264                     then do;
 265                               p = expand_primitive (blk, stmnt, (tree -> operand (1)), "0"b);
 266 
 267                               do q = p repeat q -> operand (1) while (q -> operand (1) -> node.type = operator_node);
 268                               end;
 269 
 270                               tree -> operand (1) = q -> operand (1);
 271                               q -> operand (1) = tree;
 272                               tree = p;
 273 
 274                               tree -> operator.processed = "1"b;
 275                               goto ret;
 276                          end;
 277 
 278                     if opcode = negate | opcode = not_bits | opcode = prefix_plus | opcode = put_field
 279                          | opcode = put_field_chk | (opcode >= get_list_trans & opcode <= put_data_trans)
 280                     then tree = expand_prefix (blk, stmnt, tree, context);
 281                     else tree = expand_infix (blk, stmnt, tree, context);
 282 
 283                     tree -> operator.processed = "1"b;
 284 
 285                     goto ret;
 286                end;
 287 ^L
 288           if tree -> node.type = token_node
 289           then do;
 290                     if tree -> token.type = identifier
 291                     then do;
 292 
 293                               if ^lookup (blk, stmnt, tree, s, this_context)
 294                               then do;
 295                                         call semantic_translator$error (77, tree);
 296                                         s = create_symbol ((pl1_stat_$root -> block.son), tree, by_implication);
 297                                         call declare (s);
 298                                         s -> symbol.allocate = "1"b;
 299 
 300                                         d = create_cross_reference ();
 301                                         d -> cross_reference.next = null;
 302                                         s -> symbol.cross_references = d;
 303                                         string (d -> cross_reference.source_id) = string (stmnt -> statement.source_id);
 304                                    end;
 305 
 306                               if s -> node.type = label_node
 307                               then goto process_label;
 308 
 309                               q = s -> symbol.reference;
 310                               if q -> reference.offset = null & q -> reference.qualifier = null
 311                                    & q -> reference.length = null & ^(s -> symbol.entry | s -> symbol.defined)
 312                               then tree = q;
 313                               else do;
 314                                         tree = copy_expression ((q));
 315                                         tree -> reference.shared = "0"b;
 316                                         tree -> reference.ref_count = 1;
 317                                         tree -> reference.qualifier = null;
 318                                    end;
 319                               go to process_reference;
 320                          end;
 321 
 322 /* Default arithmetic constant tokens */
 323 
 324                     if (tree -> token.type & is_arithmetic_constant) = is_arithmetic_constant
 325                     then do b = blk repeat b -> block.father while (b ^= null);
 326                               if b -> block.default ^= null
 327                               then do;
 328                                         s = create_symbol (blk, null, by_compiler);
 329                                         s -> symbol.constant = "1"b;
 330                                         if tree -> token.loc ^= ""b
 331                                                             /* "p" flag ON */
 332                                         then go to ignore_default_attempt;
 333 
 334 /* constant contains an "e" implies is_float_constant */
 335                                         if (tree -> token.type & is_float_constant) = is_float_constant
 336                                         then s -> symbol.float = "1"b;
 337                                         else if index (tree -> token.string, "f") ^= 0
 338                                         then s -> symbol.fixed = "1"b;
 339 
 340 /* constant contains an "i" implies is_imaginary_constant */
 341                                         if (tree -> token.type & is_imaginary_constant) = is_imaginary_constant
 342                                         then s -> symbol.complex = "1"b;
 343                                         else s -> symbol.real = "1"b;
 344 
 345                                         call validate (s);  /* now default the symbol */
 346 
 347                                         if ^s -> symbol.defaulted
 348                                                             /* were any defaults applied? */
 349                                         then go to ignore_default_attempt;
 350                                                             /* No */
 351 
 352                                         if ^s -> symbol.fixed & ^s -> symbol.float
 353                                                             /* complete the scale */
 354                                         then s -> symbol.fixed = "1"b;
 355 
 356                                         if ^s -> symbol.binary & ^s -> symbol.decimal
 357                                                             /* complete the base */
 358                                         then if (tree -> token.type & is_decimal_constant) = is_decimal_constant
 359                                              then s -> symbol.decimal = "1"b;
 360                                              else s -> symbol.binary = "1"b;
 361 
 362 /* validate and the above code has now supplied
 363                                         the data type to coerce the literal constant to,
 364                                         except possibly for the size (length or precision) */
 365 
 366 /* get a pointer to a reference to the converted constant */
 367 
 368                                         if s -> symbol.c_dcl_size = 0 & s -> symbol.dcl_size = null
 369                                         then tree = convert (tree, string (s -> symbol.attributes));
 370                                         else tree = convert$to_target (tree, (s -> symbol.reference));
 371 
 372 ignore_default_attempt:
 373                                         call free_node (s);
 374 
 375                                         go to ret;
 376                                    end;
 377                          end;                               /* control comes here if there were no default statements */
 378                     go to ret;
 379                end;
 380 
 381           if tree -> node.type = label_node
 382           then do;
 383                     s = tree;
 384                     go to process_label;
 385                end;
 386 
 387           if tree -> node.type ^= reference_node
 388           then goto ret;
 389 
 390           if tree -> reference.symbol -> node.type ^= token_node
 391           then do;
 392                     s = tree -> reference.symbol;
 393                     if s -> node.type ^= symbol_node
 394                     then goto ret;                          /* could be subscripted reference_node for labels */
 395                     if s -> symbol.param_desc               /* the qualifier field should be fully processed */
 396                     then do;
 397                               tree -> reference.processed = "1"b;
 398                               goto process_reference;
 399                          end;
 400 
 401                     if ^tree -> reference.symbol -> symbol.based /* for init allocated based structures */
 402                          & ^tree -> reference.processed
 403                     then tree -> reference.qualifier = null;/* for auto-adj storage class */
 404 
 405                     goto process_reference;
 406                end;
 407 
 408           subs = tree -> reference.offset;
 409           tree -> reference.offset = null;                  /*   lookup never sees the offset field  */
 410 
 411           if ^lookup (blk, stmnt, tree, s, this_context)
 412           then do;
 413                     q = tree -> reference.length;
 414                     if q ^= null
 415                     then do;
 416                               p = create_token (tree -> reference.symbol -> token.string || """ in """
 417                                    || q -> element (q -> list.number) -> token.string, identifier);
 418                               call semantic_translator$abort (102, p);
 419                          end;
 420 
 421                     if subs = null
 422                     then do;
 423                               pds = tree -> reference.put_data_sw;
 424 
 425                               call semantic_translator$error (77, tree);
 426                               s = create_symbol ((pl1_stat_$root -> block.son), (tree -> reference.symbol), by_implication);
 427                               call declare (s);
 428                               s -> symbol.allocate = "1"b;
 429 
 430                               d = create_cross_reference ();
 431                               d -> cross_reference.next = null;
 432                               s -> symbol.cross_references = d;
 433                               string (d -> cross_reference.source_id) = string (stmnt -> statement.source_id);
 434 
 435                               if pds
 436                               then do;
 437                                         tree -> reference.put_data_sw = "1"b;
 438                                         goto copy_ref;
 439                                    end;
 440 
 441                               goto process_reference;
 442                          end;
 443 
 444                     do i = 1 to number_of_names;
 445                          if tree -> reference.symbol -> token.string = pl1_data$builtin_name (i).name
 446                          then do;
 447                                    s = create_symbol ((pl1_stat_$root -> block.son), (tree -> reference.symbol),
 448                                         by_implication);
 449 
 450                                    d = create_cross_reference ();
 451                                    d -> cross_reference.next = null;
 452                                    s -> symbol.cross_references = d;
 453                                    string (d -> cross_reference.source_id) = string (stmnt -> statement.source_id);
 454                                    s -> symbol.builtin = "1"b;
 455                                    s -> symbol.c_dcl_size = i;
 456 
 457                                    tree -> reference.offset = null;
 458                                    tree -> reference.symbol = s;
 459                                    s -> symbol.reference = tree;
 460 
 461                                    tree = builtin (blk, stmnt, tree, subs, s, context);
 462                                    goto ret;
 463                               end;
 464                     end;
 465 
 466                     call semantic_translator$error (64, tree);
 467                     s = create_symbol ((pl1_stat_$root -> block.son), (tree -> reference.symbol), by_implication);
 468                     s -> symbol.entry = "1"b;
 469                     s -> symbol.variable_arg_list = "1"b;
 470                     call declare (s);
 471                     s -> symbol.allocate = "1"b;
 472                     tree = copy_expression (s -> symbol.reference);
 473                end;
 474 
 475 /* this name was found by lookup. */
 476 
 477           if s -> node.type = label_node
 478           then go to process_label;
 479 
 480 copy_ref:
 481           p = s -> symbol.reference;
 482           q = tree -> reference.qualifier;
 483           pds = tree -> reference.put_data_sw;
 484 
 485           if q = null & subs = null & p -> reference.offset = null & p -> reference.qualifier = null
 486                & p -> reference.length = null & ^s -> symbol.entry & ^pds
 487           then do;
 488                     call free_node (tree);
 489                     tree = p;
 490                end;
 491           else do;
 492                     tree -> reference = p -> reference;
 493                     tree -> reference.shared, tree -> reference.aggregate, tree -> reference.processed = "0"b;
 494                     tree -> reference.ref_count = 1;
 495                     tree -> reference.put_data_sw = pds;
 496 
 497                     if tree -> reference.offset ^= null
 498                     then tree -> reference.offset = copy_expression (/* p-> */ tree -> reference.offset);
 499 
 500                     if tree -> reference.length ^= null
 501                     then tree -> reference.length = copy_expression (/* p-> */ tree -> reference.length);
 502 
 503                     tree -> reference.qualifier = q;
 504                end;
 505 ^L
 506 process_reference:
 507           if def_context.left_side
 508           then call propagate_bit (s, set_bit);
 509           else if s -> symbol.auto | s -> symbol.defined
 510           then if s -> symbol.dcl_type ^= by_compiler       /* ck this because left_side bit not always set */
 511                then if s -> symbol.block_node ^= null
 512                     then if s -> symbol.block_node -> block.prologue_flag
 513                                                             /* are we processing prologue stmts? */
 514                          then call print (295);             /* invalid initialization of automatic variable */
 515 
 516           if tree -> reference.processed
 517           then if tree -> reference.array_ref | s -> symbol.structure
 518                then goto set_aggregate_bit;
 519                else goto ret;
 520 
 521           if s -> symbol.builtin
 522           then do;
 523                     if s -> symbol.c_dcl_size = 0
 524                     then do;
 525                               do i = 1 to number_of_names;
 526                                    if description (i).name = s -> symbol.token -> token.string
 527                                    then do;
 528                                              s -> symbol.c_dcl_size = i;
 529                                              goto call_builtin;
 530                                         end;
 531                               end;
 532 
 533                               call semantic_translator$abort (63, s);
 534                          end;
 535 
 536 call_builtin:
 537                     tree = builtin (blk, stmnt, tree, subs, s, context);
 538 
 539                     goto ret;
 540                end;
 541 
 542           if s -> symbol.generic
 543           then do;
 544                     tree = generic_selector (blk, stmnt, tree, subs, context);
 545                     goto ret;
 546                end;
 547 
 548 /* this is a variable or named constant. */
 549 /*   processing the qualifier   */
 550 
 551           if s -> symbol.based
 552           then if tree -> reference.qualifier ^= null
 553                then q = tree -> reference.qualifier;
 554                else if s -> symbol.reference -> reference.qualifier = null
 555                then if ^def_context.ignore_based
 556                     then call print (66);
 557                     else q = null;
 558                else q = copy_expression (s -> symbol.reference -> reference.qualifier);
 559 
 560           else if tree -> reference.qualifier ^= null
 561           then call print (67);
 562           else if ^s -> symbol.defined & s -> symbol.reference -> reference.qualifier ^= null
 563           then do;
 564                     q = s -> symbol.reference -> reference.qualifier;
 565                     if q -> node.type ^= reference_node
 566                     then q = copy_expression ((q));
 567                end;
 568           else q = null;
 569 
 570           if q ^= null
 571           then do;
 572                     if q -> node.type = symbol_node
 573                     then q = q -> symbol.reference;
 574 
 575                     if tree -> reference.qualifier = null
 576                     then p = s -> symbol.block_node;
 577                     else p = blk;
 578 
 579                     q = expression_semantics (p, stmnt, q, this_context);
 580 
 581                     if def_this_context.aggregate
 582                     then call print (68);
 583 
 584                     tree -> reference.qualifier, q = convert (q, pointer_type);
 585 
 586                     if q -> node.type = operator_node
 587                     then if q -> op_code = assign
 588                          then if q -> operand (2) -> reference.symbol -> symbol.offset
 589                               then do;
 590                                         q -> operator.processed = "0"b;
 591                                                             /* offset -> .... */
 592                                         tree -> reference.qualifier, q = operator_semantics (blk, stmnt, q, "0"b);
 593                                         q -> operator.processed = "1"b;
 594                                    end;
 595 
 596                     pl1_stat_$index = pl1_stat_$index + 1;
 597                     if pl1_stat_$index > 128
 598                     then call print (70);
 599                     pl1_stat_$locator (pl1_stat_$index) = tree;
 600                end;
 601 
 602 /*   processing the subscripts   */
 603 /*   calling subscripter or defined_reference   */
 604 /*   scalar, cross_section, or array(*,*,*)   */
 605 
 606           if s -> symbol.dimensioned & subs ^= null
 607           then do;
 608                     asterisk_count = 0;
 609 
 610                     do i = 1 to subs -> list.number;
 611                          if subs -> element (i) -> node.type = token_node
 612                          then if subs -> element (i) -> token.type = asterisk
 613                               then asterisk_count = asterisk_count + 1;
 614                     end;
 615 
 616                     if asterisk_count = subs -> list.number
 617                     then do;
 618                               subs = null;
 619                               tree -> reference.array_ref = "1"b;
 620 
 621                               cross_section = "0"b;
 622 
 623                               if def_context.arg_list & ^s -> symbol.defined
 624                               then goto process_ref_sons;
 625 
 626                               tree -> reference.offset = null;
 627 
 628                               if q ^= null
 629                               then pl1_stat_$index = pl1_stat_$index - 1;
 630 
 631                               goto set_aggregate_bit;
 632                          end;
 633                     else tree -> reference.array_ref, cross_section = asterisk_count ^= 0;
 634 
 635                     if cross_section & def_context.evaluate_offset
 636                     then if ^def_context.string_unspec
 637                          then call semantic_translator$abort (272, tree);
 638                          else do;
 639                                    pl1_stat_$index = pl1_stat_$index - 1;
 640 
 641                                    goto set_aggregate_bit;
 642                               end;
 643 
 644                     if def_context.arg_list
 645                     then do;
 646                               if cross_section
 647                               then do;
 648                                         tree -> reference.offset = subs;
 649                                         def_context.cross_section = "1"b;
 650 
 651                                         if q ^= null
 652                                         then pl1_stat_$index = pl1_stat_$index - 1;
 653 
 654                                         goto ret;
 655                                    end;
 656 
 657                               if s -> symbol.defined
 658                               then tree = defined_reference (blk, stmnt, tree, subs, s, context);
 659                               else tree = subscripter (blk, stmnt, tree, subs, s);
 660                          end;
 661 
 662                     else if ^(s -> symbol.structure | cross_section) | def_context.evaluate_offset
 663                     then if s -> symbol.defined
 664                          then tree = defined_reference (blk, stmnt, tree, subs, s, context);
 665                          else tree = subscripter (blk, stmnt, tree, subs, s);
 666 
 667                     if s -> symbol.entry & def_context.top & subs = null
 668                     then subs = create_list (0);
 669                end;
 670 
 671           else if subs ^= null & ^s -> symbol.entry
 672           then call neither_array_nor_entry;
 673 
 674 /*   array_reference, or undimensioned scalar   */
 675           else if s -> symbol.defined & ^s -> symbol.structure & ^tree -> reference.array_ref
 676           then tree = defined_reference (blk, stmnt, tree, subs, s, context);
 677 
 678 process_ref_sons:                                           /*   processing the offset   */
 679           if tree -> reference.offset ^= null
 680           then do;
 681                     tree -> reference.offset =
 682                          expression_semantics ((s -> symbol.block_node), stmnt, (tree -> reference.offset), "0"b);
 683                     tree -> reference.offset = convert$to_integer ((tree -> reference.offset), integer_type);
 684                end;
 685 
 686 /*   processing the length   */
 687 
 688           if tree -> reference.length ^= null
 689           then do;
 690                     tree -> reference.length =
 691                          expression_semantics ((s -> symbol.block_node), stmnt, (tree -> reference.length), "0"b);
 692                     tree -> reference.length = convert$to_integer ((tree -> reference.length), integer_type);
 693                end;
 694 
 695           call simplify_offset (tree, context);
 696 
 697           if def_this_context.aggregate
 698           then call print (73);
 699 
 700           if q ^= null
 701           then pl1_stat_$index = pl1_stat_$index - 1;
 702 
 703 /*   calls function   */
 704 
 705           if s -> symbol.entry
 706           then if subs ^= null
 707                then do;
 708                          if cross_section
 709                          then call print (72);
 710                          p = create_operator (std_arg_list, 3);
 711                          p -> operand (2) = subs;
 712                          q = create_operator (std_call, 3);
 713                          q -> operand (2) = tree;
 714                          q -> operand (3) = p;
 715                          tree = q;
 716 
 717                          tree = function (blk, stmnt, tree, s, context);
 718 
 719                          if tree -> node.type = operator_node
 720                          then tree -> operator.processed = "1"b;
 721                          else tree -> reference.processed = "1"b;
 722 
 723                          goto ret;
 724                     end;
 725 ^L
 726 set_aggregate_bit:                                          /*   turning on the aggregate bit   */
 727           tree -> reference.array_ref = tree -> reference.array_ref | cross_section;
 728 
 729           if subs ^= null
 730           then do;
 731 
 732 /* put back subs on the reference node for use by expand_primitive */
 733 
 734                     tree -> reference.offset = subs;
 735 
 736 /* undo work of simplify_offset to avoid DISASTER! */
 737 
 738                     tree -> reference.c_offset = s -> symbol.reference -> reference.c_offset;
 739                     tree -> reference.units = s -> symbol.reference -> reference.units;
 740                     string (tree -> reference.info.other) = "0"b;
 741                end;
 742 
 743           if pl1_stat_$LHS ^= null & ^def_context.left_side & ^def_context.evaluate_offset
 744           then stmnt -> statement.LHS_in_RHS = temp_needed (tree, cross_section);
 745 
 746           if tree -> reference.array_ref & s -> symbol.defined & ^s -> symbol.overlayed
 747           then def_context.cross_section = "1"b;
 748 
 749           if s -> symbol.structure | tree -> reference.array_ref
 750           then def_context.aggregate = "1"b;
 751 
 752           if ^def_context.ignore_based
 753           then tree -> reference.processed = "1"b;
 754 
 755           goto ret;
 756 ^L
 757 /* this is a reference to a label constant. */
 758 
 759 process_label:
 760           if s -> label.array
 761           then do;
 762                     if subs ^= null
 763                     then do;
 764                               if subs -> list.number ^= 1
 765                               then call print (80);
 766                               p = subs -> element (1);
 767                               if p -> node.type = token_node
 768                               then if p -> token.type = asterisk
 769                                    then cross_section = "1"b;
 770                          end;
 771 
 772                     if subs = null | cross_section
 773                     then do;
 774                               tree = create_reference (s);
 775                               tree -> reference.processed = "1"b;
 776                               tree -> reference.array_ref = "1"b;
 777                               def_context.aggregate = "1"b;
 778                               call increment_label_array_counts;
 779                               goto ret;
 780                          end;
 781 
 782                     tree = subscripter (blk, stmnt, tree, subs, s);
 783                     tree -> reference.offset = expression_semantics (blk, stmnt, (tree -> reference.offset), this_context);
 784                     call simplify_offset (tree, "0"b);
 785                     if def_this_context.aggregate
 786                     then call print (73);
 787                     tree -> reference.processed = "1"b;
 788 
 789                     if tree -> reference.offset = null
 790                     then do;
 791                               q = s -> label.statement -> list.element (tree -> reference.c_offset + 1);
 792                               if q ^= null
 793                               then q -> statement.reference_count = q -> statement.reference_count + 1;
 794                               else call print (494);
 795                          end;
 796                     else call increment_label_array_counts;
 797                end;
 798           else do;
 799                     if subs ^= null
 800                     then call neither_array_nor_entry;
 801 
 802                     if s -> label.statement ^= null
 803                     then s -> label.statement -> statement.reference_count =
 804                               s -> label.statement -> statement.reference_count + 1;
 805 
 806                     tree = s;
 807                end;
 808 
 809 ret:
 810           return (tree);
 811 ^L
 812 /* Is a temporary needed because of RHS-LHS overlap */
 813 
 814 temp_needed:
 815      procedure (RHS_ref, RHS_cross_section) returns (bit (1) aligned);
 816 
 817 /* parameters */
 818 
 819 dcl       RHS_ref             ptr parameter;
 820 dcl       RHS_cross_section   bit (1) aligned parameter;
 821 
 822 /* external static */
 823 
 824 dcl       (
 825           pl1_stat_$LHS,
 826           pl1_stat_$LHS_ref
 827           )                   ptr ext static;
 828 
 829 /* builtin */
 830 
 831 dcl       (null, string)      builtin;
 832 
 833 /* automatic */
 834 
 835 dcl       (LHS_ref, LHS_sym, RHS_sym)
 836                               ptr;
 837 dcl       t                   fixed bin;
 838 
 839           LHS_ref = pl1_stat_$LHS_ref;
 840           LHS_sym = pl1_stat_$LHS;
 841           RHS_sym = RHS_ref -> reference.symbol;
 842 
 843           if RHS_ref -> reference.array_ref
 844           then do;
 845 
 846                     if defined_on (RHS_sym, LHS_sym)
 847                     then return ("1"b);
 848 
 849                     if defined_on (LHS_sym, RHS_sym)
 850                     then return ("1"b);
 851 
 852                     if cross_section_overlap ()
 853                     then return ("1"b);
 854 
 855                end;
 856 
 857           if string_overlay_possible ()
 858           then return ("1"b);
 859 
 860           return ("0"b);
 861 ^L
 862 /* Is s1 defined on s2? */
 863 
 864 defined_on:
 865      procedure (s1, s2) returns (bit (1) aligned);
 866 
 867 /* parameters */
 868 
 869 dcl       (s1, s2)            ptr;
 870 
 871 /* automatic */
 872 
 873 dcl       s1_defined_on_s2    bit (1) aligned;
 874 
 875           if s1 -> symbol.defined & s1 -> symbol.equivalence ^= null
 876           then if s1 -> symbol.equivalence -> node.type = token_node
 877                then if s1 -> symbol.equivalence = s2 -> symbol.token
 878                     then s1_defined_on_s2 = "1"b;
 879                     else s1_defined_on_s2 = "0"b;
 880                else if s1 -> symbol.equivalence -> reference.symbol = s2
 881                then s1_defined_on_s2 = "1"b;
 882                else s1_defined_on_s2 = "0"b;
 883           else s1_defined_on_s2 = "0"b;
 884 
 885           return (s1_defined_on_s2);
 886 
 887      end /* defined_on */;
 888 
 889 /* If the RHS reference is a possible reference to a cross-section,
 890    determine if possible RHS-LHS overlap will require an aggregate temp */
 891 
 892 cross_section_overlap:
 893      procedure () returns (bit (1) aligned);
 894 
 895 /* The RHS reference is a possible cross-section reference if any of
 896    the following conditions are satisfied:
 897 
 898    (1)    An explicit cross-section reference was given (e.g. a(i,*));
 899           This would be indicated by RHS_cross_section.
 900 
 901    (2)    A reference to a parameter with star extents was given.  This
 902           is the only valid way a parameter may be aliased to a cross-section.
 903 
 904    (3)    A reference to a variable with the defined attribute was given.
 905           If this is isub defining, the variable may be a cross-section of
 906           an array.
 907 
 908    Note:  These tests are rather crude; future implementations should attempt
 909           to refine them or to substitute a more systematic approach.
 910                                                                       */
 911 
 912 /* automatic */
 913 
 914 dcl       (RHS_subs, LHS_subs)
 915                               ptr;
 916 
 917           if (RHS_cross_section | (RHS_sym -> symbol.parameter & RHS_sym -> symbol.star_extents) | RHS_sym -> symbol.defined)
 918                & (LHS_sym -> symbol.based | LHS_sym -> symbol.defined | LHS_sym -> symbol.parameter)
 919                & LHS_sym -> symbol.dimensioned & string (LHS_sym -> symbol.data_type) = string (RHS_sym -> symbol.data_type)
 920           then return ("1"b);
 921 
 922           if LHS_sym = RHS_sym & RHS_cross_section
 923           then do;
 924                     LHS_subs = LHS_ref -> reference.offset;
 925                     RHS_subs = RHS_ref -> reference.offset;
 926 
 927                     if LHS_subs = null | RHS_subs = null
 928                     then return ("1"b);
 929                     else if LHS_subs -> node.type ^= list_node | RHS_subs -> node.type ^= list_node
 930                     then return ("1"b);
 931                     else return (^stars_match ());
 932 
 933                end;
 934 
 935           return ("0"b);
 936 
 937 /* Determine if two unprocessed subscript lists have asterisks in
 938    corresponding positions. E.g., (*,i) and (*,i+1) do, and (*,i) and (i+1,*)
 939    don't. */
 940 
 941 stars_match:
 942      procedure () returns (bit (1) aligned);
 943 
 944 /* automatic */
 945 
 946 dcl       i                   fixed bin;
 947 
 948           do i = 1 to LHS_subs -> list.number;
 949                if is_star ((LHS_subs -> list.element (i))) ^= is_star ((RHS_subs -> list.element (i)))
 950                then return ("0"b);
 951           end;
 952 
 953           return ("1"b);
 954 
 955 /* Determine if a subscript is an asterisk (denotes a cross-section) */
 956 
 957 is_star:
 958      procedure (subscript) returns (bit (1) aligned);
 959 
 960 /* parameter */
 961 
 962 dcl       subscript           ptr;
 963 
 964           if subscript -> node.type ^= token_node
 965           then return ("0"b);
 966 
 967           if subscript -> token.type ^= asterisk
 968           then return ("0"b);
 969 
 970           return ("1"b);
 971 
 972      end /* is_star */;
 973 
 974      end /* stars_match */;
 975 
 976      end /* cross_section_overlap */;
 977 
 978 /* Check for a possible string overlay--one that is valid PL/I
 979    If it is possible for both references to string overlay define one
 980    other, excluding the case of references to the same generation of
 981    storage, a temporary is needed */
 982 
 983 string_overlay_possible:
 984      procedure () returns (bit (1) aligned);
 985 
 986           t = 0;
 987 
 988           if LHS_sym -> symbol.aliasable & RHS_sym -> symbol.aliasable & LHS_sym -> symbol.packed & RHS_sym -> symbol.packed
 989                & ^compare_expression (LHS_ref, RHS_ref) & string_overlay (LHS_sym) & string_overlay (RHS_sym)
 990           then do;
 991 
 992                     if RHS_sym -> symbol.father ^= null
 993                     then return ("1"b);
 994 
 995                     if RHS_sym -> symbol.based | RHS_sym -> symbol.defined | RHS_sym -> symbol.parameter
 996                     then return ("1"b);
 997 
 998                end;
 999 
1000           return ("0"b);
1001 
1002      end /* string_overlay_possible */;
1003 %include string_overlay;
1004      end /* temp_needed */;
1005 ^L
1006 /* increments reference counts of all statements pointed at by label array */
1007 
1008 increment_label_array_counts:
1009      proc;
1010 
1011 dcl       (q, vector)         ptr;
1012 dcl       i                   fixed bin;
1013 
1014           vector = s -> label.statement;
1015           do i = 1 to vector -> list.number;
1016                q = vector -> list.element (i);
1017                if q ^= null
1018                then q -> statement.reference_count = q -> statement.reference_count + 1;
1019           end;
1020 
1021      end;
1022 ^L
1023 
1024 /* subroutine to print an error message */
1025 
1026 print:
1027      proc (m);
1028 
1029 dcl       m                   fixed bin (15);
1030 
1031           if tree -> node.type = operator_node
1032           then p = null;
1033           else p = tree;
1034 
1035           call semantic_translator$abort (m, p);
1036 
1037      end;
1038 ^L
1039 /* prints appropriate error message */
1040 
1041 neither_array_nor_entry:
1042      proc;
1043 
1044 dcl       errno               fixed bin (15);
1045 
1046           if def_context.top & stmnt -> statement.statement_type = call_statement
1047           then errno = 224;                                 /* used $ where entry value needed */
1048           else errno = 370;                                 /* $ was followed by parenthesized list & is neither array nor entry */
1049 
1050           call print (errno);
1051 
1052      end;
1053 ^L
1054 %include semant;
1055 %include block;
1056 %include block_types;
1057 %include boundary;
1058 %include builtin_table;
1059 %include cross_reference;
1060 %include declare_type;
1061 %include label;
1062 %include list;
1063 %include nodes;
1064 %include op_codes;
1065 %include operator;
1066 %include reference;
1067 %include semantic_bits;
1068 %include statement;
1069 %include symbol;
1070 %include symbol_bits;
1071 %include system;
1072 %include token;
1073 %include token_types;
1074 %include statement_types;
1075 ^L
1076      end expression_semantics;